{-# 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
	Result
ret <- Host -> Propellor Result -> IO Result
runPropellor Host
host forall a b. (a -> b) -> a -> b
$ [ChildProperty] -> Propellor Result
ensureChildProperties [forall p. IsProp p => p -> ChildProperty
toChildProperty Property (MetaTypes '[])
overall]
	IO ()
messagesDone
	case Result
ret of
		Result
FailedChange -> forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
1)
		Result
_ -> forall a. ExitCode -> IO a
exitWith ExitCode
ExitSuccess
  where
	overall :: Property (MetaTypes '[])
	overall :: Property (MetaTypes '[])
overall = forall {k} (metatypes :: k).
SingI metatypes =>
[Char] -> Propellor Result -> Property (MetaTypes metatypes)
property [Char]
"overall" 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
	(Result
res, [EndAction]
endactions) <- forall (m :: * -> *) r w s a.
Monad m =>
RWST r w s m a -> r -> s -> m (a, w)
evalRWST (forall p. Propellor p -> RWST Host [EndAction] () IO p
runWithHost Propellor Result
a) Host
host ()
	[Result]
endres <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Host -> Result -> EndAction -> IO Result
runEndAction Host
host Result
res) [EndAction]
endactions
	forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat (Result
resforall 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) = 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 forall a b. (a -> b) -> a -> b
$ do
	(Result
ret, ()
_s, [EndAction]
_) <- forall r w s (m :: * -> *) a.
RWST r w s m a -> r -> s -> m (a, s, w)
runRWST (forall p. Propellor p -> RWST Host [EndAction] () IO p
runWithHost (forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
m Result -> m Result
catchPropellor (Result -> Propellor Result
a Result
res))) Host
host ()
	forall (m :: * -> *) a. Monad m => a -> m a
return Result
ret

-- | Ensures the child properties, with a display of each as it runs.
ensureChildProperties :: [ChildProperty] -> Propellor Result
ensureChildProperties :: [ChildProperty] -> Propellor Result
ensureChildProperties [ChildProperty]
ps = forall {p}. IsProp p => [p] -> Result -> Propellor Result
ensure [ChildProperty]
ps Result
NoChange
  where
	ensure :: [p] -> Result -> Propellor Result
ensure [] Result
rs = forall (m :: * -> *) a. Monad m => a -> m a
return Result
rs
	ensure (p
p:[p]
ls) Result
rs = do
		[Char]
hn <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Host -> [Char]
hostName
		Result
r <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure Result
NoChange)
			(forall (m :: * -> *) r.
(MonadIO m, MonadMask m, ActionResult r, ToResult r) =>
[Char] -> [Char] -> m r -> m r
actionMessageOn [Char]
hn (forall p. IsProp p => p -> [Char]
getDesc p
p) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
m Result -> m Result
catchPropellor)
			(forall p. IsProp p => p -> Maybe (Propellor Result)
getSatisfy p
p)
		[p] -> Result -> Propellor Result
ensure [p]
ls (Result
r forall a. Semigroup a => a -> a -> a
<> Result
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 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
	Just Host
h -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall r w s (m :: * -> *) a.
RWST r w s m a -> r -> s -> m (a, s, w)
runRWST (forall p. Propellor p -> RWST Host [EndAction] () IO p
runWithHost Propellor a
getter) Host
h ()
	forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [EndAction]
runlog
	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 = forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket IO Fd
lock Fd -> IO ()
unlock (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)
			forall (m :: * -> *) a.
MonadCatch m =>
m a -> (IOException -> m a) -> m a
`catchIO` forall a b. a -> b -> a
const forall {a}. a
alreadyrunning
		forall (m :: * -> *) a. Monad m => a -> m a
return Fd
l
	unlock :: Fd -> IO ()
unlock = Fd -> IO ()
closeFd
	alreadyrunning :: a
alreadyrunning = 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.
	forall a.
CreateProcessRunner
-> CreateProcess -> ((Handle, Handle) -> IO a) -> IO a
withOEHandles CreateProcessRunner
createProcessSuccess CreateProcess
p forall a b. (a -> b) -> a -> b
$ \(Handle
outh, Handle
errh) -> do
		(Result
r, ()) <- Handle -> IO Result
processChainOutput Handle
outh
			forall a b. IO a -> IO b -> IO (a, b)
`concurrently` Handle -> IO ()
forwardChainError Handle
errh
		forall (m :: * -> *) a. Monad m => a -> m a
return Result
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 forall a. Maybe a
Nothing
  where
	go :: Maybe [Char] -> IO Result
go Maybe [Char]
lastline = do
		Maybe [Char]
v <- 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
					forall (m :: * -> *) a. Monad m => a -> m a
return Result
FailedChange
				Just [Char]
l -> case forall a. Read a => [Char] -> Maybe a
readish [Char]
l of
					Just Result
r -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Result
r
					Maybe Result
Nothing -> do
						forall v. Outputable v => v -> IO ()
outputConcurrent ([Char]
l forall a. [a] -> [a] -> [a]
++ [Char]
"\n")
						forall (m :: * -> *) a. Monad m => a -> m a
return Result
FailedChange
			Just [Char]
s -> do
				forall v. Outputable v => v -> IO ()
outputConcurrent forall a b. (a -> b) -> a -> b
$
					forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"" (\[Char]
l -> if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
l then [Char]
"" else [Char]
l forall a. [a] -> [a] -> [a]
++ [Char]
"\n") Maybe [Char]
lastline
				Maybe [Char] -> IO Result
go (forall a. a -> Maybe a
Just [Char]
s)

forwardChainError :: Handle -> IO ()
forwardChainError :: Handle -> IO ()
forwardChainError Handle
h = do
	Maybe [Char]
v <- 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
		Just [Char]
s -> do
			forall v. Outputable v => v -> IO ()
errorConcurrent ([Char]
s 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
	Result
r <- Host -> Propellor Result -> IO Result
runPropellor Host
h Propellor Result
a
	IO ()
flushConcurrentOutput
	[Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Char]
"\n" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Result
r