module Control.Biegunka.Execute
( run, dryRun
) where
import Control.Applicative
import Control.Monad
import Prelude hiding (log, null)
import System.IO.Error (tryIOError)
import Control.Concurrent (forkFinally)
import Control.Concurrent.STM.TVar (readTVar, modifyTVar, writeTVar)
import Control.Concurrent.STM (atomically, retry)
import Control.Lens hiding (op)
import Control.Monad.Catch
(SomeException, bracket, bracket_, onException, throwM, try)
import Control.Monad.Free (Free(..))
import Control.Monad.Trans (MonadIO, liftIO)
import Data.Functor.Trans.Tagged (untag)
import Data.Default.Class (Default(..))
import Data.Proxy (Proxy)
import Data.Reflection (Reifies, reify)
import qualified Data.Set as S
import qualified Data.Text.IO as T
import qualified System.Directory as D
import System.FilePath (dropFileName)
import System.Posix.Files (createSymbolicLink, removeLink)
import System.Posix.User
( getEffectiveUserID, getEffectiveGroupID
, setEffectiveUserID, setEffectiveGroupID
, getUserEntryForName, userID
, getGroupEntryForID, getGroupEntryForName, groupID
)
import qualified System.Process as P
import Control.Biegunka.Action (copy, applyPatch, verifyAppliedPatch)
import qualified Control.Biegunka.Log as Log
import Control.Biegunka.Settings
(Settings, Templates(..), templates, local, logger, colors, Mode(..), mode)
import qualified Control.Biegunka.Groups as Groups
import Control.Biegunka.Execute.Settings
import Control.Biegunka.Execute.Describe
(termDescription, runChanges, action, exception, removal, retryCounter)
import Control.Biegunka.Execute.Exception
import Control.Biegunka.Language
import Control.Biegunka.Biegunka (Interpreter, interpretOptimistically)
import qualified Control.Biegunka.Execute.Watcher as Watcher
import Control.Biegunka.Script
run :: Interpreter
run = interpretOptimistically go where
go settings s = do
let db' = Groups.fromScript s
bracket (Groups.open settings) Groups.close $ \db -> do
bracket getEffectiveUserID setEffectiveUserID $ \_ ->
bracket getEffectiveGroupID setEffectiveGroupID $ \_ ->
bracket Watcher.new Watcher.wait $ \watcher -> do
r <- initializeSTM watcher
runTask (settings & local .~ r) (task (settings^.mode.to io) def) s
mapM_ (safely remove) (Groups.diff Groups.files (db^.Groups.these) db')
mapM_ (safely removeDirectory) (Groups.diff Groups.sources (db^.Groups.these) db')
Groups.commit (db & Groups.these .~ db')
where
io Offline = runIOOffline
io Online = runIOOnline
remove path = do
file <- D.doesFileExist path
case file of
True -> do
Log.write (settings^.logger) $
Log.plain (removal path)
D.removeFile path
False -> D.removeDirectoryRecursive path
removeDirectory path = do
directory <- D.doesDirectoryExist path
case directory of
True -> do
Log.write (settings^.logger) $
Log.plain (removal path)
D.removeDirectoryRecursive path
False -> return ()
safely doThings = tryIOError . doThings
dryRun :: Interpreter
dryRun = interpretOptimistically $ \settings s -> do
let db' = Groups.fromScript s
bracket (Groups.open settings) Groups.close $ \db -> do
bracket Watcher.new Watcher.wait $ \watcher -> do
r <- initializeSTM watcher
runTask (settings & local .~ r) (task runPure def) s
Log.write (settings^.logger) $
Log.plain (runChanges (settings^.colors) db db')
runTask
:: forall s m. MonadIO m
=> Settings Execution
-> (forall t. Reifies t (Settings Execution) => Free (Term Annotate s) () -> Executor t ())
-> Free (Term Annotate s) ()
-> m ()
runTask e f s = do
Watcher.register (e^.watch)
liftIO $ forkFinally (reify e (untag . asProxyOf (f s))) (\_ -> Watcher.unregister (e^.watch))
return ()
asProxyOf :: Executor s () -> Proxy s -> Executor s ()
asProxyOf a _ = a
task
:: forall t. Reifies t (Settings Execution)
=> (forall s b t'. Reifies t' (Settings Execution) => Term Annotate s b -> Executor t' (IO ()))
-> Retry
-> Free (Term Annotate Sources) ()
-> Executor t ()
task f = go
where
go
:: Reifies t (Settings Execution)
=> Retry
-> Free (Term Annotate Sources) ()
-> Executor t ()
go retries (Free c@(TS _ _ _ t@(Free _))) = do
e <- env
runTask e (task f def) t
go retries (Free (Pure () <$ c))
go retries (Free c@(TS (AS { asToken }) _ b (Pure _))) = do
try (command f c) >>= \case
Left e -> checkRetryCount retries (getRetries c) e >>= \case
True -> go (incr retries) (Free (Pure () <$ c))
False -> case getReaction c of
Abortive -> doneWith asToken
Ignorant -> do
taskAction f def b
doneWith asToken
Right _ -> do
taskAction f def b
doneWith asToken
go _ (Free c@(TM _ x)) = do
command f c
go def x
go _ (Pure _) = return ()
taskAction
:: forall t. Reifies t (Settings Execution)
=> (forall a s. Term Annotate s a -> Executor t (IO ()))
-> Retry
-> Free (Term Annotate Actions) ()
-> Executor t ()
taskAction f = go
where
go
:: Reifies t (Settings Execution)
=> Retry
-> Free (Term Annotate Actions) a
-> Executor t ()
go retries a@(Free c@(TA _ _ x)) =
try (command f c) >>= \case
Left e -> checkRetryCount retries (getRetries c) e >>= \case
True -> go (incr retries) a
False -> case getReaction c of
Abortive -> return ()
Ignorant -> go def x
Right _ -> go def x
go _ (Free c@(TM _ x)) = do
command f c
go def x
go _ (Pure _) = return ()
checkRetryCount
:: forall s. Reifies s (Settings Execution)
=> Retry
-> Retry
-> SomeException
-> Executor s Bool
checkRetryCount doneRetries maximumRetries exc = do
log <- env^!acts.logger
scm <- env^!acts.colors
liftIO $ do
Log.write log $
Log.exception (termDescription (exception scm exc))
if doneRetries < maximumRetries then do
Log.write log $
Log.exception (termDescription $
retryCounter scm (unRetry (incr doneRetries)) (unRetry maximumRetries))
return True
else
return False
command
:: Reifies t (Settings Execution)
=> (Term Annotate s a -> Executor t (IO ()))
-> Term Annotate s a
-> Executor t ()
command _ (TM (Wait waits) _) = do
watcher <- env^!acts.watch
Watcher.waitDone watcher waits
command getIO term = do
users <- env^!acts.user
io <- getIO term
liftIO $ case getUser term of
Nothing ->
io
Just (UserW u) -> do
gid <- getGID u
uid <- getUID u
bracket_ (acquire users uid) (release users uid) $ do
setEffectiveGroupID gid
setEffectiveUserID uid
io
where
acquire users uid = atomically $ do
mu <- readTVar users
case mu^.at uid of
Nothing
| null mu ->
writeTVar users (mu & at uid ?~ 1)
| otherwise ->
retry
Just _ ->
writeTVar users (mu & ix uid +~ 1)
release users uid = atomically $
modifyTVar users (at uid . non 0 -~ 1)
getUID (UserID i) = return i
getUID (Username n) = userID <$> getUserEntryForName n
getGID (UserID i) = groupID <$> getGroupEntryForID (fromIntegral i)
getGID (Username n) = groupID <$> getGroupEntryForName n
runIOOnline
:: Reifies t (Settings Execution)
=> Term Annotate s a
-> Executor t (IO ())
runIOOnline term = do
log <- env^!acts.logger
scm <- env^!acts.colors
io <- ioOnline term
let message = Log.write log (Log.plain (termDescription (action scm term)))
return (message *> io)
ioOnline
:: Reifies t (Settings Execution)
=> Term Annotate s a
-> Executor t (IO ())
ioOnline term = case term of
TS _ (Source _ _ dst update) _ _ -> do
rstv <- env^!acts.repos
return $ do
updated <- atomically $ do
rs <- readTVar rstv
if dst `S.member` rs
then return True
else do
writeTVar rstv $ S.insert dst rs
return False
unless updated $ do
D.createDirectoryIfMissing True $ dropFileName dst
update dst
`onException`
atomically (modifyTVar rstv (S.delete dst))
TA _ (Link src dst) _ -> return $ overWriteWith createSymbolicLink src dst
TA _ (Copy src dst spec) _ -> return $ do
try (D.removeDirectoryRecursive dst) :: IO (Either IOError ())
D.createDirectoryIfMissing True $ dropFileName dst
copy src dst spec
TA _ (Template src dst substitute) _ -> do
Templates ts <- env^!acts.templates
return $
overWriteWith (\s d -> T.writeFile d . substitute ts =<< T.readFile s) src dst
TA _ (Command p spec) _ -> return $ do
(_, _, Just errors, ph) <- P.createProcess $
P.CreateProcess
{ P.cmdspec = spec
, P.cwd = Just p
, P.env = Nothing
, P.std_in = P.Inherit
, P.std_out = P.CreatePipe
, P.std_err = P.CreatePipe
, P.close_fds = False
, P.create_group = False
}
e <- P.waitForProcess ph
e `onFailure` \status ->
T.hGetContents errors >>= throwM . ShellException spec status
TA _ (Patch patch file spec) _ -> return $ do
verified <- verifyAppliedPatch patch file spec
unless verified $
applyPatch patch file spec
TM _ _ -> return $ return ()
where
overWriteWith g src dst = do
D.createDirectoryIfMissing True $ dropFileName dst
tryIOError (removeLink dst)
g src dst
runIOOffline
:: Reifies t (Settings Execution)
=> Term Annotate s a
-> Executor t (IO ())
runIOOffline t@(TS {}) = runPure t
runIOOffline t = runIOOnline t
runPure
:: (Applicative m, Reifies t (Settings Execution))
=> Term Annotate s a
-> Executor t (m ())
runPure _ = pure (pure ())
doneWith :: Reifies t (Settings Execution) => Token -> Executor t ()
doneWith tok = do
watcher <- env^!acts.watch
Watcher.done watcher tok
getRetries :: Term Annotate s a -> Retry
getRetries (TS (AS { asMaxRetries }) _ _ _) = asMaxRetries
getRetries (TA (AA { aaMaxRetries }) _ _) = aaMaxRetries
getRetries (TM _ _) = def
getUser :: Term Annotate s a -> Maybe UserW
getUser (TS (AS { asUser }) _ _ _) = asUser
getUser (TA (AA { aaUser }) _ _) = aaUser
getUser (TM _ _) = Nothing
getReaction :: Term Annotate s a -> React
getReaction (TS (AS { asReaction }) _ _ _) = asReaction
getReaction (TA (AA { aaReaction }) _ _) = aaReaction
getReaction (TM _ _) = Ignorant