<commit_before>{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
-- | Real run interpreter
module Biegunka.Execute (run, execute) where

import           Control.Applicative
import           Control.Monad
import           Control.Exception (Exception, SomeException(..), throwIO)
import qualified Control.Exception as E
import           Data.Foldable (traverse_)
import           Data.List ((\\))
import           Prelude hiding (log)
import           System.Exit (ExitCode(..))
import           System.IO.Error (tryIOError)

import           Control.Concurrent.STM.TQueue (writeTQueue)
import           Control.Concurrent.STM.TVar (readTVar, modifyTVar, writeTVar)
import           Control.Concurrent.STM (atomically)
import           Control.Lens hiding (op)
import           Control.Monad.Free (Free(..))
import           Control.Monad.State (runStateT, get, put)
import           Control.Monad.Trans (MonadIO, liftIO)
import           Data.Default (def)
import           Data.Proxy
import           Data.Reflection
import           Data.Functor.Trans.Tagged
import qualified Data.Set as S
import           Data.Text.Lazy (toStrict)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import           System.Directory
  ( removeDirectoryRecursive, removeFile, copyFile, createDirectoryIfMissing )
import           System.FilePath (dropFileName)
import           System.Posix.Files (createSymbolicLink, removeLink)
import           System.Posix.Env (getEnv)
import           System.Posix.User (getEffectiveUserID, getUserEntryForName, userID, setEffectiveUserID)
import           System.Process

import Biegunka.Control (Interpreter(..), interpret, logger)
import Biegunka.DB
import Biegunka.Execute.Control
import Biegunka.Execute.Exception
import Biegunka.Execute.Describe (describe, action, exception, retryCounter)
import Biegunka.Language (EL(..), A(..), S(..), M(..), React(..), peek)
import Biegunka.Execute.Schedule (runTask, schedule)
import Biegunka.Script


-- | Real run interpreter
run :: (EE () -> EE ()) -> Interpreter
run e = interpret $ \c s -> do
  let b = construct s
  a <- load c s
  (controls .~ c -> e') <- initializeSTM (e def)
  when (e' ^. priviledges == Drop) $ getEnv "SUDO_USER" >>= traverse_ setUser
  runTask e' def newTask s
  atomically (writeTQueue (e'^.stm.work) (Stop 0)) -- Can we assume script starts from id 0?
  schedule (e'^.stm.work)
  mapM_ (tryIOError . removeFile) (filepaths a \\ filepaths b)
  mapM_ (tryIOError . removeDirectoryRecursive) (sources a \\ sources b)
  save c b
 where
  setUser n = getUserEntryForName n >>= setEffectiveUserID . userID

-- | Real run interpreter
execute :: (EE () -> EE ()) -> Interpreter
execute = run
{-# DEPRECATED execute "Please, use `run'" #-}


-- | Run single task command by command
--
-- "Forks" on 'Task' 'True'.
-- Note: current thread continues to execute what's inside task, but all the other stuff is queued
--
-- Complexity comes from forking and responding to errors. Otherwise that is dead simple function
task :: Reifies t (EE STM) => Free (EL SA s) a -> Execution t ()
task (Free (EP _ _ b d)) = do
  newTask d
  task b
task (Free c@(ES _ _ b d)) = do
  newTask d
  try (command c) >>= \e -> case e of
    Left e' -> retry e' >>= \r -> case r of
      Retry    -> task (Free (Pure () <$ c))<commit_msg>Make dropPriviledges a separate function.<commit_after>{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
-- | Real run interpreter
module Biegunka.Execute (run, execute) where

import           Control.Applicative
import           Control.Monad
import           Control.Exception (Exception, SomeException(..), throwIO)
import qualified Control.Exception as E
import           Data.Foldable (traverse_)
import           Data.List ((\\))
import           Prelude hiding (log)
import           System.Exit (ExitCode(..))
import           System.IO.Error (tryIOError)

import           Control.Concurrent.STM.TQueue (writeTQueue)
import           Control.Concurrent.STM.TVar (readTVar, modifyTVar, writeTVar)
import           Control.Concurrent.STM (atomically)
import           Control.Lens hiding (op)
import           Control.Monad.Free (Free(..))
import           Control.Monad.State (runStateT, get, put)
import           Control.Monad.Trans (MonadIO, liftIO)
import           Data.Default (def)
import           Data.Proxy
import           Data.Reflection
import           Data.Functor.Trans.Tagged
import qualified Data.Set as S
import           Data.Text.Lazy (toStrict)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import           System.Directory
  ( removeDirectoryRecursive, removeFile, copyFile, createDirectoryIfMissing )
import           System.FilePath (dropFileName)
import           System.Posix.Files (createSymbolicLink, removeLink)
import           System.Posix.Env (getEnv)
import           System.Posix.User (getEffectiveUserID, getUserEntryForName, userID, setEffectiveUserID)
import           System.Process

import Biegunka.Control (Interpreter(..), interpret, logger)
import Biegunka.DB
import Biegunka.Execute.Control
import Biegunka.Execute.Exception
import Biegunka.Execute.Describe (describe, action, exception, retryCounter)
import Biegunka.Language (EL(..), A(..), S(..), M(..), React(..), peek)
import Biegunka.Execute.Schedule (runTask, schedule)
import Biegunka.Script


-- | Real run interpreter
run :: (EE () -> EE ()) -> Interpreter
run e = interpret $ \c s -> do
  let b = construct s
  a <- load c s
  (controls .~ c -> e') <- initializeSTM (e def)
  dropPriviledges e'
  runTask e' def newTask s
  atomically (writeTQueue (e'^.stm.work) (Stop 0)) -- Can we assume script starts from id 0?
  schedule (e'^.stm.work)
  mapM_ (tryIOError . removeFile) (filepaths a \\ filepaths b)
  mapM_ (tryIOError . removeDirectoryRecursive) (sources a \\ sources b)
  save c b

-- | Real run interpreter
execute :: (EE () -> EE ()) -> Interpreter
execute = run
{-# DEPRECATED execute "Please, use `run'" #-}

dropPriviledges :: EE a -> IO ()
dropPriviledges e =
  case e^.priviledges of
    Drop     -> getEnv "SUDO_USER" >>= traverse_ setUser
    Preserve -> return ()
 where
  setUser n = getUserEntryForName n >>= setEffectiveUserID . userID


-- | Run single task command by command
--
-- "Forks" on 'Task' 'True'.
-- Note: current thread continues to execute what's inside task, but all the other stuff is queued
--
-- Complexity comes from forking and responding to errors. Otherwise that is dead simple function
task :: Reifies t (EE STM) => Free (EL SA s) a -> Execution t ()
task (Free (EP _ _ b d)) = do
  newTask d
  task b
task (Free c@(ES _ _ b d)) = do
  newTask d
  try (command c) >>= \e -> case e of
    Left e' -> retry e' >>= \r -> case r of
      Retry    -> task (Free (Pure () <$ c))
{'fraction_non_alphanumeric': 0.11606762324193777, 'fraction_numerical': 0.000568262537292229, 'mean_word_length': 2.9329608938547485, 'pattern_counts': {'":': 0, '<': 9, '<?xml version=': 0, '>': 46, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '4002588', 'n_tokens_mistral': 2213, 'n_tokens_neox': 2180, 'n_words': 697}