{-# LANGUAGE PackageImports #-}
{-# LANGUAGE DataKinds #-}
module Propellor.Engine (
mainProperties,
runPropellor,
ensureChildProperties,
fromHost,
fromHost',
onlyProcess,
chainPropellor,
runChainPropellor,
) where
import System.Exit
import System.IO
import Data.Monoid
import "mtl" Control.Monad.RWS.Strict
import System.Posix.Files
import System.Posix.IO
import System.FilePath
import System.Console.Concurrent
import Control.Applicative
import Control.Concurrent.Async
import Prelude
import Propellor.Types
import Propellor.Types.MetaTypes
import Propellor.Types.Core
import Propellor.Message
import Propellor.Exception
import Propellor.Info
import Utility.Exception
import Utility.Directory
import Utility.Process
import Utility.PartialPrelude
mainProperties :: Host -> IO ()
mainProperties :: Host -> IO ()
mainProperties Host
host = do
Result
ret <- Host -> Propellor Result -> IO Result
runPropellor Host
host (Propellor Result -> IO Result) -> Propellor Result -> IO Result
forall a b. (a -> b) -> a -> b
$ [ChildProperty] -> Propellor Result
ensureChildProperties [Property (MetaTypes '[]) -> ChildProperty
forall p. IsProp p => p -> ChildProperty
toChildProperty Property (MetaTypes '[])
overall]
IO ()
messagesDone
case Result
ret of
Result
FailedChange -> ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
1)
Result
_ -> ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith ExitCode
ExitSuccess
where
overall :: Property (MetaTypes '[])
overall :: Property (MetaTypes '[])
overall = [Char] -> Propellor Result -> Property (MetaTypes '[])
forall {k} (metatypes :: k).
SingI metatypes =>
[Char] -> Propellor Result -> Property (MetaTypes metatypes)
property [Char]
"overall" (Propellor Result -> Property (MetaTypes '[]))
-> Propellor Result -> Property (MetaTypes '[])
forall a b. (a -> b) -> a -> b
$
[ChildProperty] -> Propellor Result
ensureChildProperties (Host -> [ChildProperty]
hostProperties Host
host)
runPropellor :: Host -> Propellor Result -> IO Result
runPropellor :: Host -> Propellor Result -> IO Result
runPropellor Host
host Propellor Result
a = do
(Result
res, [EndAction]
endactions) <- RWST Host [EndAction] () IO Result
-> Host -> () -> IO (Result, [EndAction])
forall (m :: * -> *) r w s a.
Monad m =>
RWST r w s m a -> r -> s -> m (a, w)
evalRWST (Propellor Result -> RWST Host [EndAction] () IO Result
forall p. Propellor p -> RWST Host [EndAction] () IO p
runWithHost Propellor Result
a) Host
host ()
[Result]
endres <- (EndAction -> IO Result) -> [EndAction] -> IO [Result]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Host -> Result -> EndAction -> IO Result
runEndAction Host
host Result
res) [EndAction]
endactions
Result -> IO Result
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Result -> IO Result) -> Result -> IO Result
forall a b. (a -> b) -> a -> b
$ [Result] -> Result
forall a. Monoid a => [a] -> a
mconcat (Result
resResult -> [Result] -> [Result]
forall a. a -> [a] -> [a]
:[Result]
endres)
runEndAction :: Host -> Result -> EndAction -> IO Result
runEndAction :: Host -> Result -> EndAction -> IO Result
runEndAction Host
host Result
res (EndAction [Char]
desc Result -> Propellor Result
a) = [Char] -> [Char] -> IO Result -> IO Result
forall (m :: * -> *) r.
(MonadIO m, MonadMask m, ActionResult r, ToResult r) =>
[Char] -> [Char] -> m r -> m r
actionMessageOn (Host -> [Char]
hostName Host
host) [Char]
desc (IO Result -> IO Result) -> IO Result -> IO Result
forall a b. (a -> b) -> a -> b
$ do
(Result
ret, ()
_s, [EndAction]
_) <- RWST Host [EndAction] () IO Result
-> Host -> () -> IO (Result, (), [EndAction])
forall r w s (m :: * -> *) a.
RWST r w s m a -> r -> s -> m (a, s, w)
runRWST (Propellor Result -> RWST Host [EndAction] () IO Result
forall p. Propellor p -> RWST Host [EndAction] () IO p
runWithHost (Propellor Result -> Propellor Result
forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
m Result -> m Result
catchPropellor (Result -> Propellor Result
a Result
res))) Host
host ()
Result -> IO Result
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Result
ret
ensureChildProperties :: [ChildProperty] -> Propellor Result
ensureChildProperties :: [ChildProperty] -> Propellor Result
ensureChildProperties [ChildProperty]
ps = [ChildProperty] -> Result -> Propellor Result
forall {p}. IsProp p => [p] -> Result -> Propellor Result
ensure [ChildProperty]
ps Result
NoChange
where
ensure :: [p] -> Result -> Propellor Result
ensure [] Result
rs = Result -> Propellor Result
forall a. a -> Propellor a
forall (m :: * -> *) a. Monad m => a -> m a
return Result
rs
ensure (p
p:[p]
ls) Result
rs = do
[Char]
hn <- (Host -> [Char]) -> Propellor [Char]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Host -> [Char]
hostName
Result
r <- Propellor Result
-> (Propellor Result -> Propellor Result)
-> Maybe (Propellor Result)
-> Propellor Result
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Result -> Propellor Result
forall a. a -> Propellor a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Result
NoChange)
([Char] -> [Char] -> Propellor Result -> Propellor Result
forall (m :: * -> *) r.
(MonadIO m, MonadMask m, ActionResult r, ToResult r) =>
[Char] -> [Char] -> m r -> m r
actionMessageOn [Char]
hn (p -> [Char]
forall p. IsProp p => p -> [Char]
getDesc p
p) (Propellor Result -> Propellor Result)
-> (Propellor Result -> Propellor Result)
-> Propellor Result
-> Propellor Result
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Propellor Result -> Propellor Result
forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
m Result -> m Result
catchPropellor)
(p -> Maybe (Propellor Result)
forall p. IsProp p => p -> Maybe (Propellor Result)
getSatisfy p
p)
[p] -> Result -> Propellor Result
ensure [p]
ls (Result
r Result -> Result -> Result
forall a. Semigroup a => a -> a -> a
<> Result
rs)
fromHost :: [Host] -> HostName -> Propellor a -> Propellor (Maybe a)
fromHost :: forall a. [Host] -> [Char] -> Propellor a -> Propellor (Maybe a)
fromHost [Host]
l [Char]
hn Propellor a
getter = case [Host] -> [Char] -> Maybe Host
findHost [Host]
l [Char]
hn of
Maybe Host
Nothing -> Maybe a -> Propellor (Maybe a)
forall a. a -> Propellor a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
Just Host
h -> a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> Propellor a -> Propellor (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Host -> Propellor a -> Propellor a
forall a. Host -> Propellor a -> Propellor a
fromHost' Host
h Propellor a
getter
fromHost' :: Host -> Propellor a -> Propellor a
fromHost' :: forall a. Host -> Propellor a -> Propellor a
fromHost' Host
h Propellor a
getter = do
(a
ret, ()
_s, [EndAction]
runlog) <- IO (a, (), [EndAction]) -> Propellor (a, (), [EndAction])
forall a. IO a -> Propellor a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (a, (), [EndAction]) -> Propellor (a, (), [EndAction]))
-> IO (a, (), [EndAction]) -> Propellor (a, (), [EndAction])
forall a b. (a -> b) -> a -> b
$ RWST Host [EndAction] () IO a
-> Host -> () -> IO (a, (), [EndAction])
forall r w s (m :: * -> *) a.
RWST r w s m a -> r -> s -> m (a, s, w)
runRWST (Propellor a -> RWST Host [EndAction] () IO a
forall p. Propellor p -> RWST Host [EndAction] () IO p
runWithHost Propellor a
getter) Host
h ()
[EndAction] -> Propellor ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [EndAction]
runlog
a -> Propellor a
forall a. a -> Propellor a
forall (m :: * -> *) a. Monad m => a -> m a
return a
ret
onlyProcess :: FilePath -> IO a -> IO a
onlyProcess :: forall a. [Char] -> IO a -> IO a
onlyProcess [Char]
lockfile IO a
a = IO Fd -> (Fd -> IO ()) -> (Fd -> IO a) -> IO a
forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket IO Fd
lock Fd -> IO ()
unlock (IO a -> Fd -> IO a
forall a b. a -> b -> a
const IO a
a)
where
lock :: IO Fd
lock = do
Bool -> [Char] -> IO ()
createDirectoryIfMissing Bool
True ([Char] -> [Char]
takeDirectory [Char]
lockfile)
Fd
l <- [Char] -> FileMode -> IO Fd
createFile [Char]
lockfile FileMode
stdFileMode
Fd -> FdOption -> Bool -> IO ()
setFdOption Fd
l FdOption
CloseOnExec Bool
True
Fd -> FileLock -> IO ()
setLock Fd
l (LockRequest
WriteLock, SeekMode
AbsoluteSeek, FileOffset
0, FileOffset
0)
IO () -> (IOException -> IO ()) -> IO ()
forall (m :: * -> *) a.
MonadCatch m =>
m a -> (IOException -> m a) -> m a
`catchIO` IO () -> IOException -> IO ()
forall a b. a -> b -> a
const IO ()
forall {a}. a
alreadyrunning
Fd -> IO Fd
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Fd
l
unlock :: Fd -> IO ()
unlock = Fd -> IO ()
closeFd
alreadyrunning :: a
alreadyrunning = [Char] -> a
forall a. [Char] -> a
giveup [Char]
"Propellor is already running on this host!"
chainPropellor :: CreateProcess -> IO Result
chainPropellor :: CreateProcess -> IO Result
chainPropellor CreateProcess
p =
CreateProcessRunner
-> CreateProcess -> ((Handle, Handle) -> IO Result) -> IO Result
forall a.
CreateProcessRunner
-> CreateProcess -> ((Handle, Handle) -> IO a) -> IO a
withOEHandles CreateProcess
-> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> IO a)
-> IO a
CreateProcessRunner
createProcessSuccess CreateProcess
p (((Handle, Handle) -> IO Result) -> IO Result)
-> ((Handle, Handle) -> IO Result) -> IO Result
forall a b. (a -> b) -> a -> b
$ \(Handle
outh, Handle
errh) -> do
(Result
r, ()) <- Handle -> IO Result
processChainOutput Handle
outh
IO Result -> IO () -> IO (Result, ())
forall a b. IO a -> IO b -> IO (a, b)
`concurrently` Handle -> IO ()
forwardChainError Handle
errh
Result -> IO Result
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Result
r
processChainOutput :: Handle -> IO Result
processChainOutput :: Handle -> IO Result
processChainOutput Handle
h = Maybe [Char] -> IO Result
go Maybe [Char]
forall a. Maybe a
Nothing
where
go :: Maybe [Char] -> IO Result
go Maybe [Char]
lastline = do
Maybe [Char]
v <- IO [Char] -> IO (Maybe [Char])
forall (m :: * -> *) a. MonadCatch m => m a -> m (Maybe a)
catchMaybeIO (Handle -> IO [Char]
hGetLine Handle
h)
case Maybe [Char]
v of
Maybe [Char]
Nothing -> case Maybe [Char]
lastline of
Maybe [Char]
Nothing -> do
Result -> IO Result
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Result
FailedChange
Just [Char]
l -> case [Char] -> Maybe Result
forall a. Read a => [Char] -> Maybe a
readish [Char]
l of
Just Result
r -> Result -> IO Result
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Result
r
Maybe Result
Nothing -> do
[Char] -> IO ()
forall v. Outputable v => v -> IO ()
outputConcurrent ([Char]
l [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n")
Result -> IO Result
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Result
FailedChange
Just [Char]
s -> do
[Char] -> IO ()
forall v. Outputable v => v -> IO ()
outputConcurrent ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$
[Char] -> ([Char] -> [Char]) -> Maybe [Char] -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"" (\[Char]
l -> if [Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
l then [Char]
"" else [Char]
l [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n") Maybe [Char]
lastline
Maybe [Char] -> IO Result
go ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
s)
forwardChainError :: Handle -> IO ()
forwardChainError :: Handle -> IO ()
forwardChainError Handle
h = do
Maybe [Char]
v <- IO [Char] -> IO (Maybe [Char])
forall (m :: * -> *) a. MonadCatch m => m a -> m (Maybe a)
catchMaybeIO (Handle -> IO [Char]
hGetLine Handle
h)
case Maybe [Char]
v of
Maybe [Char]
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just [Char]
s -> do
[Char] -> IO ()
forall v. Outputable v => v -> IO ()
errorConcurrent ([Char]
s [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n")
Handle -> IO ()
forwardChainError Handle
h
runChainPropellor :: Host -> Propellor Result -> IO ()
runChainPropellor :: Host -> Propellor Result -> IO ()
runChainPropellor Host
h Propellor Result
a = do
Result
r <- Host -> Propellor Result -> IO Result
runPropellor Host
h Propellor Result
a
IO ()
flushConcurrentOutput
[Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Result -> [Char]
forall a. Show a => a -> [Char]
show Result
r