summaryrefslogtreecommitdiff
path: root/src/Propellor/Engine.hs
blob: b4dc66ce3933a3b0b1757f72f52f5d785fffed45 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
{-# 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 = error "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