    {-# 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.PosixCompat
    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 = do
            ret <- runPropellor host $ ensureChildProperties [toChildProperty overall]
            messagesDone
            case ret of
                    FailedChange -> exitWith (ExitFailure 1)
                    _ -> exitWith ExitSuccess
      where
            overall :: Property (MetaTypes '[])
            overall = property "overall" $
                    ensureChildProperties (hostProperties 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 a = do
            (res, endactions) <- evalRWST (runWithHost a) host ()
            endres <- mapM (runEndAction host res) endactions
            return $ mconcat (res:endres)

    runEndAction :: Host -> Result -> EndAction -> IO Result
    runEndAction host res (EndAction desc a) = actionMessageOn (hostName host) desc $ do
            (ret, _s, _) <- runRWST (runWithHost (catchPropellor (a res))) host ()
            return ret

    -- | Ensures the child properties, with a display of each as it runs.
    ensureChildProperties :: [ChildProperty] -> Propellor Result
    ensureChildProperties ps = ensure ps NoChange
      where
            ensure [] rs = return rs
            ensure (p:ls) rs = do
                    hn <- asks 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 l hn getter = case findHost l hn of
            Nothing -> return Nothing
            Just h -> Just <$> fromHost' h getter

    fromHost' :: Host -> Propellor a -> Propellor a
    fromHost' h getter = do
            (ret, _s, runlog) <- liftIO $ runRWST (runWithHost getter) h ()
            tell runlog
            return ret

    onlyProcess :: FilePath -> IO a -> IO a
    onlyProcess lockfile a = bracket lock unlock (const a)
      where
            lock = do
                    createDirectoryIfMissing True (takeDirectory lockfile)
                    l <- createFile lockfile stdFileMode
                    setFdOption l CloseOnExec True
                    setLock l (WriteLock, AbsoluteSeek, 0, 0)
                            `catchIO` const alreadyrunning
                    return l
            unlock = closeFd
            alreadyrunning = giveup "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 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.
            withOEHandles createProcessSuccess p $ \(outh, errh) -> do
                    (r, ()) <- processChainOutput outh
                            `concurrently` forwardChainError 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 h = go Nothing
      where
            go lastline = do
                    v <- catchMaybeIO (hGetLine h)
                    case v of
                            Nothing -> case lastline of
                                    Nothing -> do
                                            return FailedChange
                                    Just l -> case readish l of
                                            Just r -> pure r
                                            Nothing -> do
                                                    outputConcurrent (l ++ "\n")
                                                    return FailedChange
                            Just s -> do
                                    outputConcurrent $
                                            maybe "" (\l -> if null l then "" else l ++ "\n") lastline
                                    go (Just s)

    forwardChainError :: Handle -> IO ()
    forwardChainError h = do
            v <- catchMaybeIO (hGetLine h)
            case v of
                    Nothing -> return ()
                    Just s -> do
                            errorConcurrent (s ++ "\n")
                            forwardChainError h

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