propellor 2.12.0 → 2.13.0

raw patch · 43 files changed

+1281/−305 lines, 43 filesdep +stmdep +textPVP ok

version bump matches the API change (PVP)

Dependencies added: stm, text

API changes (from Hackage documentation)

Files

• CHANGELOG +30/−0
• config-joey.hs +2/−2
• debian/changelog +30/−0
• debian/control +5/−1
• propellor.cabal +13/−7
• src/Propellor/Base.hs +2/−0
• src/Propellor/Bootstrap.hs +3/−1
• src/Propellor/CmdLine.hs +4/−3
• src/Propellor/Debug.hs +36/−0
• src/Propellor/Engine.hs +2/−34
• src/Propellor/Gpg.hs +14/−8
• src/Propellor/Message.hs +107/−84
• src/Propellor/PrivData.hs +18/−10
• src/Propellor/PropAccum.hs +2/−2
• src/Propellor/Property.hs +44/−27
• src/Propellor/Property/Apache.hs +3/−3
• src/Propellor/Property/Apt.hs +2/−2
• src/Propellor/Property/Chroot.hs +5/−3
• src/Propellor/Property/Cmd.hs +2/−1
• src/Propellor/Property/Concurrent.hs +137/−0
• src/Propellor/Property/Conductor.hs +3/−3
• src/Propellor/Property/Debootstrap.hs +1/−1
• src/Propellor/Property/DiskImage.hs +4/−4
• src/Propellor/Property/Dns.hs +5/−5
• src/Propellor/Property/DnsSec.hs +4/−4
• src/Propellor/Property/Docker.hs +5/−2
• src/Propellor/Property/File.hs +22/−0
• src/Propellor/Property/Git.hs +1/−1
• src/Propellor/Property/List.hs +1/−0
• src/Propellor/Property/Nginx.hs +1/−1
• src/Propellor/Property/Prosody.hs +1/−1
• src/Propellor/Property/SiteSpecific/JoeySites.hs +4/−4
• src/Propellor/Property/Ssh.hs +1/−1
• src/Propellor/Property/Systemd.hs +11/−11
• src/Propellor/Property/Uwsgi.hs +1/−1
• src/Propellor/Spin.hs +11/−9
• src/Propellor/Types.hs +110/−53
• src/System/Console/Concurrent.hs +44/−0
• src/System/Console/Concurrent/Internal.hs +538/−0
• src/System/Process/Concurrent.hs +34/−0
• src/Utility/Process.hs +13/−15
• src/Utility/Process/Shim.hs +4/−0
• src/wrapper.hs +1/−1

@@ -1,3 +1,33 @@+propellor (2.13.0) unstable; urgency=medium++  * RevertableProperty used to be assumed to contain info, but this is+    now made explicit, with RevertableProperty HasInfo or+    RevertableProperty NoInfo. (API change)+    Transition guide:+      - If you define a RevertableProperty, expect some type check+        failures like: "Expecting one more argument to ‘RevertableProperty’".+      - Change it to "RevertableProperty NoInfo"+      - The compiler will then tell you if it needs "HasInfo" instead.+      - If you have code that uses the RevertableProperty constructor+        that fails to type check, use the more powerful <!> operator+        instead to create the RevertableProperty.+  * Various property combinators that combined a RevertableProperty+    with a non-revertable property used to yield a RevertableProperty.+    This was a bug, because the combined property could not be fully+    reverted in many cases, and the result is now a non-revertable property.+  * combineWith now takes an additional parameter to control how revert+    actions are combined (API change).+  * Added Propellor.Property.Concurrent for concurrent properties.+  * Made the execProcess exported by propellor, and everything built on it,+    avoid scrambled output when run concurrently.+  * Propellor now depends on STM and text.+  * The cabal file now builds propellor with -O. While -O0 makes ghc+    take less memory while building propellor, it can lead to bad memory+    usage at runtime due to eg, disabled stream fusion.+  * Add File.isCopyOf. Thanks, Per Olofsson.++ -- Joey Hess <id@joeyh.name>  Sun, 08 Nov 2015 14:51:15 -0400+ propellor (2.12.0) unstable; urgency=medium    * The DiskImage module can now make bootable images using grub.

