    {-# 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

    -- | Gets the Properties of a Host, and ensures them all,
    -- with nice display of what's being done.
    mainProperties :: Host -> IO ()
    mainProperties :: Host -> IO ()
    mainProperties Host
    host = do
    	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]
    	messagesDone
    	case 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)

    -- | Runs a Propellor action with the specified host.
    --
    -- If the Result is not FailedChange, any EndActions
    -- that were accumulated while running the action
    -- are then also run.
    runPropellor :: Host -> Propellor Result -> IO Result
    runPropellor :: Host -> Propellor Result -> IO Result
    runPropellor Host
    host Propellor Result
    a = do
    	(res, 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 ()
    	endres <- mapM (runEndAction host res) endactions
    	return $ mconcat (res: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
    	(ret, _s, _) <- 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 ()
    	return ret

    -- | Ensures the child properties, with a display of each as it runs.
    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
    		hn <- (Host -> [Char]) -> Propellor [Char]
    forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
    asks Host -> [Char]
    hostName
    		r <- maybe (pure NoChange)
    			(actionMessageOn hn (getDesc p) . catchPropellor)
    			(getSatisfy p)
    		ensure ls (r <> rs)

    -- | Lifts an action into the context of a different host.
    --
    -- > fromHost hosts "otherhost" Ssh.getHostPubKey
    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
    	(ret, _s, 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 ()
    	tell runlog
    	return 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.
    (HasCallStack, 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)
    		l <- [Char] -> FileMode -> IO Fd
    createFile [Char]
    lockfile FileMode
    stdFileMode
    		setFdOption l CloseOnExec True
    		setLock l (WriteLock, AbsoluteSeek, 0, 0)
    			`catchIO` const alreadyrunning
    		return 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!"

    -- | Chains to a propellor sub-Process, forwarding its output on to the
    -- display, except for the last line which is a Result.
    chainPropellor :: CreateProcess -> IO Result
    chainPropellor :: CreateProcess -> IO Result
    chainPropellor CreateProcess
    p =
    	-- We want to use outputConcurrent to display output
    	-- as it's received. If only stdout were captured,
    	-- concurrent-output would buffer all outputConcurrent.
    	-- Also capturing stderr avoids that problem.
    	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
    		(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
    		return r

    -- | Reads and displays each line from the Handle, except for the last line
    -- which is a Result.
    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
    		v <- IO [Char] -> IO (Maybe [Char])
    forall (m :: * -> *) a. MonadCatch m => m a -> m (Maybe a)
    catchMaybeIO (Handle -> IO [Char]
    hGetLine Handle
    h)
    		case 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
    	v <- IO [Char] -> IO (Maybe [Char])
    forall (m :: * -> *) a. MonadCatch m => m a -> m (Maybe a)
    catchMaybeIO (Handle -> IO [Char]
    hGetLine Handle
    h)
    	case 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

    -- | Used by propellor sub-Processes that are run by chainPropellor.
    runChainPropellor :: Host -> Propellor Result -> IO ()
    runChainPropellor :: Host -> Propellor Result -> IO ()
    runChainPropellor Host
    h Propellor Result
    a = do
    	r <- Host -> Propellor Result -> IO Result
    runPropellor Host
    h Propellor Result
    a
    	flushConcurrentOutput
    	putStrLn $ "\n" ++ show r