{-# 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 -> IO ()
mainProperties host :: 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
		FailedChange -> ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure 1)
		_ -> ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith ExitCode
ExitSuccess
  where
	overall :: Property (MetaTypes '[])
	overall :: Property (MetaTypes '[])
overall = Desc -> Propellor Result -> Property (MetaTypes '[])
forall k (metatypes :: k).
SingI metatypes =>
Desc -> Propellor Result -> Property (MetaTypes metatypes)
property "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
host a :: Propellor Result
a = do
	(res :: Result
res, endactions :: [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)
mapM (Host -> Result -> EndAction -> IO Result
runEndAction Host
host Result
res) [EndAction]
endactions
	Result -> IO Result
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
host res :: Result
res (EndAction desc :: Desc
desc a :: Result -> Propellor Result
a) = Desc -> Desc -> IO Result -> IO Result
forall (m :: * -> *) r.
(MonadIO m, MonadMask m, ActionResult r, ToResult r) =>
Desc -> Desc -> m r -> m r
actionMessageOn (Host -> Desc
hostName Host
host) Desc
desc (IO Result -> IO Result) -> IO Result -> IO Result
forall a b. (a -> b) -> a -> b
$ do
	(ret :: Result
ret, _s :: ()
_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 ()
	Result -> IO Result
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 ps :: [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 [] rs :: Result
rs = Result -> Propellor Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
rs
	ensure (p :: p
p:ls :: [p]
ls) rs :: Result
rs = do
		Desc
hn <- (Host -> Desc) -> Propellor Desc
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Host -> Desc
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 (f :: * -> *) a. Applicative f => a -> f a
pure Result
NoChange)
			(Desc -> Desc -> Propellor Result -> Propellor Result
forall (m :: * -> *) r.
(MonadIO m, MonadMask m, ActionResult r, ToResult r) =>
Desc -> Desc -> m r -> m r
actionMessageOn Desc
hn (p -> Desc
forall p. IsProp p => p -> Desc
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)

-- | Lifts an action into the context of a different host.
--
-- > fromHost hosts "otherhost" Ssh.getHostPubKey
fromHost :: [Host] -> HostName -> Propellor a -> Propellor (Maybe a)
fromHost :: [Host] -> Desc -> Propellor a -> Propellor (Maybe a)
fromHost l :: [Host]
l hn :: Desc
hn getter :: Propellor a
getter = case [Host] -> Desc -> Maybe Host
findHost [Host]
l Desc
hn of
	Nothing -> Maybe a -> Propellor (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
	Just h :: 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' :: Host -> Propellor a -> Propellor a
fromHost' h :: Host
h getter :: Propellor a
getter = do
	(ret :: a
ret, _s :: ()
_s, runlog :: [EndAction]
runlog) <- IO (a, (), [EndAction]) -> Propellor (a, (), [EndAction])
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 (m :: * -> *) a. Monad m => a -> m a
return a
ret

onlyProcess :: FilePath -> IO a -> IO a
onlyProcess :: Desc -> IO a -> IO a
onlyProcess lockfile :: Desc
lockfile a :: 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 -> Desc -> IO ()
createDirectoryIfMissing Bool
True (Desc -> Desc
takeDirectory Desc
lockfile)
		Fd
l <- Desc -> FileMode -> IO Fd
createFile Desc
lockfile FileMode
stdFileMode
		Fd -> FdOption -> Bool -> IO ()
setFdOption Fd
l FdOption
CloseOnExec Bool
True
		Fd -> FileLock -> IO ()
setLock Fd
l (LockRequest
WriteLock, SeekMode
AbsoluteSeek, 0, 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 (m :: * -> *) a. Monad m => a -> m a
return Fd
l
	unlock :: Fd -> IO ()
unlock = Fd -> IO ()
closeFd
	alreadyrunning :: a
alreadyrunning = Desc -> a
forall a. Desc -> a
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 :: CreateProcess -> IO Result
chainPropellor p :: 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 CreateProcessRunner
createProcessSuccess CreateProcess
p (((Handle, Handle) -> IO Result) -> IO Result)
-> ((Handle, Handle) -> IO Result) -> IO Result
forall a b. (a -> b) -> a -> b
$ \(outh :: Handle
outh, errh :: Handle
errh) -> do
		(r :: 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 (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 h :: Handle
h = Maybe Desc -> IO Result
go Maybe Desc
forall a. Maybe a
Nothing
  where
	go :: Maybe Desc -> IO Result
go lastline :: Maybe Desc
lastline = do
		Maybe Desc
v <- IO Desc -> IO (Maybe Desc)
forall (m :: * -> *) a. MonadCatch m => m a -> m (Maybe a)
catchMaybeIO (Handle -> IO Desc
hGetLine Handle
h)
		case Maybe Desc
v of
			Nothing -> case Maybe Desc
lastline of
				Nothing -> do
					Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
FailedChange
				Just l :: Desc
l -> case Desc -> Maybe Result
forall a. Read a => Desc -> Maybe a
readish Desc
l of
					Just r :: Result
r -> Result -> IO Result
forall (f :: * -> *) a. Applicative f => a -> f a
pure Result
r
					Nothing -> do
						Desc -> IO ()
forall v. Outputable v => v -> IO ()
outputConcurrent (Desc
l Desc -> Desc -> Desc
forall a. [a] -> [a] -> [a]
++ "\n")
						Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
FailedChange
			Just s :: Desc
s -> do
				Desc -> IO ()
forall v. Outputable v => v -> IO ()
outputConcurrent (Desc -> IO ()) -> Desc -> IO ()
forall a b. (a -> b) -> a -> b
$
					Desc -> (Desc -> Desc) -> Maybe Desc -> Desc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "" (\l :: Desc
l -> if Desc -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Desc
l then "" else Desc
l Desc -> Desc -> Desc
forall a. [a] -> [a] -> [a]
++ "\n") Maybe Desc
lastline
				Maybe Desc -> IO Result
go (Desc -> Maybe Desc
forall a. a -> Maybe a
Just Desc
s)

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