@@ -515,13 +515,13 @@ 	& Dns.secondary hosts "ikiwiki.info" 	& Dns.secondary hosts "olduse.net" -branchableSecondary :: RevertableProperty+branchableSecondary :: RevertableProperty HasInfo branchableSecondary = Dns.secondaryFor ["branchable.com"] hosts "branchable.com"  -- Currently using kite (ns4) as primary with secondaries -- elephant (ns3) and gandi. -- kite handles all mail.-myDnsPrimary :: Bool -> Domain -> [(BindDomain, Record)] -> RevertableProperty+myDnsPrimary :: Bool -> Domain -> [(BindDomain, Record)] -> RevertableProperty HasInfo myDnsPrimary dnssec domain extras = (if dnssec then Dns.signedPrimary (Weekly Nothing) else Dns.primary) hosts domain 	(Dns.mkSOA "ns4.kitenet.net" 100) $ 	[ (RootDomain, NS $ AbsDomain "ns4.kitenet.net")

@@ -1,3 +1,33 @@+propellor (2.13.0) unstable; urgency=medium++  * RevertableProperty used to be assumed to contain info, but this is+    now made explicit, with RevertableProperty HasInfo or+    RevertableProperty NoInfo. (API change)+    Transition guide:+      - If you define a RevertableProperty, expect some type check+        failures like: "Expecting one more argument to ‘RevertableProperty’".+      - Change it to "RevertableProperty NoInfo"+      - The compiler will then tell you if it needs "HasInfo" instead.+      - If you have code that uses the RevertableProperty constructor+        that fails to type check, use the more powerful <!> operator+        instead to create the RevertableProperty.+  * Various property combinators that combined a RevertableProperty+    with a non-revertable property used to yield a RevertableProperty.+    This was a bug, because the combined property could not be fully+    reverted in many cases, and the result is now a non-revertable property.+  * combineWith now takes an additional parameter to control how revert+    actions are combined (API change).+  * Added Propellor.Property.Concurrent for concurrent properties.+  * Made the execProcess exported by propellor, and everything built on it,+    avoid scrambled output when run concurrently.+  * Propellor now depends on STM and text.+  * The cabal file now builds propellor with -O. While -O0 makes ghc+    take less memory while building propellor, it can lead to bad memory+    usage at runtime due to eg, disabled stream fusion.+  * Add File.isCopyOf. Thanks, Per Olofsson.++ -- Joey Hess <id@joeyh.name>  Sun, 08 Nov 2015 14:51:15 -0400+ propellor (2.12.0) unstable; urgency=medium    * The DiskImage module can now make bootable images using grub.

@@ -17,7 +17,9 @@ 	libghc-mtl-dev, 	libghc-transformers-dev, 	libghc-exceptions-dev (>= 0.6),-Maintainer: Gergely Nagy <algernon@madhouse-project.org>+	libghc-stm-dev,+	libghc-text-dev,+Maintainer: Joey Hess <id@joeyh.name> Standards-Version: 3.9.6 Vcs-Git: git://git.joeyh.name/propellor Homepage: http://propellor.branchable.com/@@ -39,6 +41,8 @@ 	libghc-mtl-dev, 	libghc-transformers-dev, 	libghc-exceptions-dev (>= 0.6),+	libghc-stm-dev,+	libghc-text-dev, 	git, 	make, Description: property-based host configuration management in haskell

@@ -1,5 +1,5 @@ Name: propellor-Version: 2.12.0+Version: 2.13.0 Cabal-Version: >= 1.8 License: BSD3 Maintainer: Joey Hess <id@joeyh.name>@@ -34,35 +34,35 @@  Executable propellor   Main-Is: wrapper.hs-  GHC-Options: -threaded -O0 -Wall -fno-warn-tabs+  GHC-Options: -threaded -Wall -fno-warn-tabs   Hs-Source-Dirs:  src   Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5,    IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal,    containers (>= 0.5), network, async, time, QuickCheck, mtl, transformers,-   exceptions (>= 0.6)+   exceptions (>= 0.6), stm, text    if (! os(windows))     Build-Depends: unix  Executable propellor-config   Main-Is: config.hs-  GHC-Options: -threaded -O0 -Wall -fno-warn-tabs+  GHC-Options: -threaded -Wall -fno-warn-tabs   Hs-Source-Dirs:  src   Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5,    IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal,    containers (>= 0.5), network, async, time, QuickCheck, mtl, transformers,-   exceptions+   exceptions, stm, text    if (! os(windows))     Build-Depends: unix  Library-  GHC-Options: -O0 -Wall -fno-warn-tabs+  GHC-Options: -Wall -fno-warn-tabs   Hs-Source-Dirs:  src   Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5,    IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal,    containers (>= 0.5), network, async, time, QuickCheck, mtl, transformers,-   exceptions+   exceptions, stm, text    if (! os(windows))     Build-Depends: unix@@ -76,6 +76,7 @@     Propellor.Property.Apache     Propellor.Property.Apt     Propellor.Property.Cmd+    Propellor.Property.Concurrent     Propellor.Property.Conductor     Propellor.Property.Hostname     Propellor.Property.Chroot@@ -134,6 +135,7 @@     Propellor.CmdLine     Propellor.Info     Propellor.Message+    Propellor.Debug     Propellor.PrivData     Propellor.Engine     Propellor.Exception@@ -174,6 +176,7 @@     Utility.PartialPrelude     Utility.PosixFiles     Utility.Process+    Utility.Process.Shim     Utility.SafeCommand     Utility.Scheduled     Utility.Table@@ -181,6 +184,9 @@     Utility.Tmp     Utility.UserInfo     Utility.QuickCheck+    System.Console.Concurrent+    System.Console.Concurrent.Internal+    System.Process.Concurrent  source-repository head   type: git

@@ -15,6 +15,7 @@ 	, module Propellor.Engine 	, module Propellor.Exception 	, module Propellor.Message+	, module Propellor.Debug 	, module Propellor.Location 	, module Propellor.Utilities @@ -39,6 +40,7 @@ import Propellor.PrivData import Propellor.Types.PrivData import Propellor.Message+import Propellor.Debug import Propellor.Exception import Propellor.Info import Propellor.PropAccum

@@ -65,7 +65,7 @@  	aptinstall p = "apt-get --no-upgrade --no-install-recommends -y install " ++ p -	-- This is the same build deps listed in debian/control.+	-- This is the same deps listed in debian/control. 	debdeps = 		[ "gnupg" 		, "ghc"@@ -81,6 +81,8 @@ 		, "libghc-mtl-dev" 		, "libghc-transformers-dev" 		, "libghc-exceptions-dev"+		, "libghc-stm-dev"+		, "libghc-text-dev" 		, "make" 		] 

@@ -89,7 +89,7 @@  -- | Runs propellor on hosts, as controlled by command-line options. defaultMain :: [Host] -> IO ()-defaultMain hostlist = do+defaultMain hostlist = withConcurrentOutput $ do 	Shim.cleanEnv 	checkDebugMode 	cmdline <- processCmdLine@@ -120,8 +120,9 @@ 	go False (Spin hs mrelay) = do 		commitSpin 		forM_ hs $ \hn -> withhost hn $ spin mrelay hn-	go False cmdline@(SimpleRun hn) = buildFirst cmdline $-		go False (Run hn)+	go False cmdline@(SimpleRun hn) = do+		forceConsole+		buildFirst cmdline $ go False (Run hn) 	go False (Run hn) = ifM ((==) 0 <$> getRealUserID) 		( onlyprocess $ withhost hn mainProperties 		, go True (Spin [hn] Nothing)

@@ -0,0 +1,36 @@+module Propellor.Debug where++import Control.Applicative+import Control.Monad.IfElse+import System.IO+import System.Directory+import System.Log.Logger+import System.Log.Formatter+import System.Log.Handler (setFormatter)+import System.Log.Handler.Simple++import Utility.Monad+import Utility.Env+import Utility.Exception+import Utility.Process++debug :: [String] -> IO ()+debug = debugM "propellor" . unwords++checkDebugMode :: IO ()+checkDebugMode = go =<< getEnv "PROPELLOR_DEBUG"+  where+	go (Just "1") = enableDebugMode+	go (Just _) = noop+	go Nothing = whenM (doesDirectoryExist ".git") $+		whenM (elem "1" . lines <$> getgitconfig) enableDebugMode+	getgitconfig = catchDefaultIO "" $+		readProcess "git" ["config", "propellor.debug"]++enableDebugMode :: IO ()+enableDebugMode = do+	f <- setFormatter+		<$> streamHandler stderr DEBUG+		<*> pure (simpleLogFormatter "[$time] $msg")+	updateGlobalLogger rootLoggerName $ +		setLevel DEBUG .  setHandlers [f]

@@ -9,14 +9,12 @@ 	fromHost, 	fromHost', 	onlyProcess,-	processChainOutput, ) where  import System.Exit import System.IO import Data.Monoid import Control.Applicative-import System.Console.ANSI import "mtl" Control.Monad.RWS.Strict import System.PosixCompat import System.Posix.IO@@ -29,8 +27,6 @@ import Propellor.Info import Propellor.Property import Utility.Exception-import Utility.PartialPrelude-import Utility.Monad  -- | Gets the Properties of a Host, and ensures them all, -- with nice display of what's being done.@@ -38,10 +34,7 @@ mainProperties host = do 	ret <- runPropellor host $ 		ensureProperties [ignoreInfo $ infoProperty "overall" (ensureProperties ps) mempty mempty]-	h <- mkMessageHandle-        whenConsole h $-		setTitle "propellor: done"-	hFlush stdout+	messagesDone 	case ret of 		FailedChange -> exitWith (ExitFailure 1) 		_ -> exitWith ExitSuccess@@ -55,7 +48,7 @@ -- are then also run. runPropellor :: Host -> Propellor Result -> IO Result runPropellor host a = do-	(res, _s, endactions) <- runRWST (runWithHost a) host ()+	(res, endactions) <- evalRWST (runWithHost a) host () 	endres <- mapM (runEndAction host res) endactions 	return $ mconcat (res:endres) @@ -99,28 +92,3 @@ 		return l 	unlock = closeFd 	alreadyrunning = error "Propellor is already running on this host!"---- | 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)-		debug ["read from chained propellor: ", show v]-		case v of-			Nothing -> case lastline of-				Nothing -> do-					debug ["chained propellor output nothing; assuming it failed"]-					return FailedChange-				Just l -> case readish l of-					Just r -> pure r-					Nothing -> do-						debug ["chained propellor output did not end with a Result; assuming it failed"]-						putStrLn l-						hFlush stdout-						return FailedChange-			Just s -> do-				maybe noop (\l -> unless (null l) (putStrLn l)) lastline-				hFlush stdout-				go (Just s)

@@ -7,6 +7,8 @@ import Data.Maybe import Data.List.Utils import Control.Monad+import System.Console.Concurrent+import System.Console.Concurrent.Internal (ConcurrentProcessHandle(..))  import Propellor.PrivData.Paths import Propellor.Message@@ -111,10 +113,7 @@ 	-- Commit explicitly the keyring and privdata files, as other 	-- changes may be staged by the user and shouldn't be committed. 	tocommit <- filterM doesFileExist [ privDataFile, keyring]-	gitCommit $ (map File tocommit) ++ -		[ Param "-m"-		, Param ("propellor " ++ action)-		]+	gitCommit (Just ("propellor " ++ action)) (map File tocommit)  -- Adds --gpg-sign if there's a keyring. gpgSignParams :: [CommandParam] -> IO [CommandParam]@@ -124,10 +123,17 @@ 	)  -- Automatically sign the commit if there'a a keyring.-gitCommit :: [CommandParam] -> IO Bool-gitCommit ps = do-	ps' <- gpgSignParams ps-	boolSystem "git" (Param "commit" : ps')+gitCommit :: Maybe String -> [CommandParam] -> IO Bool+gitCommit msg ps = do+	let ps' = Param "commit" : ps ++ +		maybe [] (\m -> [Param "-m", Param m]) msg+	ps'' <- gpgSignParams ps'+	if isNothing msg+		then do+			(_, _, _, ConcurrentProcessHandle p) <- createProcessForeground $+				proc "git" (toCommand ps'')+			checkSuccessProcess p+		else boolSystem "git" ps''  gpgDecrypt :: FilePath -> IO String gpgDecrypt f = ifM (doesFileExist f)

@@ -1,125 +1,148 @@-{-# LANGUAGE PackageImports #-}+-- | This module handles all display of output to the console when+-- propellor is ensuring Properties.+--+-- When two threads both try to display a message concurrently, +-- the messages will be displayed sequentially. -module Propellor.Message where+module Propellor.Message (+	getMessageHandle,+	isConsole,+	forceConsole,+	actionMessage,+	actionMessageOn,+	warningMessage,+	infoMessage,+	errorMessage,+	processChainOutput,+	messagesDone,+	createProcessConcurrent,+	withConcurrentOutput,+) where  import System.Console.ANSI import System.IO-import System.Log.Logger-import System.Log.Formatter-import System.Log.Handler (setFormatter)-import System.Log.Handler.Simple-import "mtl" Control.Monad.Reader-import Data.Maybe+import Control.Monad.IO.Class (liftIO, MonadIO) import Control.Applicative-import System.Directory-import Control.Monad.IfElse+import System.IO.Unsafe (unsafePerformIO)+import Control.Concurrent+import System.Console.Concurrent  import Propellor.Types+import Utility.PartialPrelude import Utility.Monad-import Utility.Env-import Utility.Process import Utility.Exception -data MessageHandle-	= ConsoleMessageHandle-	| TextMessageHandle+data MessageHandle = MessageHandle+	{ isConsole :: Bool+	} -mkMessageHandle :: IO MessageHandle-mkMessageHandle = do-	ifM (hIsTerminalDevice stdout <||> (isJust <$> getEnv "PROPELLOR_CONSOLE"))-		( return ConsoleMessageHandle-		, return TextMessageHandle-		)+-- | A shared global variable for the MessageHandle.+{-# NOINLINE globalMessageHandle #-}+globalMessageHandle :: MVar MessageHandle+globalMessageHandle = unsafePerformIO $ +	newMVar =<< MessageHandle+		<$> hIsTerminalDevice stdout -forceConsole :: IO ()-forceConsole = void $ setEnv "PROPELLOR_CONSOLE" "1" True+-- | Gets the global MessageHandle.+getMessageHandle :: IO MessageHandle+getMessageHandle = readMVar globalMessageHandle -isConsole :: MessageHandle -> Bool-isConsole ConsoleMessageHandle = True-isConsole _ = False+-- | Force console output. This can be used when stdout is not directly+-- connected to a console, but is eventually going to be displayed at a+-- console.+forceConsole :: IO ()+forceConsole = modifyMVar_ globalMessageHandle $ \mh ->+	pure (mh { isConsole = True }) -whenConsole :: MessageHandle -> IO () -> IO ()-whenConsole ConsoleMessageHandle a = a-whenConsole _ _ = return ()+whenConsole :: String -> IO String+whenConsole s = ifM (isConsole <$> getMessageHandle)+	( pure s+	, pure ""+	)  -- | Shows a message while performing an action, with a colored status -- display.-actionMessage :: (MonadIO m, ActionResult r) => Desc -> m r -> m r+actionMessage :: (MonadIO m, MonadMask m, ActionResult r) => Desc -> m r -> m r actionMessage = actionMessage' Nothing  -- | Shows a message while performing an action on a specified host, -- with a colored status display.-actionMessageOn :: (MonadIO m, ActionResult r) => HostName -> Desc -> m r -> m r+actionMessageOn :: (MonadIO m, MonadMask m, ActionResult r) => HostName -> Desc -> m r -> m r actionMessageOn = actionMessage' . Just -actionMessage' :: (MonadIO m, ActionResult r) => Maybe HostName -> Desc -> m r -> m r+actionMessage' :: (MonadIO m, MonadMask m, ActionResult r) => Maybe HostName -> Desc -> m r -> m r actionMessage' mhn desc a = do-	h <- liftIO mkMessageHandle-	liftIO $ whenConsole h $ do-		setTitle $ "propellor: " ++ desc-		hFlush stdout+	liftIO $ outputConcurrent+		=<< whenConsole (setTitleCode $ "propellor: " ++ desc)  	r <- a -	liftIO $ do-		whenConsole h $-			setTitle "propellor: running"-		showhn h mhn-		putStr $ desc ++ " ... "-		let (msg, intensity, color) = getActionResult r-		colorLine h intensity color msg-		hFlush stdout+	liftIO $ outputConcurrent . concat =<< sequence+		[ whenConsole $+			setTitleCode "propellor: running"+		, showhn mhn+		, pure $ desc ++ " ... "+		, let (msg, intensity, color) = getActionResult r+		  in colorLine intensity color msg+		]  	return r   where-	showhn _ Nothing = return ()-	showhn h (Just hn) = do-		whenConsole h $-			setSGR [SetColor Foreground Dull Cyan]-		putStr (hn ++ " ")-		whenConsole h $-			setSGR []+	showhn Nothing = return ""+	showhn (Just hn) = concat <$> sequence+		[ whenConsole $+			setSGRCode [SetColor Foreground Dull Cyan]+		, pure (hn ++ " ")+		, whenConsole $+			setSGRCode []+		]  warningMessage :: MonadIO m => String -> m ()-warningMessage s = liftIO $ do-	h <- mkMessageHandle-	colorLine h Vivid Magenta $ "** warning: " ++ s+warningMessage s = liftIO $+	outputConcurrent =<< colorLine Vivid Magenta ("** warning: " ++ s) +infoMessage :: MonadIO m => [String] -> m ()+infoMessage ls = liftIO $ outputConcurrent $ concatMap (++ "\n") ls+ errorMessage :: MonadIO m => String -> m a errorMessage s = liftIO $ do-	h <- mkMessageHandle-	colorLine h Vivid Red $ "** error: " ++ s+	outputConcurrent =<< colorLine Vivid Red ("** error: " ++ s) 	error "Cannot continue!"--colorLine :: MessageHandle -> ColorIntensity -> Color -> String -> IO ()-colorLine h intensity color msg = do-	whenConsole h $-		setSGR [SetColor Foreground intensity color]-	putStr msg-	whenConsole h $-		setSGR []+ +colorLine :: ColorIntensity -> Color -> String -> IO String+colorLine intensity color msg = concat <$> sequence+	[ whenConsole $+		setSGRCode [SetColor Foreground intensity color]+	, pure msg+	, whenConsole $+		setSGRCode [] 	-- Note this comes after the color is reset, so that 	-- the color set and reset happen in the same line.-	putStrLn ""-	hFlush stdout--debug :: [String] -> IO ()-debug = debugM "propellor" . unwords+	, pure "\n"+	] -checkDebugMode :: IO ()-checkDebugMode = go =<< getEnv "PROPELLOR_DEBUG"+-- | 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 (Just "1") = enableDebugMode-	go (Just _) = noop-	go Nothing = whenM (doesDirectoryExist ".git") $-		whenM (elem "1" . lines <$> getgitconfig) enableDebugMode-	getgitconfig = catchDefaultIO "" $-		readProcess "git" ["config", "propellor.debug"]+	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) -enableDebugMode :: IO ()-enableDebugMode = do-	f <- setFormatter-		<$> streamHandler stderr DEBUG-		<*> pure (simpleLogFormatter "[$time] $msg")-	updateGlobalLogger rootLoggerName $ -		setLevel DEBUG .  setHandlers [f]+-- | Called when all messages about properties have been printed.+messagesDone :: IO ()+messagesDone = outputConcurrent+	=<< whenConsole (setTitleCode "propellor: done")

@@ -36,6 +36,8 @@ import qualified Data.Map as M import qualified Data.Set as S import qualified Data.ByteString.Lazy as L+import System.Console.Concurrent+import System.Console.Concurrent.Internal (ConcurrentProcessHandle(..))  import Propellor.Types import Propellor.Types.PrivData@@ -54,6 +56,7 @@ import Utility.Env import Utility.Table import Utility.FileSystemEncoding+import Utility.Process  -- | Allows a Property to access the value of a specific PrivDataField, -- for use in a specific Context or HostContext.@@ -106,9 +109,9 @@ 	missing = do 		Context cname <- mkHostContext hc <$> asks hostName 		warningMessage $ "Missing privdata " ++ intercalate " or " fieldnames ++ " (for " ++ cname ++ ")"-		liftIO $ putStrLn $ "Fix this by running:"-		liftIO $ showSet $-			map (\s -> (privDataField s, Context cname, describePrivDataSource s)) srclist+		infoMessage $ +			"Fix this by running:" :+			showSet (map (\s -> (privDataField s, Context cname, describePrivDataSource s)) srclist) 		return FailedChange 	addinfo p = infoProperty 		(propertyDesc p)@@ -121,11 +124,14 @@ 	fieldlist = map privDataField srclist 	hc = asHostContext c -showSet :: [(PrivDataField, Context, Maybe PrivDataSourceDesc)] -> IO ()-showSet l = forM_ l $ \(f, Context c, md) -> do-	putStrLn $ "  propellor --set '" ++ show f ++ "' '" ++ c ++ "' \\"-	maybe noop (\d -> putStrLn $ "    " ++ d) md-	putStrLn ""+showSet :: [(PrivDataField, Context, Maybe PrivDataSourceDesc)] -> [String]+showSet = concatMap go+  where+	go (f, Context c, md) = catMaybes+		[ Just $ "  propellor --set '" ++ show f ++ "' '" ++ c ++ "' \\"+		, maybe Nothing (\d -> Just $ "    " ++ d) md+		, Just ""+		]  addPrivData :: (PrivDataField, Maybe PrivDataSourceDesc, HostContext) -> Property HasInfo addPrivData v = pureInfoProperty (show v) (PrivInfo (S.singleton v))@@ -189,7 +195,8 @@ 		hClose th 		maybe noop (\p -> writeFileProtected' f (`L.hPut` privDataByteString p)) v 		editor <- getEnvDefault "EDITOR" "vi"-		unlessM (boolSystem editor [File f]) $+		(_, _, _, ConcurrentProcessHandle p) <- createProcessForeground $ proc editor [f]+		unlessM (checkSuccessProcess p) $ 			error "Editor failed; aborting." 		PrivData <$> readFile f 	setPrivDataTo field context v'@@ -207,7 +214,8 @@ 		showtable $ map mkrow missing  		section "How to set missing data:"-		showSet $ map (\(f, c) -> (f, c, join $ M.lookup (f, c) descmap)) missing+		mapM_ putStrLn $ showSet $+			map (\(f, c) -> (f, c, join $ M.lookup (f, c) descmap)) missing   where 	header = ["Field", "Context", "Used by"] 	mkrow k@(field, Context context) =

@@ -1,4 +1,4 @@-{-# LANGUAGE PackageImports #-}+{-# LANGUAGE PackageImports, FlexibleContexts #-}  module Propellor.PropAccum 	( host@@ -46,7 +46,7 @@ (&^) = addPropFront  -- | Adds a property in reverted form.-(!) :: PropAccum h => h -> RevertableProperty -> h+(!) :: IsProp (RevertableProperty i) => PropAccum h => h -> RevertableProperty i -> h h ! p = h & revert p  infixl 1 &

@@ -66,30 +66,43 @@  -- | Indicates that the first property depends on the second, -- so before the first is ensured, the second must be ensured.+--+-- The combined property uses the description of the first property. requires :: Combines x y => x -> y -> CombinedType x y-requires = (<<>>)+requires = combineWith+	-- Run action of y, then x+	(flip (<>))+	-- When reverting, run in reverse order.+	(<>)  -- | Combines together two properties, resulting in one property -- that ensures the first, and if the first succeeds, ensures the second. -- -- The combined property uses the description of the first property.-before :: (IsProp x, Combines y x, IsProp (CombinedType y x)) => x -> y -> CombinedType y x-before x y = (y `requires` x) `describe` getDesc x+before :: Combines x y => x -> y -> CombinedType x y+before = combineWith+	-- Run action of x, then y+	(<>)+	-- When reverting, run in reverse order.+	(flip (<>))  -- | Whenever a change has to be made for a Property, causes a hook -- Property to also be run, but not otherwise. onChange-	:: (Combines (Property x) (Property y))-	=> Property x-        -> Property y-        -> CombinedType (Property x) (Property y)-onChange = combineWith $ \p hook -> do-	r <- p-	case r of-		MadeChange -> do-			r' <- hook-			return $ r <> r'-		_ -> return r+	:: (Combines x y)+	=> x+        -> y+        -> CombinedType x y+onChange = combineWith combiner revertcombiner+  where+	combiner p hook = do+		r <- p+		case r of+			MadeChange -> do+				r' <- hook+				return $ r <> r'+			_ -> return r+	revertcombiner = (<>)  -- | Same as `onChange` except that if property y fails, a flag file -- is generated. On next run, if the flag file is present, property y@@ -99,14 +112,14 @@ -- `FailedChange`. But if this property is applied again, it returns -- `NoChange`. This behavior can cause trouble... onChangeFlagOnFail-	:: (Combines (Property x) (Property y))+	:: (Combines x y) 	=> FilePath-        -> Property x-        -> Property y-        -> CombinedType (Property x) (Property y)-onChangeFlagOnFail flagfile = combineWith go+        -> x+        -> y+        -> CombinedType x y+onChangeFlagOnFail flagfile = combineWith combiner revertcombiner   where-	go s1 s2 = do+	combiner s1 s2 = do 		r1 <- s1 		case r1 of 			MadeChange -> flagFailed s2@@ -114,6 +127,7 @@ 				(flagFailed s2 				, return r1 				)+	revertcombiner = (<>) 	flagFailed s = do 		r <- s 		liftIO $ case r of@@ -151,12 +165,15 @@  -- | Tries the first property, but if it fails to work, instead uses -- the second.-fallback :: (Combines (Property p1) (Property p2)) => Property p1 -> Property p2 -> Property (CInfo p1 p2)-fallback = combineWith $ \a1 a2 -> do-	r <- a1-	if r == FailedChange-		then a2-		else return r+fallback :: (Combines p1 p2) => p1 -> p2 -> CombinedType p1 p2+fallback = combineWith combiner revertcombiner+  where+	combiner a1 a2 = do+		r <- a1+		if r == FailedChange+			then a2+			else return r+	revertcombiner = (<>)  -- | Marks a Property as trivial. It can only return FailedChange or -- NoChange. @@ -184,7 +201,7 @@ withOS desc a = property desc $ a =<< getOS  -- | Undoes the effect of a RevertableProperty.-revert :: RevertableProperty -> RevertableProperty+revert :: RevertableProperty i -> RevertableProperty i revert (RevertableProperty p1 p2) = RevertableProperty p2 p1  makeChange :: IO () -> Propellor Result

@@ -16,7 +16,7 @@  -- | A basic virtual host, publishing a directory, and logging to -- the combined apache log file.-virtualHost :: HostName -> Port -> FilePath -> RevertableProperty+virtualHost :: HostName -> Port -> FilePath -> RevertableProperty NoInfo virtualHost hn (Port p) docroot = siteEnabled hn 	[ "<VirtualHost *:"++show p++">" 	, "ServerName "++hn++":"++show p@@ -30,7 +30,7 @@  type ConfigFile = [String] -siteEnabled :: HostName -> ConfigFile -> RevertableProperty+siteEnabled :: HostName -> ConfigFile -> RevertableProperty NoInfo siteEnabled hn cf = enable <!> disable   where 	enable = combineProperties ("apache site enabled " ++ hn)@@ -59,7 +59,7 @@   where 	comment = "# deployed with propellor, do not modify" -modEnabled :: String -> RevertableProperty+modEnabled :: String -> RevertableProperty NoInfo modEnabled modname = enable <!> disable   where 	enable = check (not <$> isenabled) $

@@ -212,7 +212,7 @@ 	`describe` "apt autoremove"  -- | Enables unattended upgrades. Revert to disable.-unattendedUpgrades :: RevertableProperty+unattendedUpgrades :: RevertableProperty NoInfo unattendedUpgrades = enable <!> disable   where 	enable = setup True@@ -272,7 +272,7 @@ 	, pubkey :: String 	} -trustsKey :: AptKey -> RevertableProperty+trustsKey :: AptKey -> RevertableProperty NoInfo trustsKey k = trustsKey' k <!> untrustKey k  trustsKey' :: AptKey -> Property NoInfo

@@ -31,6 +31,7 @@ import qualified Data.Map as M import Data.List.Utils import System.Posix.Directory+import System.Console.Concurrent  -- | Specification of a chroot. Normally you'll use `debootstrapped` or -- `bootstrapped` to construct a Chroot value.@@ -116,10 +117,10 @@ -- Reverting this property removes the chroot. Anything mounted inside it -- is first unmounted. Note that it does not ensure that any processes -- that might be running inside the chroot are stopped.-provisioned :: Chroot -> RevertableProperty+provisioned :: Chroot -> RevertableProperty HasInfo provisioned c = provisioned' (propagateChrootInfo c) c False -provisioned' :: (Property HasInfo -> Property HasInfo) -> Chroot -> Bool -> RevertableProperty+provisioned' :: (Property HasInfo -> Property HasInfo) -> Chroot -> Bool -> RevertableProperty HasInfo provisioned' propigator c@(Chroot loc bootstrapper _) systemdonly = 	(propigator $ propertyList (chrootDesc c "exists") [setup]) 		<!>@@ -193,7 +194,7 @@  toChain :: HostName -> Chroot -> Bool -> IO CmdLine toChain parenthost (Chroot loc _ _) systemdonly = do-	onconsole <- isConsole <$> mkMessageHandle+	onconsole <- isConsole <$> getMessageHandle 	return $ ChrootChain parenthost loc systemdonly onconsole  chain :: [Host] -> CmdLine -> IO ()@@ -213,6 +214,7 @@ 					then [Systemd.installed] 					else map ignoreInfo $ 						hostProperties h+			flushConcurrentOutput 			putStrLn $ "\n" ++ show r chain _ _ = errorMessage "bad chain command" 

@@ -16,6 +16,7 @@ 	safeSystemEnv, 	shellEscape, 	createProcess,+	waitForProcess, ) where  import Control.Applicative@@ -26,7 +27,7 @@ import Propellor.Property import Utility.SafeCommand import Utility.Env-import Utility.Process (createProcess, CreateProcess)+import Utility.Process (createProcess, CreateProcess, waitForProcess)  -- | A property that can be satisfied by running a command. --

@@ -0,0 +1,137 @@+{-# LANGUAGE FlexibleContexts #-}++-- | Propellor properties can be made to run concurrently, using this+-- module. This can speed up propellor, at the expense of using more CPUs+-- and other resources.+--+-- It's up to you to make sure that properties that you make run concurrently+-- don't implicitly depend on one-another. The worst that can happen+-- though, is that propellor fails to ensure some of the properties,+-- and tells you what went wrong.+--+-- Another potential problem is that output of concurrent properties could+-- interleave into a scrambled mess. This is mostly prevented; all messages+-- output by propellor are concurrency safe, including `errorMessage`,+-- `infoMessage`, etc. However, if you write a property that directly+-- uses `print` or `putStrLn`, you can still experience this problem.+--+-- Similarly, when properties run external commands, the command's output+-- can be a problem for concurrency. No need to worry;+-- `Propellor.Property.Cmd.createProcess` is concurrent output safe+-- (it actually uses `Propellor.Message.createProcessConcurrent`), and+-- everything else in propellor that runs external commands is built on top+-- of that. Of course, if you import System.Process and use it in a+-- property, you can bypass that and shoot yourself in the foot.+--+-- Finally, anything that directly accesses the tty can bypass+-- these protections. That's sometimes done for eg, password prompts.+-- A well-written property should avoid running interactive commands+-- anyway.++module Propellor.Property.Concurrent (+	concurrently,+	concurrentList,+	props,+	getNumProcessors,+	concurrentSatisfy,+) where++import Propellor.Base++import Control.Concurrent+import qualified Control.Concurrent.Async as A+import GHC.Conc (getNumProcessors)+import Control.Monad.RWS.Strict++-- | Ensures two properties concurrently.+--+-- >	& foo `concurrently` bar+--+-- To ensure three properties concurrently, just use this combinator twice:+--+-- >	& foo `concurrently` bar `concurrently` baz+concurrently+	:: (IsProp p1, IsProp p2, Combines p1 p2, IsProp (CombinedType p1 p2))+	=> p1+	-> p2+	-> CombinedType p1 p2+concurrently p1 p2 = (combineWith go go p1 p2)+	`describe` d+  where+	d = getDesc p1 ++ " `concurrently` " ++ getDesc p2+	-- Increase the number of capabilities right up to the number of+	-- processors, so that A `concurrently` B `concurrently` C+	-- runs all 3 properties on different processors when possible.+	go a1 a2 = do+		n <- liftIO getNumProcessors+		withCapabilities n $+			concurrentSatisfy a1 a2++-- | Ensures all the properties in the list, with a specified amount of+-- concurrency.+-- +-- > concurrentList (pure 2) "demo" $ props+-- >	& foo+-- >	& bar+-- >	& baz+--+-- The above example will run foo and bar concurrently, and once either of+-- those 2 properties finishes, will start running baz.+concurrentList :: IO Int -> Desc -> PropList -> Property HasInfo+concurrentList getn d (PropList ps) = infoProperty d go mempty ps+  where+	go = do+		n <- liftIO getn+		withCapabilities n $+			startworkers n =<< liftIO (newMVar ps)+	startworkers n q+		| n < 1 = return NoChange+		| n == 1 = worker q NoChange+		| otherwise = +			worker q NoChange+				`concurrentSatisfy`+			startworkers (n-1) q+	worker q r = do+		v <- liftIO $ modifyMVar q $ \v -> case v of+			[] -> return ([], Nothing)+			(p:rest) -> return (rest, Just p)+		case v of+			Nothing -> return r+			-- This use of propertySatisfy does not lose any+			-- Info asociated with the property, because+			-- concurrentList sets all the properties as+			-- children, and so propigates their info.+			Just p -> do+				hn <- asks hostName+				r' <- actionMessageOn hn+					(propertyDesc p)+					(propertySatisfy p)+				worker q (r <> r')++-- | Run an action with the number of capabiities increased as necessary to+-- allow running on the specified number of cores.+--+-- Never increases the number of capabilities higher than the actual number+-- of processors.+withCapabilities :: Int -> Propellor a -> Propellor a+withCapabilities n a = bracket setup cleanup (const a)+  where+	setup = do+		np <- liftIO getNumProcessors+		let n' = min n np+		c <- liftIO getNumCapabilities+		when (n' > c) $ +			liftIO $ setNumCapabilities n'+		return c+	cleanup = liftIO . setNumCapabilities++-- | Running Propellor actions concurrently.+concurrentSatisfy :: Propellor Result -> Propellor Result -> Propellor Result+concurrentSatisfy a1 a2 = do+	h <- ask+	((r1, w1), (r2, w2)) <- liftIO $+		runp a1 h `A.concurrently` runp a2 h+	tell (w1 <> w2)+	return (r1 <> r2)+  where+	runp a h = evalRWST (runWithHost (catchPropellor a)) h ()

@@ -83,7 +83,7 @@  -- | Class of things that can be conducted. class Conductable c where-	conducts :: c -> RevertableProperty+	conducts :: c -> RevertableProperty HasInfo  instance Conductable Host where 	-- | Conduct the specified host.@@ -268,7 +268,7 @@   where 	desc = "not " ++ cdesc (hostName h) -conductorKnownHost :: Host -> RevertableProperty+conductorKnownHost :: Host -> RevertableProperty NoInfo conductorKnownHost h =  	mk Ssh.knownHost 		<!>@@ -290,7 +290,7 @@ 	privinfo h' = forceHostContext (hostName h') $ getInfo (hostInfo h')  -- Use this property to let the specified conductor ssh in and run propellor.-conductedBy :: Host -> RevertableProperty+conductedBy :: Host -> RevertableProperty NoInfo conductedBy h = (setup <!> teardown) 	`describe` ("conducted by " ++ hostName h)   where

@@ -98,7 +98,7 @@ -- When necessary, falls back to installing debootstrap from source. -- Note that installation from source is done by downloading the tarball -- from a Debian mirror, with no cryptographic verification.-installed :: RevertableProperty+installed :: RevertableProperty NoInfo installed = install <!> remove   where 	install = withOS "debootstrap installed" $ \o -> 

@@ -69,16 +69,16 @@ -- Note that the disk image file is reused if it already exists, -- to avoid expensive IO to generate a new one. And, it's updated in-place, -- so its contents are undefined during the build process.-imageBuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty+imageBuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty HasInfo imageBuilt = imageBuilt' False  -- | Like 'built', but the chroot is deleted and rebuilt from scratch each -- time. This is more expensive, but useful to ensure reproducible results -- when the properties of the chroot have been changed.-imageRebuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty+imageRebuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty HasInfo imageRebuilt = imageBuilt' True -imageBuilt' :: Bool -> DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty+imageBuilt' :: Bool -> DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty HasInfo imageBuilt' rebuild img mkchroot tabletype final partspec =  	imageBuiltFrom img chrootdir tabletype final partspec 		`requires` Chroot.provisioned chroot@@ -99,7 +99,7 @@ 		& Apt.cacheCleaned  -- | Builds a disk image from the contents of a chroot.-imageBuiltFrom :: DiskImage -> FilePath -> TableType -> Finalization -> [PartSpec] -> RevertableProperty+imageBuiltFrom :: DiskImage -> FilePath -> TableType -> Finalization -> [PartSpec] -> RevertableProperty NoInfo imageBuiltFrom img chrootdir tabletype final partspec = mkimg <!> rmimg   where 	desc = img ++ " built from " ++ chrootdir

@@ -60,7 +60,7 @@ -- -- In either case, the secondary dns server Host should have an ipv4 and/or -- ipv6 property defined.-primary :: [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> RevertableProperty+primary :: [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> RevertableProperty HasInfo primary hosts domain soa rs = setup <!> cleanup   where 	setup = setupPrimary zonefile id hosts domain soa rs@@ -152,7 +152,7 @@ -- This is different from the serial number used by 'primary', so if you -- want to later disable DNSSEC you will need to adjust the serial number -- passed to mkSOA to ensure it is larger.-signedPrimary :: Recurrance -> [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> RevertableProperty+signedPrimary :: Recurrance -> [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> RevertableProperty HasInfo signedPrimary recurrance hosts domain soa rs = setup <!> cleanup   where 	setup = combineProperties ("dns primary for " ++ domain ++ " (signed)")@@ -164,7 +164,7 @@ 		`onChange` Service.reloaded "bind9"  	cleanup = cleanupPrimary zonefile domain-		`onChange` toProp (revert (zoneSigned domain zonefile))+		`onChange` revert (zoneSigned domain zonefile) 		`onChange` Service.reloaded "bind9"  	-- Include the public keys into the zone file.@@ -184,12 +184,12 @@ -- -- Note that if a host is declared to be a primary and a secondary dns -- server for the same domain, the primary server config always wins.-secondary :: [Host] -> Domain -> RevertableProperty+secondary :: [Host] -> Domain -> RevertableProperty HasInfo secondary hosts domain = secondaryFor (otherServers Master hosts domain) hosts domain  -- | This variant is useful if the primary server does not have its DNS -- configured via propellor.-secondaryFor :: [HostName] -> [Host] -> Domain -> RevertableProperty+secondaryFor :: [HostName] -> [Host] -> Domain -> RevertableProperty HasInfo secondaryFor masters hosts domain = setup <!> cleanup   where 	setup = pureInfoProperty desc (addNamedConf conf)

@@ -7,7 +7,7 @@ -- -- signedPrimary uses this, so this property does not normally need to be -- used directly.-keysInstalled :: Domain -> RevertableProperty+keysInstalled :: Domain -> RevertableProperty HasInfo keysInstalled domain = setup <!> cleanup   where 	setup = propertyList "DNSSEC keys installed" $@@ -37,15 +37,15 @@ -- -- signedPrimary uses this, so this property does not normally need to be -- used directly.-zoneSigned :: Domain -> FilePath -> RevertableProperty+zoneSigned :: Domain -> FilePath -> RevertableProperty HasInfo zoneSigned domain zonefile = setup <!> cleanup   where 	setup = check needupdate (forceZoneSigned domain zonefile)-		`requires` toProp (keysInstalled domain)+		`requires` keysInstalled domain 	 	cleanup = File.notPresent (signedZoneFile zonefile) 		`before` File.notPresent dssetfile-		`before` toProp (revert (keysInstalled domain))+		`before` revert (keysInstalled domain) 	 	dssetfile = dir </> "-" ++ domain ++ "." 	dir = takeDirectory zonefile

@@ -64,6 +64,7 @@ import Data.List hiding (init) import Data.List.Utils import qualified Data.Map as M+import System.Console.Concurrent  installed :: Property NoInfo installed = Apt.installed ["docker.io"]@@ -123,7 +124,7 @@ -- -- Reverting this property ensures that the container is stopped and -- removed.-docked :: Container -> RevertableProperty+docked :: Container -> RevertableProperty HasInfo docked ctr@(Container _ h) = 	(propagateContainerInfo ctr (go "docked" setup)) 		<!>@@ -540,6 +541,7 @@ 				warningMessage "Boot provision failed!" 		void $ async $ job reapzombies 		job $ do+			flushConcurrentOutput 			void $ tryIO $ ifM (inPath "bash") 				( boolSystem "bash" [Param "-l"] 				, boolSystem "/bin/sh" []@@ -555,7 +557,7 @@ provisionContainer cid = containerDesc cid $ property "provisioned" $ liftIO $ do 	let shim = Shim.file (localdir </> "propellor") (localdir </> shimdir cid) 	let params = ["--continue", show $ toChain cid]-	msgh <- mkMessageHandle+	msgh <- getMessageHandle 	let p = inContainerProcess cid 		(if isConsole msgh then ["-it"] else []) 		(shim : params)@@ -583,6 +585,7 @@ 			r <- runPropellor h $ ensureProperties $ 				map ignoreInfo $ 					hostProperties h+			flushConcurrentOutput 			putStrLn $ "\n" ++ show r  stopContainer :: ContainerId -> IO Bool

@@ -5,6 +5,7 @@  import System.Posix.Files import System.PosixCompat.Types+import System.Exit  type Line = String @@ -133,6 +134,27 @@ 			then noChange 			else makeChange updateLink 	updateLink = createSymbolicLink target `viaStableTmp` link++-- | Ensures that a file is a copy of another (regular) file.+isCopyOf :: FilePath -> FilePath -> Property NoInfo+f `isCopyOf` f' = property desc $ go =<< (liftIO $ tryIO $ getFileStatus f')+  where+	desc = f ++ " is copy of " ++ f'+	go (Right stat) = if isRegularFile stat+		then gocmp =<< (liftIO $ cmp)+		else warningMessage (f' ++ " is not a regular file") >>+			return FailedChange+	go (Left e) = warningMessage (show e) >> return FailedChange++	cmp = safeSystem "cmp" [Param "-s", Param "--", File f, File f']+	gocmp ExitSuccess = noChange+	gocmp (ExitFailure 1) = doit+	gocmp _ = warningMessage "cmp failed" >> return FailedChange++	doit = makeChange $ copy f' `viaStableTmp` f+	copy src dest = unlessM (runcp src dest) $ errorMessage "cp failed"+	runcp src dest = boolSystem "cp"+		[Param "--preserve=all", Param "--", File src, File dest]  -- | Ensures that a file/dir has the specified owner and group. ownerGroup :: FilePath -> User -> Group -> Property NoInfo

@@ -11,7 +11,7 @@ -- using git-daemon, run from inetd. -- -- Note that reverting this property does not remove or stop inetd.-daemonRunning :: FilePath -> RevertableProperty+daemonRunning :: FilePath -> RevertableProperty NoInfo daemonRunning exportdir = setup <!> unsetup   where 	setup = containsLine conf (mkl "tcp4")

@@ -5,6 +5,7 @@ 	props, 	PropertyList(..), 	PropertyListType,+	PropList(..), ) where  import Propellor.Types

@@ -9,7 +9,7 @@  type ConfigFile = [String] -siteEnabled :: HostName -> ConfigFile -> RevertableProperty+siteEnabled :: HostName -> ConfigFile -> RevertableProperty NoInfo siteEnabled hn cf = enable <!> disable   where 	enable = siteVal hn `File.isSymlinkedTo` siteValRelativeCfg hn

@@ -11,7 +11,7 @@  type Conf = String -confEnabled :: Conf -> ConfigFile -> RevertableProperty+confEnabled :: Conf -> ConfigFile -> RevertableProperty NoInfo confEnabled conf cf = enable <!> disable   where 	enable = dir `File.isSymlinkedTo` target

@@ -298,7 +298,7 @@ 		, "  </Directory>" 		] -apacheSite :: HostName -> Bool -> Apache.ConfigFile -> RevertableProperty+apacheSite :: HostName -> Bool -> Apache.ConfigFile -> RevertableProperty NoInfo apacheSite hn withssl middle = Apache.siteEnabled hn $ apachecfg hn withssl middle  apachecfg :: HostName -> Bool -> Apache.ConfigFile -> Apache.ConfigFile@@ -738,7 +738,7 @@ -- This value can be included in a domain's additional records to make -- it use this domainkey. domainKey :: (BindDomain, Record)-domainKey = (RelDomain "mail._domainkey", TXT "v=DKIM1; k=rsa; t=y; p=MIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKBgQCc+/rfzNdt5DseBBmfB3C6sVM7FgVvf4h1FeCfyfwPpVcmPdW6M2I+NtJsbRkNbEICxiP6QY2UM0uoo9TmPqLgiCCG2vtuiG6XMsS0Y/gGwqKM7ntg/7vT1Go9vcquOFFuLa5PnzpVf8hB9+PMFdS4NPTvWL2c5xxshl/RJzICnQIDAQAB")+domainKey = (RelDomain "mail._domainkey", TXT "v=DKIM1; k=rsa; p=MIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKBgQCc+/rfzNdt5DseBBmfB3C6sVM7FgVvf4h1FeCfyfwPpVcmPdW6M2I+NtJsbRkNbEICxiP6QY2UM0uoo9TmPqLgiCCG2vtuiG6XMsS0Y/gGwqKM7ntg/7vT1Go9vcquOFFuLa5PnzpVf8hB9+PMFdS4NPTvWL2c5xxshl/RJzICnQIDAQAB")  hasJoeyCAChain :: Property HasInfo hasJoeyCAChain = "/etc/ssl/certs/joeyca.pem" `File.hasPrivContentExposed`@@ -921,10 +921,10 @@ 		, "rewriterule (.*) http://joeyh.name$1 [r]" 		] -userDirHtml :: Property HasInfo+userDirHtml :: Property NoInfo userDirHtml = File.fileProperty "apache userdir is html" (map munge) conf 	`onChange` Apache.reloaded-	`requires` (toProp $ Apache.modEnabled "userdir")+	`requires` Apache.modEnabled "userdir"   where 	munge = replace "public_html" "html" 	conf = "/etc/apache2/mods-available/userdir.conf"

@@ -115,7 +115,7 @@ -- ports it is configured to listen on. -- -- Revert to prevent it listening on a particular port.-listenPort :: Int -> RevertableProperty+listenPort :: Int -> RevertableProperty NoInfo listenPort port = enable <!> disable   where 	portline = "Port " ++ show port

@@ -93,7 +93,7 @@ 	`describe` ("service " ++ n ++ " disabled")  -- | Masks a systemd service.-masked :: ServiceName -> RevertableProperty+masked :: ServiceName -> RevertableProperty NoInfo masked n = systemdMask <!> systemdUnmask   where 	systemdMask   = trivial $ cmdProperty "systemctl" ["mask", n]@@ -206,7 +206,7 @@ -- -- Reverting this property stops the container, removes the systemd unit, -- and deletes the chroot and all its contents.-nspawned :: Container -> RevertableProperty+nspawned :: Container -> RevertableProperty HasInfo nspawned c@(Container name (Chroot.Chroot loc builder _) h) = 	p `describe` ("nspawned " ++ name)   where@@ -231,7 +231,7 @@  -- | Sets up the service file for the container, and then starts -- it running.-nspawnService :: Container -> ChrootCfg -> RevertableProperty+nspawnService :: Container -> ChrootCfg -> RevertableProperty NoInfo nspawnService (Container name _ _) cfg = setup <!> teardown   where 	service = nspawnServiceName name@@ -282,7 +282,7 @@ -- -- This uses nsenter to enter the container, by looking up the pid of the -- container's init process and using its namespace.-enterScript :: Container -> RevertableProperty+enterScript :: Container -> RevertableProperty NoInfo enterScript c@(Container name _ _) = setup <!> teardown   where 	setup = combineProperties ("generated " ++ enterScriptFile c)@@ -328,7 +328,7 @@ -- When there is no leading dash, "--" is prepended to the parameter. -- -- Reverting the property will remove a parameter, if it's present.-containerCfg :: String -> RevertableProperty+containerCfg :: String -> RevertableProperty HasInfo containerCfg p = RevertableProperty (mk True) (mk False)   where 	mk b = pureInfoProperty ("container configuration " ++ (if b then "" else "without ") ++ p') $@@ -340,18 +340,18 @@ -- | Bind mounts </etc/resolv.conf> from the host into the container. -- -- This property is enabled by default. Revert it to disable it.-resolvConfed :: RevertableProperty+resolvConfed :: RevertableProperty HasInfo resolvConfed = containerCfg "bind=/etc/resolv.conf"  -- | Link the container's journal to the host's if possible. -- (Only works if the host has persistent journal enabled.) -- -- This property is enabled by default. Revert it to disable it.-linkJournal :: RevertableProperty+linkJournal :: RevertableProperty HasInfo linkJournal = containerCfg "link-journal=try-guest"  -- | Disconnect networking of the container from the host.-privateNetwork :: RevertableProperty+privateNetwork :: RevertableProperty HasInfo privateNetwork = containerCfg "private-network"  class Publishable a where@@ -389,7 +389,7 @@ -- >	& Systemd.running Systemd.networkd -- >	& Systemd.publish (Port 80 ->- Port 8080) -- >	& Apt.installedRunning "apache2"-publish :: Publishable p => p -> RevertableProperty+publish :: Publishable p => p -> RevertableProperty HasInfo publish p = containerCfg $ "--port=" ++ toPublish p  class Bindable a where@@ -402,9 +402,9 @@ 	toBind v = hostSide v ++ ":" ++ containerSide v  -- | Bind mount a file or directory from the host into the container.-bind :: Bindable p => p -> RevertableProperty+bind :: Bindable p => p -> RevertableProperty HasInfo bind p = containerCfg $ "--bind=" ++ toBind p  -- | Read-only mind mount.-bindRo :: Bindable p => p -> RevertableProperty+bindRo :: Bindable p => p -> RevertableProperty HasInfo bindRo p = containerCfg $ "--bind-ro=" ++ toBind p

@@ -11,7 +11,7 @@  type AppName = String -appEnabled :: AppName -> ConfigFile -> RevertableProperty+appEnabled :: AppName -> ConfigFile -> RevertableProperty NoInfo appEnabled an cf = enable <!> disable   where 	enable = appVal an `File.isSymlinkedTo` appValRelativeCfg an

@@ -33,7 +33,8 @@ commitSpin :: IO () commitSpin = do 	void $ actionMessage "Git commit" $-		gitCommit [Param "--allow-empty", Param "-a", Param "-m", Param spinCommitMessage]+		gitCommit (Just spinCommitMessage) +			[Param "--allow-empty", Param "-a"] 	-- Push to central origin repo first, if possible. 	-- The remote propellor will pull from there, which avoids 	-- us needing to send stuff directly to the remote host.@@ -60,7 +61,7 @@ 	updateServer target relay hst 		(proc "ssh" $ cacheparams ++ [sshtarget, shellWrap probecmd]) 		(proc "ssh" $ cacheparams ++ [sshtarget, shellWrap updatecmd])-		getprivdata+		=<< getprivdata  	-- And now we can run it. 	unlessM (boolSystem "ssh" (map Param $ cacheparams ++ ["-t", sshtarget, shellWrap runcmd])) $@@ -189,16 +190,16 @@ 	-> Host 	-> CreateProcess 	-> CreateProcess-	-> IO PrivMap+	-> PrivMap 	-> IO ()-updateServer target relay hst connect haveprecompiled getprivdata =+updateServer target relay hst connect haveprecompiled privdata = 	withIOHandles createProcessSuccess connect go   where 	hn = fromMaybe target relay  	go (toh, fromh) = do 		let loop = go (toh, fromh)-		let restart = updateServer hn relay hst connect haveprecompiled getprivdata+		let restart = updateServer hn relay hst connect haveprecompiled privdata 		let done = return () 		v <- maybe Nothing readish <$> getMarked fromh statusMarker 		case v of@@ -206,7 +207,7 @@ 				sendRepoUrl toh 				loop 			(Just NeedPrivData) -> do-				sendPrivData hn toh =<< getprivdata+				sendPrivData hn toh privdata 				loop 			(Just NeedGitClone) -> do 				hClose toh@@ -217,7 +218,7 @@ 				hClose toh 				hClose fromh 				sendPrecompiled hn-				updateServer hn relay hst haveprecompiled (error "loop") getprivdata+				updateServer hn relay hst haveprecompiled (error "loop") privdata 			(Just NeedGitPush) -> do 				sendGitUpdate hn fromh toh 				hClose fromh@@ -336,8 +337,9 @@ 	old_head <- getCurrentGitSha1 branch 	old_commit <- findLastNonSpinCommit 	rungit "reset" [Param old_commit]-	rungit "commit" [Param "-a", Param "--allow-empty"]-	rungit "merge" =<< gpgSignParams [Param "-s", Param "ours", Param old_head]+	unlessM (gitCommit Nothing [Param "-a", Param "--allow-empty"]) $+		error "git commit failed"+	rungit "merge" =<< gpgSignParams [Param "-s", Param "ours", Param old_head, Param "--no-edit"] 	current_commit <- getCurrentGitSha1 branch 	rungit "update-ref" [Param branchref, Param current_commit] 	rungit "checkout" [Param branch]

@@ -27,7 +27,6 @@ 	, IsProp(..) 	, Combines(..) 	, CombinedType-	, combineWith 	, Propellor(..) 	, LiftPropellor(..) 	, EndAction(..)@@ -157,9 +156,6 @@ propertySatisfy (IProperty _ a _ _) = a propertySatisfy (SProperty _ a _) = a -instance Show (Property i) where-        show p = "property " ++ show (propertyDesc p)- -- | Changes the action that is performed to satisfy a property.  adjustPropertySatisfy :: Property i -> (Propellor Result -> Propellor Result) -> Property i adjustPropertySatisfy (IProperty d s i cs) f = IProperty d (f s) i cs@@ -173,6 +169,9 @@ propertyDesc (IProperty d _ _ _) = d propertyDesc (SProperty d _ _) = d +instance Show (Property i) where+        show p = "property " ++ show (propertyDesc p)+ -- | A Property can include a list of child properties that it also -- satisfies. This allows them to be introspected to collect their info, etc. propertyChildren :: Property i -> [Property i]@@ -181,12 +180,24 @@  -- | A property that can be reverted. The first Property is run -- normally and the second is run when it's reverted.-data RevertableProperty = RevertableProperty (Property HasInfo) (Property HasInfo)+data RevertableProperty i = RevertableProperty (Property i) (Property i) --- | Shorthand to construct a revertable property.-(<!>) :: Property i1 -> Property i2 -> RevertableProperty-p1 <!> p2 = RevertableProperty (toIProperty p1) (toIProperty p2)+instance Show (RevertableProperty i) where+        show (RevertableProperty p _) = show p +class MkRevertableProperty i1 i2 where+	-- | Shorthand to construct a revertable property.+	(<!>) :: Property i1 -> Property i2 -> RevertableProperty (CInfo i1 i2)++instance MkRevertableProperty HasInfo HasInfo where+	x <!> y = RevertableProperty x y+instance MkRevertableProperty NoInfo NoInfo where+	x <!> y = RevertableProperty x y+instance MkRevertableProperty NoInfo HasInfo where+	x <!> y = RevertableProperty (toProp x) y+instance MkRevertableProperty HasInfo NoInfo where+	x <!> y = RevertableProperty x (toProp y)+ -- | Class of types that can be used as properties of a host. class IsProp p where 	setDesc :: p -> Desc -> p@@ -208,70 +219,116 @@ 	getDesc = propertyDesc 	getInfoRecursive _ = mempty -instance IsProp RevertableProperty where-	-- | Sets the description of both sides.-	setDesc (RevertableProperty p1 p2) d = -		RevertableProperty (setDesc p1 d) (setDesc p2 ("not " ++ d))+instance IsProp (RevertableProperty HasInfo) where+	setDesc = setDescR 	getDesc (RevertableProperty p1 _) = getDesc p1 	toProp (RevertableProperty p1 _) = p1 	-- | Return the Info of the currently active side. 	getInfoRecursive (RevertableProperty p1 _p2) = getInfoRecursive p1+instance IsProp (RevertableProperty NoInfo) where+	setDesc = setDescR+	getDesc (RevertableProperty p1 _) = getDesc p1+	toProp (RevertableProperty p1 _) = toProp p1+	getInfoRecursive (RevertableProperty _ _) = mempty +-- | Sets the description of both sides.+setDescR :: IsProp (Property i) => RevertableProperty i -> Desc -> RevertableProperty i+setDescR (RevertableProperty p1 p2) d =+	RevertableProperty (setDesc p1 d) (setDesc p2 ("not " ++ d))+ -- | Type level calculation of the type that results from combining two -- types of properties. type family CombinedType x y type instance CombinedType (Property x) (Property y) = Property (CInfo x y)-type instance CombinedType RevertableProperty (Property NoInfo) = RevertableProperty-type instance CombinedType RevertableProperty (Property HasInfo) = RevertableProperty-type instance CombinedType RevertableProperty RevertableProperty = RevertableProperty+type instance CombinedType (RevertableProperty x) (RevertableProperty y) = RevertableProperty (CInfo x y)+-- When only one of the properties is revertable, the combined property is+-- not fully revertable, so is not a RevertableProperty.+type instance CombinedType (RevertableProperty x) (Property y) = Property (CInfo x y)+type instance CombinedType (Property x) (RevertableProperty y) = Property (CInfo x y) -class Combines x y where-	-- | Combines two properties. The second property is ensured-	-- first, and only once it is successfully ensures will the first-	-- be ensured. The combined property will have the description of-	-- the first property.-	(<<>>) :: x -> y -> CombinedType x y+type ResultCombiner = Propellor Result -> Propellor Result -> Propellor Result --- | Combines together two properties, yielding a property that--- has the description and info of the first, and that has the second--- property as a child. The two actions to satisfy the properties--- are passed to a function that can combine them in arbitrary ways.-combineWith-	:: (Combines (Property x) (Property y))-	=> (Propellor Result -> Propellor Result -> Propellor Result)-	-> Property x-	-> Property y-	-> CombinedType (Property x) (Property y)-combineWith f x y = adjustPropertySatisfy (x <<>> y) $ \_ ->-	f (propertySatisfy $ toSProperty x) (propertySatisfy $ toSProperty y)+class Combines x y where+	-- | Combines together two properties, yielding a property that+	-- has the description and info of the first, and that has the second+	-- property as a child. +	combineWith +		:: ResultCombiner+		-- ^ How to combine the actions to satisfy the properties.+		-> ResultCombiner+		-- ^ Used when combining revertable properties, to combine+		-- their reversion actions.+		-> x+		-> y+		-> CombinedType x y  instance Combines (Property HasInfo) (Property HasInfo) where-	(IProperty d1 a1 i1 cs1) <<>> y@(IProperty _d2 a2 _i2 _cs2) =-		IProperty d1 (a2 <> a1) i1 (y : cs1)+	combineWith f _ (IProperty d1 a1 i1 cs1) y@(IProperty _d2 a2 _i2 _cs2) =+		IProperty d1 (f a1 a2) i1 (y : cs1)  instance Combines (Property HasInfo) (Property NoInfo) where-	(IProperty d1 a1 i1 cs1) <<>> y@(SProperty _d2 a2 _cs2) =-		IProperty d1 (a2 <> a1) i1 (toIProperty y : cs1)+	combineWith f _ (IProperty d1 a1 i1 cs1) y@(SProperty _d2 a2 _cs2) =+		IProperty d1 (f a1 a2) i1 (toIProperty y : cs1)  instance Combines (Property NoInfo) (Property HasInfo) where-	(SProperty d1 a1 cs1) <<>> y@(IProperty _d2 a2 _i2 _cs2) =-		IProperty d1 (a2 <> a1) mempty (y : map toIProperty cs1)+	combineWith f _ (SProperty d1 a1 cs1) y@(IProperty _d2 a2 _i2 _cs2) =+		IProperty d1 (f a1 a2) mempty (y : map toIProperty cs1)  instance Combines (Property NoInfo) (Property NoInfo) where-	(SProperty d1 a1  cs1) <<>> y@(SProperty _d2 a2 _cs2) =-		SProperty d1 (a2 <> a1) (y : cs1)+	combineWith f _ (SProperty d1 a1  cs1) y@(SProperty _d2 a2 _cs2) =+		SProperty d1 (f a1 a2) (y : cs1) -instance Combines RevertableProperty (Property HasInfo) where-	(RevertableProperty p1 p2) <<>> y =-		RevertableProperty (p1 <<>> y) p2+instance Combines (RevertableProperty NoInfo) (RevertableProperty NoInfo) where+	combineWith = combineWithRR+instance Combines (RevertableProperty HasInfo) (RevertableProperty HasInfo) where+	combineWith = combineWithRR+instance Combines (RevertableProperty HasInfo) (RevertableProperty NoInfo) where+	combineWith = combineWithRR+instance Combines (RevertableProperty NoInfo) (RevertableProperty HasInfo) where+	combineWith = combineWithRR+instance Combines (RevertableProperty NoInfo) (Property HasInfo) where+	combineWith = combineWithRP+instance Combines (RevertableProperty NoInfo) (Property NoInfo) where+	combineWith = combineWithRP+instance Combines (RevertableProperty HasInfo) (Property HasInfo) where+	combineWith = combineWithRP+instance Combines (RevertableProperty HasInfo) (Property NoInfo) where+	combineWith = combineWithRP+instance Combines (Property HasInfo) (RevertableProperty NoInfo) where+	combineWith = combineWithPR+instance Combines (Property NoInfo) (RevertableProperty NoInfo) where+	combineWith = combineWithPR+instance Combines (Property HasInfo) (RevertableProperty HasInfo) where+	combineWith = combineWithPR+instance Combines (Property NoInfo) (RevertableProperty HasInfo) where+	combineWith = combineWithPR -instance Combines RevertableProperty (Property NoInfo) where-	(RevertableProperty p1 p2) <<>> y =-		RevertableProperty (p1 <<>> toIProperty y) p2+combineWithRR +	:: Combines (Property x) (Property y)+	=> ResultCombiner+	-> ResultCombiner+	-> RevertableProperty x+	-> RevertableProperty y+	-> RevertableProperty (CInfo x y)+combineWithRR sf tf (RevertableProperty s1 t1) (RevertableProperty s2 t2) =+	RevertableProperty+		(combineWith sf tf s1 s2)+		(combineWith tf sf t1 t2) -instance Combines RevertableProperty RevertableProperty where-	(RevertableProperty x1 x2) <<>> (RevertableProperty y1 y2) =-		RevertableProperty-			(x1 <<>> y1)-			-- when reverting, run actions in reverse order-			(y2 <<>> x2)+combineWithRP+	:: Combines (Property i) y+	=> (Propellor Result -> Propellor Result -> Propellor Result)+	-> (Propellor Result -> Propellor Result -> Propellor Result)+	-> RevertableProperty i+	-> y+	-> CombinedType (Property i) y+combineWithRP sf tf (RevertableProperty x _) y = combineWith sf tf x y++combineWithPR+	:: Combines x (Property i)+	=> (Propellor Result -> Propellor Result -> Propellor Result)+	-> (Propellor Result -> Propellor Result -> Propellor Result)+	-> x+	-> RevertableProperty i+	-> CombinedType x (Property i)+combineWithPR sf tf x (RevertableProperty y _) = combineWith sf tf x y

@@ -0,0 +1,44 @@+-- | +-- Copyright: 2015 Joey Hess <id@joeyh.name>+-- License: BSD-2-clause+-- +-- Concurrent output handling.+--+-- > import Control.Concurrent.Async+-- > import System.Console.Concurrent+-- >+-- > main = withConcurrentOutput $+-- > 	outputConcurrent "washed the car\n"+-- > 		`concurrently`+-- >	outputConcurrent "walked the dog\n"+-- >		`concurrently`+-- > 	createProcessConcurrent (proc "ls" [])++{-# LANGUAGE CPP #-}++module System.Console.Concurrent (+	-- * Concurrent output+	withConcurrentOutput,+	Outputable(..),+	outputConcurrent,+	errorConcurrent,+	ConcurrentProcessHandle,+#ifndef mingw32_HOST_OS+	createProcessConcurrent,+#endif+	waitForProcessConcurrent,+	createProcessForeground,+	flushConcurrentOutput,+	lockOutput,+	-- * Low level access to the output buffer+	OutputBuffer,+	StdHandle(..),+	bufferOutputSTM,+	outputBufferWaiterSTM,+	waitAnyBuffer,+	waitCompleteLines,+	emitOutputBuffer,+) where++import System.Console.Concurrent.Internal+

@@ -0,0 +1,538 @@+{-# LANGUAGE BangPatterns, TypeSynonymInstances, FlexibleInstances, TupleSections #-}+{-# LANGUAGE CPP #-}++-- | +-- Copyright: 2015 Joey Hess <id@joeyh.name>+-- License: BSD-2-clause+-- +-- Concurrent output handling, internals.+--+-- May change at any time.++module System.Console.Concurrent.Internal where++import System.IO+#ifndef mingw32_HOST_OS+import System.Posix.IO+#endif+import System.Directory+import System.Exit+import Control.Monad+import Control.Monad.IO.Class (liftIO, MonadIO)+import Control.Applicative+import System.IO.Unsafe (unsafePerformIO)+import Control.Concurrent+import Control.Concurrent.STM+import Control.Concurrent.Async+import Data.Maybe+import Data.List+import Data.Monoid+import qualified System.Process as P+import qualified Data.Text as T+import qualified Data.Text.IO as T++import Utility.Monad+import Utility.Exception++data OutputHandle = OutputHandle+	{ outputLock :: TMVar Lock+	, outputBuffer :: TMVar OutputBuffer+	, errorBuffer :: TMVar OutputBuffer+	, outputThreads :: TMVar Integer+	, processWaiters :: TMVar [Async ()]+	, waitForProcessLock :: TMVar ()+	}++data Lock = Locked++-- | A shared global variable for the OutputHandle.+{-# NOINLINE globalOutputHandle #-}+globalOutputHandle :: OutputHandle+globalOutputHandle = unsafePerformIO $ OutputHandle+	<$> newEmptyTMVarIO+	<*> newTMVarIO (OutputBuffer [])+	<*> newTMVarIO (OutputBuffer [])+	<*> newTMVarIO 0+	<*> newTMVarIO []+	<*> newEmptyTMVarIO++-- | Holds a lock while performing an action. This allows the action to+-- perform its own output to the console, without using functions from this+-- module.+--+-- While this is running, other threads that try to lockOutput will block.+-- Any calls to `outputConcurrent` and `createProcessConcurrent` will not+-- block, but the output will be buffered and displayed only once the+-- action is done.+lockOutput :: (MonadIO m, MonadMask m) => m a -> m a+lockOutput = bracket_ (liftIO takeOutputLock) (liftIO dropOutputLock)++-- | Blocks until we have the output lock.+takeOutputLock :: IO ()+takeOutputLock = void $ takeOutputLock' True++-- | Tries to take the output lock, without blocking.+tryTakeOutputLock :: IO Bool+tryTakeOutputLock = takeOutputLock' False++withLock :: (TMVar Lock -> STM a) -> IO a+withLock a = atomically $ a (outputLock globalOutputHandle)++takeOutputLock' :: Bool -> IO Bool+takeOutputLock' block = do+	locked <- withLock $ \l -> do+		v <- tryTakeTMVar l+		case v of+			Just Locked+				| block -> retry+				| otherwise -> do+					-- Restore value we took.+					putTMVar l Locked+					return False+			Nothing -> do+				putTMVar l Locked+				return True+	when locked $ do+		(outbuf, errbuf) <- atomically $ (,)+			<$> swapTMVar (outputBuffer globalOutputHandle) (OutputBuffer [])+			<*> swapTMVar (errorBuffer globalOutputHandle) (OutputBuffer [])+		emitOutputBuffer StdOut outbuf+		emitOutputBuffer StdErr errbuf+	return locked++-- | Only safe to call after taking the output lock.+dropOutputLock :: IO ()+dropOutputLock = withLock $ void . takeTMVar++-- | Use this around any actions that use `outputConcurrent`+-- or `createProcessConcurrent`+--+-- This is necessary to ensure that buffered concurrent output actually+-- gets displayed before the program exits.+withConcurrentOutput :: (MonadIO m, MonadMask m) => m a -> m a+withConcurrentOutput a = a `finally` liftIO flushConcurrentOutput++-- | Blocks until any processes started by `createProcessConcurrent` have+-- finished, and any buffered output is displayed. +--+-- `withConcurrentOutput` calls this at the end; you can call it anytime+-- you want to flush output.+flushConcurrentOutput :: IO ()+flushConcurrentOutput = do+	-- Wait for all outputThreads to finish.+	let v = outputThreads globalOutputHandle+	atomically $ do+		r <- takeTMVar v+		if r <= 0+			then putTMVar v r+			else retry+	-- Take output lock to ensure that nothing else is currently+	-- generating output, and flush any buffered output.+	lockOutput $ return ()++-- | Values that can be output.+class Outputable v where+	toOutput :: v -> T.Text++instance Outputable T.Text where+	toOutput = id++instance Outputable String where+	toOutput = toOutput . T.pack++-- | Displays a value to stdout.+--+-- No newline is appended to the value, so if you want a newline, be sure+-- to include it yourself.+--+-- Uses locking to ensure that the whole output occurs atomically+-- even when other threads are concurrently generating output.+--+-- When something else is writing to the console at the same time, this does+-- not block. It buffers the value, so it will be displayed once the other+-- writer is done.+outputConcurrent :: Outputable v => v -> IO ()+outputConcurrent = outputConcurrent' StdOut++-- | Like `outputConcurrent`, but displays to stderr.+--+-- (Does not throw an exception.)+errorConcurrent :: Outputable v => v -> IO ()+errorConcurrent = outputConcurrent' StdErr++outputConcurrent' :: Outputable v => StdHandle -> v -> IO ()+outputConcurrent' stdh v = bracket setup cleanup go+  where+	setup = tryTakeOutputLock+	cleanup False = return ()+	cleanup True = dropOutputLock+	go True = do+		T.hPutStr h (toOutput v)+		hFlush h+	go False = do+		oldbuf <- atomically $ takeTMVar bv+		newbuf <- addOutputBuffer (Output (toOutput v)) oldbuf+		atomically $ putTMVar bv newbuf+	h = toHandle stdh+	bv = bufferFor stdh++newtype ConcurrentProcessHandle = ConcurrentProcessHandle P.ProcessHandle++toConcurrentProcessHandle :: (Maybe Handle, Maybe Handle, Maybe Handle, P.ProcessHandle) -> (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle)+toConcurrentProcessHandle (i, o, e, h) = (i, o, e, ConcurrentProcessHandle h)++-- | Use this to wait for processes started with +-- `createProcessConcurrent` and `createProcessForeground`, and get their+-- exit status.+--+-- Note that such processes are actually automatically waited for+-- internally, so not calling this explicitly will not result+-- in zombie processes. This behavior differs from `P.waitForProcess`+waitForProcessConcurrent :: ConcurrentProcessHandle -> IO ExitCode+waitForProcessConcurrent (ConcurrentProcessHandle h) = +	bracket lock unlock checkexit+  where+	lck = waitForProcessLock globalOutputHandle+	lock = atomically $ tryPutTMVar lck ()+	unlock True = atomically $ takeTMVar lck+	unlock False = return ()+	checkexit locked = maybe (waitsome locked) return+		=<< P.getProcessExitCode h+	waitsome True = do+		let v = processWaiters globalOutputHandle+		l <- atomically $ readTMVar v+		if null l+			-- Avoid waitAny [] which blocks forever+			then P.waitForProcess h+			else do+				-- Wait for any of the running+				-- processes to exit. It may or may not+				-- be the one corresponding to the+				-- ProcessHandle. If it is,+				-- getProcessExitCode will succeed.+				void $ tryIO $ waitAny l+				checkexit True+	waitsome False = do+		-- Another thread took the lck first. Wait for that thread to+		-- wait for one of the running processes to exit.+		atomically $ do+			putTMVar lck ()+			takeTMVar lck+		checkexit False++-- Registers an action that waits for a process to exit,+-- adding it to the processWaiters list, and removing it once the action+-- completes.+asyncProcessWaiter :: IO () -> IO ()+asyncProcessWaiter waitaction = do+	regdone <- newEmptyTMVarIO+	waiter <- async $ do+		self <- atomically (takeTMVar regdone)+		waitaction `finally` unregister self+	register waiter regdone+  where+	v = processWaiters globalOutputHandle+  	register waiter regdone = atomically $ do+		l <- takeTMVar v+		putTMVar v (waiter:l)+		putTMVar regdone waiter+	unregister waiter = atomically $ do+		l <- takeTMVar v+		putTMVar v (filter (/= waiter) l)++-- | Wrapper around `System.Process.createProcess` that prevents +-- multiple processes that are running concurrently from writing+-- to stdout/stderr at the same time.+--+-- If the process does not output to stdout or stderr, it's run+-- by createProcess entirely as usual. Only processes that can generate+-- output are handled specially:+--+-- A process is allowed to write to stdout and stderr in the usual+-- way, assuming it can successfully take the output lock.+--+-- When the output lock is held (ie, by another concurrent process,+-- or because `outputConcurrent` is being called at the same time),+-- the process is instead run with its stdout and stderr+-- redirected to a buffer. The buffered output will be displayed as soon+-- as the output lock becomes free.+--+-- Currently only available on Unix systems, not Windows.+#ifndef mingw32_HOST_OS+createProcessConcurrent :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle) +createProcessConcurrent p+	| willOutput (P.std_out p) || willOutput (P.std_err p) =+		ifM tryTakeOutputLock+			( fgProcess p+			, bgProcess p+			)+	| otherwise = do+		r@(_, _, _, h) <- P.createProcess p+		asyncProcessWaiter $+			void $ tryIO $ P.waitForProcess h+		return (toConcurrentProcessHandle r)+#endif++-- | Wrapper around `System.Process.createProcess` that makes sure a process+-- is run in the foreground, with direct access to stdout and stderr.+-- Useful when eg, running an interactive process.+createProcessForeground :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle)+createProcessForeground p = do+	takeOutputLock+	fgProcess p++fgProcess :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle)+fgProcess p = do+	r@(_, _, _, h) <- P.createProcess p+		`onException` dropOutputLock+	-- Wait for the process to exit and drop the lock.+	asyncProcessWaiter $ do+		void $ tryIO $ P.waitForProcess h+		dropOutputLock+	return (toConcurrentProcessHandle r)++#ifndef mingw32_HOST_OS+bgProcess :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle)+bgProcess p = do+	(toouth, fromouth) <- pipe+	(toerrh, fromerrh) <- pipe+	let p' = p+		{ P.std_out = rediroutput (P.std_out p) toouth+		, P.std_err = rediroutput (P.std_err p) toerrh+		}+	registerOutputThread+	r@(_, _, _, h) <- P.createProcess p'+		`onException` unregisterOutputThread+	asyncProcessWaiter $ void $ tryIO $ P.waitForProcess h+	outbuf <- setupOutputBuffer StdOut toouth (P.std_out p) fromouth+	errbuf <- setupOutputBuffer StdErr toerrh (P.std_err p) fromerrh+	void $ async $ bufferWriter [outbuf, errbuf]+	return (toConcurrentProcessHandle r)+  where+	pipe = do+		(from, to) <- createPipe+		(,) <$> fdToHandle to <*> fdToHandle from+	rediroutput ss h+		| willOutput ss = P.UseHandle h+		| otherwise = ss+#endif++willOutput :: P.StdStream -> Bool+willOutput P.Inherit = True+willOutput _ = False++-- | Buffered output.+data OutputBuffer = OutputBuffer [OutputBufferedActivity]+	deriving (Eq)++data StdHandle = StdOut | StdErr++toHandle :: StdHandle -> Handle+toHandle StdOut = stdout+toHandle StdErr = stderr++bufferFor :: StdHandle -> TMVar OutputBuffer+bufferFor StdOut = outputBuffer globalOutputHandle+bufferFor StdErr = errorBuffer globalOutputHandle++data OutputBufferedActivity+	= Output T.Text+	| InTempFile+		{ tempFile :: FilePath+		, endsInNewLine :: Bool+		}+	deriving (Eq)++data AtEnd = AtEnd+	deriving Eq++data BufSig = BufSig++setupOutputBuffer :: StdHandle -> Handle -> P.StdStream -> Handle -> IO (StdHandle, MVar OutputBuffer, TMVar BufSig, TMVar AtEnd)+setupOutputBuffer h toh ss fromh = do+	hClose toh+	buf <- newMVar (OutputBuffer [])+	bufsig <- atomically newEmptyTMVar+	bufend <- atomically newEmptyTMVar+	void $ async $ outputDrainer ss fromh buf bufsig bufend+	return (h, buf, bufsig, bufend)++-- Drain output from the handle, and buffer it.+outputDrainer :: P.StdStream -> Handle -> MVar OutputBuffer -> TMVar BufSig -> TMVar AtEnd -> IO ()+outputDrainer ss fromh buf bufsig bufend+	| willOutput ss = go+	| otherwise = atend+  where+	go = do+		t <- T.hGetChunk fromh+		if T.null t+			then atend+			else do+				modifyMVar_ buf $ addOutputBuffer (Output t)+				changed+				go+	atend = do+		atomically $ putTMVar bufend AtEnd+		hClose fromh+	changed = atomically $ do+		void $ tryTakeTMVar bufsig+		putTMVar bufsig BufSig++registerOutputThread :: IO ()+registerOutputThread = do+	let v = outputThreads globalOutputHandle+	atomically $ putTMVar v . succ =<< takeTMVar v+	+unregisterOutputThread :: IO ()+unregisterOutputThread = do+	let v = outputThreads globalOutputHandle+	atomically $ putTMVar v . pred =<< takeTMVar v++-- Wait to lock output, and once we can, display everything +-- that's put into the buffers, until the end.+--+-- If end is reached before lock is taken, instead add the command's+-- buffers to the global outputBuffer and errorBuffer.+bufferWriter :: [(StdHandle, MVar OutputBuffer, TMVar BufSig, TMVar AtEnd)] -> IO ()+bufferWriter ts = do+	activitysig <- atomically newEmptyTMVar+	worker1 <- async $ lockOutput $+		ifM (atomically $ tryPutTMVar activitysig ())+			( void $ mapConcurrently displaybuf ts+			, noop -- buffers already moved to global+			)+	worker2 <- async $ void $ globalbuf activitysig+	void $ async $ do+		void $ waitCatch worker1+		void $ waitCatch worker2+		unregisterOutputThread+  where+	displaybuf v@(outh, buf, bufsig, bufend) = do+		change <- atomically $+			(Right <$> takeTMVar bufsig)+				`orElse`+			(Left <$> takeTMVar bufend)+		l <- takeMVar buf+		putMVar buf (OutputBuffer [])+		emitOutputBuffer outh l+		case change of+			Right BufSig -> displaybuf v+			Left AtEnd -> return ()+	globalbuf activitysig = do+		ok <- atomically $ do+			-- signal we're going to handle it+			-- (returns false if the displaybuf already did)+			ok <- tryPutTMVar activitysig ()+			-- wait for end of all buffers+			when ok $+				mapM_ (\(_outh, _buf, _bufsig, bufend) -> takeTMVar bufend) ts+			return ok+		when ok $ do+			-- add all of the command's buffered output to the+			-- global output buffer, atomically+			bs <- forM ts $ \(outh, buf, _bufsig, _bufend) ->+				(outh,) <$> takeMVar buf+			atomically $+				forM_ bs $ \(outh, b) -> +					bufferOutputSTM' outh b++-- Adds a value to the OutputBuffer. When adding Output to a Handle,+-- it's cheaper to combine it with any already buffered Output to that+-- same Handle.+--+-- When the total buffered Output exceeds 1 mb in size, it's moved out of+-- memory, to a temp file. This should only happen rarely, but is done to+-- avoid some verbose process unexpectedly causing excessive memory use.+addOutputBuffer :: OutputBufferedActivity -> OutputBuffer -> IO OutputBuffer+addOutputBuffer (Output t) (OutputBuffer buf)+	| T.length t' <= 1048576 = return $ OutputBuffer (Output t' : other)+	| otherwise = do+		tmpdir <- getTemporaryDirectory+		(tmp, h) <- openTempFile tmpdir "output.tmp"+		let !endnl = endsNewLine t'+		let i = InTempFile+			{ tempFile = tmp+			, endsInNewLine = endnl+			}+		T.hPutStr h t'+		hClose h+		return $ OutputBuffer (i : other)+  where+	!t' = T.concat (mapMaybe getOutput this) <> t+	!(this, other) = partition isOutput buf+	isOutput v = case v of+		Output _ -> True+		_ -> False+	getOutput v = case v of+		Output t'' -> Just t''+		_ -> Nothing+addOutputBuffer v (OutputBuffer buf) = return $ OutputBuffer (v:buf)++-- | Adds a value to the output buffer for later display.+--+-- Note that buffering large quantities of data this way will keep it+-- resident in memory until it can be displayed. While `outputConcurrent`+-- uses temp files if the buffer gets too big, this STM function cannot do+-- so.+bufferOutputSTM :: Outputable v => StdHandle -> v -> STM ()+bufferOutputSTM h v = bufferOutputSTM' h (OutputBuffer [Output (toOutput v)])++bufferOutputSTM' :: StdHandle -> OutputBuffer -> STM ()+bufferOutputSTM' h (OutputBuffer newbuf) = do+	(OutputBuffer buf) <- takeTMVar bv+	putTMVar bv (OutputBuffer (newbuf ++ buf))+  where+	bv = bufferFor h++-- | A STM action that waits for some buffered output to become+-- available, and returns it.+--+-- The function can select a subset of output when only some is desired;+-- the fst part is returned and the snd is left in the buffer.+--+-- This will prevent it from being displayed in the usual way, so you'll+-- need to use `emitOutputBuffer` to display it yourself.+outputBufferWaiterSTM :: (OutputBuffer -> (OutputBuffer, OutputBuffer)) -> STM (StdHandle, OutputBuffer)+outputBufferWaiterSTM selector = waitgetbuf StdOut `orElse` waitgetbuf StdErr+  where+	waitgetbuf h = do+		let bv = bufferFor h+		(selected, rest) <- selector <$> takeTMVar bv+		when (selected == OutputBuffer [])+			retry+		putTMVar bv rest+		return (h, selected)++waitAnyBuffer :: OutputBuffer -> (OutputBuffer, OutputBuffer)+waitAnyBuffer b = (b, OutputBuffer [])++-- | Use with `outputBufferWaiterSTM` to make it only return buffered+-- output that ends with a newline. Anything buffered without a newline+-- is left in the buffer.+waitCompleteLines :: OutputBuffer -> (OutputBuffer, OutputBuffer)+waitCompleteLines (OutputBuffer l) = +	let (selected, rest) = span completeline l+	in (OutputBuffer selected, OutputBuffer rest)+  where+	completeline (v@(InTempFile {})) = endsInNewLine v+	completeline (Output b) = endsNewLine b++endsNewLine :: T.Text -> Bool+endsNewLine t = not (T.null t) && T.last t == '\n'++-- | Emits the content of the OutputBuffer to the Handle+--+-- If you use this, you should use `lockOutput` to ensure you're the only+-- thread writing to the console.+emitOutputBuffer :: StdHandle -> OutputBuffer -> IO ()+emitOutputBuffer stdh (OutputBuffer l) = +	forM_ (reverse l) $ \ba -> case ba of+		Output t -> emit t+		InTempFile tmp _ -> do+			emit =<< T.readFile tmp+			void $ tryWhenExists $ removeFile tmp+  where+	outh = toHandle stdh+	emit t = void $ tryIO $ do+		T.hPutStr outh t+		hFlush outh

@@ -0,0 +1,34 @@+-- | +-- Copyright: 2015 Joey Hess <id@joeyh.name>+-- License: BSD-2-clause+-- +-- The functions exported by this module are intended to be drop-in+-- replacements for those from System.Process, when converting a whole+-- program to use System.Console.Concurrent.++module System.Process.Concurrent where++import System.Console.Concurrent+import System.Console.Concurrent.Internal (ConcurrentProcessHandle(..))+import System.Process hiding (createProcess, waitForProcess)+import System.IO+import System.Exit++-- | Calls `createProcessConcurrent`+--+-- You should use the waitForProcess in this module on the resulting+-- ProcessHandle. Using System.Process.waitForProcess instead can have+-- mildly unexpected results.+createProcess :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)+createProcess p = do+	(i, o, e, ConcurrentProcessHandle h) <- createProcessConcurrent p+	return (i, o, e, h)++-- | Calls `waitForProcessConcurrent`+--+-- You should only use this on a ProcessHandle obtained by calling+-- createProcess from this module. Using this with a ProcessHandle+-- obtained from System.Process.createProcess etc will have extremely+-- unexpected results; it can wait a very long time before returning.+waitForProcess :: ProcessHandle -> IO ExitCode+waitForProcess = waitForProcessConcurrent . ConcurrentProcessHandle

@@ -41,9 +41,12 @@ 	devNull, ) where -import qualified System.Process-import qualified System.Process as X hiding (CreateProcess(..), createProcess, runInteractiveProcess, readProcess, readProcessWithExitCode, system, rawSystem, runInteractiveCommand, runProcess)-import System.Process hiding (createProcess, readProcess, waitForProcess)+import qualified Utility.Process.Shim+import qualified Utility.Process.Shim as X hiding (CreateProcess(..), createProcess, runInteractiveProcess, readProcess, readProcessWithExitCode, system, rawSystem, runInteractiveCommand, runProcess)+import Utility.Process.Shim hiding (createProcess, readProcess, waitForProcess)+import Utility.Misc+import Utility.Exception+ import System.Exit import System.IO import System.Log.Logger@@ -58,9 +61,6 @@ import Data.Maybe import Prelude -import Utility.Misc-import Utility.Exception- type CreateProcessRunner = forall a. CreateProcess -> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO a) -> IO a  data StdHandle = StdinHandle | StdoutHandle | StderrHandle@@ -172,22 +172,21 @@ -- returns a transcript combining its stdout and stderr, and -- whether it succeeded or failed. processTranscript :: String -> [String] -> (Maybe String) -> IO (String, Bool)-processTranscript cmd opts = processTranscript' cmd opts Nothing+processTranscript = processTranscript' id -processTranscript' :: String -> [String] -> Maybe [(String, String)] -> (Maybe String) -> IO (String, Bool)-processTranscript' cmd opts environ input = do+processTranscript' :: (CreateProcess -> CreateProcess) -> String -> [String] -> Maybe String -> IO (String, Bool)+processTranscript' modproc cmd opts input = do #ifndef mingw32_HOST_OS {- This implementation interleves stdout and stderr in exactly the order  - the process writes them. -} 	(readf, writef) <- System.Posix.IO.createPipe 	readh <- System.Posix.IO.fdToHandle readf 	writeh <- System.Posix.IO.fdToHandle writef-	p@(_, _, _, pid) <- createProcess $+	p@(_, _, _, pid) <- createProcess $ modproc $ 		(proc cmd opts) 			{ std_in = if isJust input then CreatePipe else Inherit 			, std_out = UseHandle writeh 			, std_err = UseHandle writeh-			, env = environ 			} 	hClose writeh @@ -199,12 +198,11 @@ 	return (transcript, ok) #else {- This implementation for Windows puts stderr after stdout. -}-	p@(_, _, _, pid) <- createProcess $+	p@(_, _, _, pid) <- createProcess $ modproc $ 		(proc cmd opts) 			{ std_in = if isJust input then CreatePipe else Inherit 			, std_out = CreatePipe 			, std_err = CreatePipe-			, env = environ 			}  	getout <- mkreader (stdoutHandle p)@@ -374,7 +372,7 @@ createProcess :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) createProcess p = do 	debugProcess p-	System.Process.createProcess p+	Utility.Process.Shim.createProcess p  -- | Debugging trace for a CreateProcess. debugProcess :: CreateProcess -> IO ()@@ -394,6 +392,6 @@ -- | Wrapper around 'System.Process.waitForProcess' that does debug logging. waitForProcess ::  ProcessHandle -> IO ExitCode waitForProcess h = do-	r <- System.Process.waitForProcess h+	r <- Utility.Process.Shim.waitForProcess h 	debugM "Utility.Process" ("process done " ++ show r) 	return r

@@ -0,0 +1,4 @@+module Utility.Process.Shim (module X, createProcess, waitForProcess) where++import System.Process as X hiding (createProcess, waitForProcess)+import System.Process.Concurrent

@@ -50,7 +50,7 @@ netrepo = "https://github.com/joeyh/propellor.git"  main :: IO ()-main = do+main = withConcurrentOutput $ do 	args <- getArgs 	home <- myHomeDir 	let propellordir = home </> ".propellor"