summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorJoey Hess2015-11-01 11:30:36 -0400
committerJoey Hess2015-11-01 11:30:36 -0400
commit046d7d82b4b309ade5e3508817f1b9b684e57b94 (patch)
treeb1e6cc3f2d959c7726e3da0c67551927d6a321c8 /src
parent082bfc9f301adc59d7cd26954d8cdc0caf80ec7e (diff)
parentb218820da0b069e826507150cba118f0fa69d409 (diff)
Merge branch 'joeyconfig'
Diffstat (limited to 'src')
-rw-r--r--src/Propellor/Base.hs2
-rw-r--r--src/Propellor/Bootstrap.hs4
-rw-r--r--src/Propellor/CmdLine.hs2
-rw-r--r--src/Propellor/Debug.hs36
-rw-r--r--src/Propellor/Engine.hs34
-rw-r--r--src/Propellor/Message.hs195
-rw-r--r--src/Propellor/PrivData.hs22
-rw-r--r--src/Propellor/PropAccum.hs4
-rw-r--r--src/Propellor/Property.hs2
-rw-r--r--src/Propellor/Property/Apache.hs6
-rw-r--r--src/Propellor/Property/Apt.hs4
-rw-r--r--src/Propellor/Property/Chroot.hs8
-rw-r--r--src/Propellor/Property/Cmd.hs3
-rw-r--r--src/Propellor/Property/Concurrent.hs37
-rw-r--r--src/Propellor/Property/Conductor.hs6
-rw-r--r--src/Propellor/Property/Debootstrap.hs2
-rw-r--r--src/Propellor/Property/DiskImage.hs8
-rw-r--r--src/Propellor/Property/Dns.hs8
-rw-r--r--src/Propellor/Property/DnsSec.hs4
-rw-r--r--src/Propellor/Property/Docker.hs7
-rw-r--r--src/Propellor/Property/Git.hs2
-rw-r--r--src/Propellor/Property/Nginx.hs2
-rw-r--r--src/Propellor/Property/Prosody.hs2
-rw-r--r--src/Propellor/Property/SiteSpecific/JoeySites.hs6
-rw-r--r--src/Propellor/Property/Ssh.hs2
-rw-r--r--src/Propellor/Property/Systemd.hs22
-rw-r--r--src/Propellor/Property/Uwsgi.hs2
-rw-r--r--src/Propellor/Spin.hs2
-rw-r--r--src/Propellor/Types.hs130
-rw-r--r--src/Utility/ConcurrentOutput.hs348
-rw-r--r--src/Utility/Process.hs28
-rw-r--r--src/Utility/Process/Shim.hs12
-rw-r--r--src/wrapper.hs2
33 files changed, 720 insertions, 234 deletions
diff --git a/src/Propellor/Base.hs b/src/Propellor/Base.hs
index 3c13bb7d..2a0f5cbc 100644
--- a/src/Propellor/Base.hs
+++ b/src/Propellor/Base.hs
@@ -15,6 +15,7 @@ module Propellor.Base (
, module Propellor.Engine
, module Propellor.Exception
, module Propellor.Message
+ , module Propellor.Debug
, module Propellor.Location
, module Propellor.Utilities
@@ -39,6 +40,7 @@ import Propellor.Property.Cmd
import Propellor.PrivData
import Propellor.Types.PrivData
import Propellor.Message
+import Propellor.Debug
import Propellor.Exception
import Propellor.Info
import Propellor.PropAccum
diff --git a/src/Propellor/Bootstrap.hs b/src/Propellor/Bootstrap.hs
index 6a5d5acb..21772b34 100644
--- a/src/Propellor/Bootstrap.hs
+++ b/src/Propellor/Bootstrap.hs
@@ -65,7 +65,7 @@ depsCommand = "( " ++ intercalate " ; " (concat [osinstall, cabalinstall]) ++ "
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 @@ depsCommand = "( " ++ intercalate " ; " (concat [osinstall, cabalinstall]) ++ "
, "libghc-mtl-dev"
, "libghc-transformers-dev"
, "libghc-exceptions-dev"
+ , "libghc-stm-dev"
+ , "libghc-text-dev"
, "make"
]
diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs
index 9f798166..4bca3986 100644
--- a/src/Propellor/CmdLine.hs
+++ b/src/Propellor/CmdLine.hs
@@ -89,7 +89,7 @@ processCmdLine = go =<< getArgs
-- | 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
diff --git a/src/Propellor/Debug.hs b/src/Propellor/Debug.hs
new file mode 100644
index 00000000..ac4a56cc
--- /dev/null
+++ b/src/Propellor/Debug.hs
@@ -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]
diff --git a/src/Propellor/Engine.hs b/src/Propellor/Engine.hs
index a811724a..36a05b28 100644
--- a/src/Propellor/Engine.hs
+++ b/src/Propellor/Engine.hs
@@ -9,14 +9,12 @@ module Propellor.Engine (
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.Exception
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 -> IO ()
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
@@ -99,28 +92,3 @@ onlyProcess lockfile a = bracket lock unlock (const a)
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)
diff --git a/src/Propellor/Message.hs b/src/Propellor/Message.hs
index 94892da8..7df5104a 100644
--- a/src/Propellor/Message.hs
+++ b/src/Propellor/Message.hs
@@ -1,125 +1,148 @@
-{-# LANGUAGE PackageImports #-}
-
-module Propellor.Message where
+-- | 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 (
+ 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 Propellor.Types
+import Utility.ConcurrentOutput
+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"]
-
-enableDebugMode :: IO ()
-enableDebugMode = do
- f <- setFormatter
- <$> streamHandler stderr DEBUG
- <*> pure (simpleLogFormatter "[$time] $msg")
- updateGlobalLogger rootLoggerName $
- setLevel DEBUG . setHandlers [f]
+ 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)
+
+-- | Called when all messages about properties have been printed.
+messagesDone :: IO ()
+messagesDone = outputConcurrent
+ =<< whenConsole (setTitleCode "propellor: done")
diff --git a/src/Propellor/PrivData.hs b/src/Propellor/PrivData.hs
index aac37d14..e59f42c3 100644
--- a/src/Propellor/PrivData.hs
+++ b/src/Propellor/PrivData.hs
@@ -106,9 +106,9 @@ withPrivData' feed srclist c mkprop = addinfo $ mkprop $ \a ->
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 +121,14 @@ withPrivData' feed srclist c mkprop = addinfo $ mkprop $ \a ->
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))
@@ -207,7 +210,8 @@ listPrivDataFields hosts = do
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) =
diff --git a/src/Propellor/PropAccum.hs b/src/Propellor/PropAccum.hs
index 3c50cf32..85a30af5 100644
--- a/src/Propellor/PropAccum.hs
+++ b/src/Propellor/PropAccum.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE PackageImports #-}
+{-# LANGUAGE PackageImports, FlexibleContexts #-}
module Propellor.PropAccum
( host
@@ -46,7 +46,7 @@ class PropAccum h where
(&^) = 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 &
diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs
index d80d9c1f..e967cac9 100644
--- a/src/Propellor/Property.hs
+++ b/src/Propellor/Property.hs
@@ -201,7 +201,7 @@ withOS :: Desc -> (Maybe System -> Propellor Result) -> Property NoInfo
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
diff --git a/src/Propellor/Property/Apache.hs b/src/Propellor/Property/Apache.hs
index 91b2e6a2..c2f49cff 100644
--- a/src/Propellor/Property/Apache.hs
+++ b/src/Propellor/Property/Apache.hs
@@ -16,7 +16,7 @@ reloaded = Service.reloaded "apache2"
-- | 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 @@ virtualHost hn (Port p) docroot = siteEnabled hn
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 @@ siteAvailable hn cf = combineProperties ("apache site available " ++ hn) $
where
comment = "# deployed with propellor, do not modify"
-modEnabled :: String -> RevertableProperty
+modEnabled :: String -> RevertableProperty NoInfo
modEnabled modname = enable <!> disable
where
enable = check (not <$> isenabled) $
diff --git a/src/Propellor/Property/Apt.hs b/src/Propellor/Property/Apt.hs
index 14f170af..fd6230e8 100644
--- a/src/Propellor/Property/Apt.hs
+++ b/src/Propellor/Property/Apt.hs
@@ -212,7 +212,7 @@ autoRemove = runApt ["-y", "autoremove"]
`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 @@ data AptKey = AptKey
, pubkey :: String
}
-trustsKey :: AptKey -> RevertableProperty
+trustsKey :: AptKey -> RevertableProperty NoInfo
trustsKey k = trustsKey' k <!> untrustKey k
trustsKey' :: AptKey -> Property NoInfo
diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs
index 771c4b99..0c00e8f4 100644
--- a/src/Propellor/Property/Chroot.hs
+++ b/src/Propellor/Property/Chroot.hs
@@ -27,6 +27,7 @@ import qualified Propellor.Property.Systemd.Core as Systemd
import qualified Propellor.Property.File as File
import qualified Propellor.Shim as Shim
import Propellor.Property.Mount
+import Utility.ConcurrentOutput
import qualified Data.Map as M
import Data.List.Utils
@@ -116,10 +117,10 @@ bootstrapped bootstrapper location = Chroot location bootstrapper h
-- 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 @@ propellChroot c@(Chroot loc _ _) mkproc systemdonly = property (chrootDesc c "pr
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 @@ chain hostlist (ChrootChain hn loc systemdonly onconsole) =
then [Systemd.installed]
else map ignoreInfo $
hostProperties h
+ flushConcurrentOutput
putStrLn $ "\n" ++ show r
chain _ _ = errorMessage "bad chain command"
diff --git a/src/Propellor/Property/Cmd.hs b/src/Propellor/Property/Cmd.hs
index 23816a94..9536f71d 100644
--- a/src/Propellor/Property/Cmd.hs
+++ b/src/Propellor/Property/Cmd.hs
@@ -16,6 +16,7 @@ module Propellor.Property.Cmd (
safeSystemEnv,
shellEscape,
createProcess,
+ waitForProcess,
) where
import Control.Applicative
@@ -26,7 +27,7 @@ import Propellor.Types
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.
--
diff --git a/src/Propellor/Property/Concurrent.hs b/src/Propellor/Property/Concurrent.hs
index c57f5228..74afecc4 100644
--- a/src/Propellor/Property/Concurrent.hs
+++ b/src/Propellor/Property/Concurrent.hs
@@ -1,14 +1,38 @@
{-# LANGUAGE FlexibleContexts #-}
--- | Note that this module does not yet arrange for any output multiplexing,
--- so the output of concurrent properties will be scrambled together.
+-- | 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,
- withCapabilities,
concurrentSatisfy,
) where
@@ -20,6 +44,12 @@ 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
@@ -95,6 +125,7 @@ withCapabilities n a = bracket setup cleanup (const a)
return c
cleanup = liftIO . setNumCapabilities
+-- | Running Propellor actions concurrently.
concurrentSatisfy :: Propellor Result -> Propellor Result -> Propellor Result
concurrentSatisfy a1 a2 = do
h <- ask
diff --git a/src/Propellor/Property/Conductor.hs b/src/Propellor/Property/Conductor.hs
index ed46601d..0d275b91 100644
--- a/src/Propellor/Property/Conductor.hs
+++ b/src/Propellor/Property/Conductor.hs
@@ -83,7 +83,7 @@ import qualified Data.Set as S
-- | 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 @@ notConductorFor h = infoProperty desc (return NoChange) (addInfo mempty (NotCond
where
desc = "not " ++ cdesc (hostName h)
-conductorKnownHost :: Host -> RevertableProperty
+conductorKnownHost :: Host -> RevertableProperty NoInfo
conductorKnownHost h =
mk Ssh.knownHost
<!>
@@ -290,7 +290,7 @@ addConductorPrivData h hs = h { hostInfo = hostInfo h <> i }
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
diff --git a/src/Propellor/Property/Debootstrap.hs b/src/Propellor/Property/Debootstrap.hs
index f8981591..61912b32 100644
--- a/src/Propellor/Property/Debootstrap.hs
+++ b/src/Propellor/Property/Debootstrap.hs
@@ -98,7 +98,7 @@ extractSuite (System (Ubuntu r) _) = Just r
-- 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 ->
diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs
index 90d0bcc6..5b8619ba 100644
--- a/src/Propellor/Property/DiskImage.hs
+++ b/src/Propellor/Property/DiskImage.hs
@@ -69,16 +69,16 @@ type DiskImage = FilePath
-- 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 @@ imageBuilt' rebuild img mkchroot tabletype final partspec =
& 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
diff --git a/src/Propellor/Property/Dns.hs b/src/Propellor/Property/Dns.hs
index 4c2f787f..adc12930 100644
--- a/src/Propellor/Property/Dns.hs
+++ b/src/Propellor/Property/Dns.hs
@@ -60,7 +60,7 @@ import Data.List
--
-- 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 @@ cleanupPrimary zonefile domain = check (doesFileExist zonefile) $
-- 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)")
@@ -184,12 +184,12 @@ signedPrimary recurrance hosts domain soa rs = setup <!> cleanup
--
-- 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)
diff --git a/src/Propellor/Property/DnsSec.hs b/src/Propellor/Property/DnsSec.hs
index c0aa1302..1ba459e6 100644
--- a/src/Propellor/Property/DnsSec.hs
+++ b/src/Propellor/Property/DnsSec.hs
@@ -7,7 +7,7 @@ import qualified Propellor.Property.File as File
--
-- 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,7 +37,7 @@ keysInstalled domain = setup <!> cleanup
--
-- 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)
diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs
index 394c4271..f2dbaaf5 100644
--- a/src/Propellor/Property/Docker.hs
+++ b/src/Propellor/Property/Docker.hs
@@ -56,6 +56,7 @@ import qualified Propellor.Property.Cmd as Cmd
import qualified Propellor.Shim as Shim
import Utility.Path
import Utility.ThreadScheduler
+import Utility.ConcurrentOutput
import Control.Concurrent.Async hiding (link)
import System.Posix.Directory
@@ -123,7 +124,7 @@ container cn image = Container image (Host cn [] info)
--
-- 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 @@ init s = case toContainerId s of
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 :: ContainerId -> Property NoInfo
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 @@ chain hostlist hn s = case toContainerId s of
r <- runPropellor h $ ensureProperties $
map ignoreInfo $
hostProperties h
+ flushConcurrentOutput
putStrLn $ "\n" ++ show r
stopContainer :: ContainerId -> IO Bool
diff --git a/src/Propellor/Property/Git.hs b/src/Propellor/Property/Git.hs
index d69fe250..8937d21a 100644
--- a/src/Propellor/Property/Git.hs
+++ b/src/Propellor/Property/Git.hs
@@ -11,7 +11,7 @@ import Data.List
-- 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")
diff --git a/src/Propellor/Property/Nginx.hs b/src/Propellor/Property/Nginx.hs
index c9b4d8fd..c28dcc01 100644
--- a/src/Propellor/Property/Nginx.hs
+++ b/src/Propellor/Property/Nginx.hs
@@ -9,7 +9,7 @@ import qualified Propellor.Property.Service as Service
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
diff --git a/src/Propellor/Property/Prosody.hs b/src/Propellor/Property/Prosody.hs
index 0e379e63..f2d80ae4 100644
--- a/src/Propellor/Property/Prosody.hs
+++ b/src/Propellor/Property/Prosody.hs
@@ -11,7 +11,7 @@ type ConfigFile = [String]
type Conf = String
-confEnabled :: Conf -> ConfigFile -> RevertableProperty
+confEnabled :: Conf -> ConfigFile -> RevertableProperty NoInfo
confEnabled conf cf = enable <!> disable
where
enable = dir `File.isSymlinkedTo` target
diff --git a/src/Propellor/Property/SiteSpecific/JoeySites.hs b/src/Propellor/Property/SiteSpecific/JoeySites.hs
index 92903e9a..d6a50309 100644
--- a/src/Propellor/Property/SiteSpecific/JoeySites.hs
+++ b/src/Propellor/Property/SiteSpecific/JoeySites.hs
@@ -298,7 +298,7 @@ annexWebSite origin hn uuid remotes = propertyList (hn ++" website using git-ann
, " </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 @@ dkimInstalled = go `onChange` Service.restarted "opendkim"
-- 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,7 +921,7 @@ legacyWebSites = propertyList "legacy web sites" $ props
, "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` Apache.modEnabled "userdir"
diff --git a/src/Propellor/Property/Ssh.hs b/src/Propellor/Property/Ssh.hs
index 60121336..304ed5cc 100644
--- a/src/Propellor/Property/Ssh.hs
+++ b/src/Propellor/Property/Ssh.hs
@@ -115,7 +115,7 @@ dotFile f user = do
-- 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
diff --git a/src/Propellor/Property/Systemd.hs b/src/Propellor/Property/Systemd.hs
index 8761d842..42ff8e57 100644
--- a/src/Propellor/Property/Systemd.hs
+++ b/src/Propellor/Property/Systemd.hs
@@ -93,7 +93,7 @@ disabled n = trivial $ cmdProperty "systemctl" ["disable", n]
`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 @@ container name system mkchroot = Container name c h
--
-- 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 @@ nspawned c@(Container name (Chroot.Chroot loc builder _) h) =
-- | 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 @@ nspawnServiceParams (SystemdNspawnCfg ps) =
--
-- 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 @@ mungename = replace "/" "_"
-- 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 @@ containerCfg p = RevertableProperty (mk True) (mk False)
-- | 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 @@ instance Publishable (Proto, Bound Port) where
-- > & 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 @@ instance Bindable (Bound FilePath) where
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
diff --git a/src/Propellor/Property/Uwsgi.hs b/src/Propellor/Property/Uwsgi.hs
index 7de1a85a..9748f16d 100644
--- a/src/Propellor/Property/Uwsgi.hs
+++ b/src/Propellor/Property/Uwsgi.hs
@@ -11,7 +11,7 @@ type ConfigFile = [String]
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
diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs
index 0c457705..478d1517 100644
--- a/src/Propellor/Spin.hs
+++ b/src/Propellor/Spin.hs
@@ -29,6 +29,7 @@ import Propellor.Types.Info
import qualified Propellor.Shim as Shim
import Utility.FileMode
import Utility.SafeCommand
+import Utility.ConcurrentOutput
commitSpin :: IO ()
commitSpin = do
@@ -63,6 +64,7 @@ spin' mprivdata relay target hst = do
getprivdata
-- And now we can run it.
+ flushConcurrentOutput
unlessM (boolSystem "ssh" (map Param $ cacheparams ++ ["-t", sshtarget, shellWrap runcmd])) $
error "remote propellor failed"
where
diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs
index 06f0935d..fa24786c 100644
--- a/src/Propellor/Types.hs
+++ b/src/Propellor/Types.hs
@@ -156,12 +156,6 @@ propertySatisfy :: Property i -> Propellor Result
propertySatisfy (IProperty _ a _ _) = a
propertySatisfy (SProperty _ a _) = a
-instance Show (Property i) where
- show p = "property " ++ show (propertyDesc p)
-
-instance Show RevertableProperty where
- show (RevertableProperty 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
@@ -175,6 +169,9 @@ propertyDesc :: Property i -> Desc
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]
@@ -183,11 +180,23 @@ propertyChildren (SProperty _ _ cs) = cs
-- | 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)
+
+instance Show (RevertableProperty i) where
+ show (RevertableProperty p _) = show p
--- | Shorthand to construct a revertable property.
-(<!>) :: Property i1 -> Property i2 -> RevertableProperty
-p1 <!> p2 = RevertableProperty (toIProperty p1) (toIProperty p2)
+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
@@ -210,35 +219,43 @@ instance IsProp (Property NoInfo) where
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 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 (Property NoInfo) = Property HasInfo
-type instance CombinedType RevertableProperty (Property HasInfo) = Property HasInfo
-type instance CombinedType (Property NoInfo) RevertableProperty = Property HasInfo
-type instance CombinedType (Property HasInfo) RevertableProperty = Property HasInfo
+type instance CombinedType (RevertableProperty x) (Property y) = Property (CInfo x y)
+type instance CombinedType (Property x) (RevertableProperty y) = Property (CInfo x y)
+
+type ResultCombiner = Propellor Result -> Propellor Result -> Propellor Result
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
- :: (Propellor Result -> Propellor Result -> Propellor Result)
+ :: ResultCombiner
-- ^ How to combine the actions to satisfy the properties.
- -> (Propellor Result -> Propellor Result -> Propellor Result)
+ -> ResultCombiner
-- ^ Used when combining revertable properties, to combine
-- their reversion actions.
-> x
@@ -261,20 +278,57 @@ instance Combines (Property NoInfo) (Property NoInfo) where
combineWith f _ (SProperty d1 a1 cs1) y@(SProperty _d2 a2 _cs2) =
SProperty d1 (f a1 a2) (y : cs1)
-instance Combines RevertableProperty RevertableProperty where
- combineWith sf tf (RevertableProperty s1 t1) (RevertableProperty s2 t2) =
- RevertableProperty
- (combineWith sf tf s1 s2)
- (combineWith tf sf t1 t2)
-
-instance Combines RevertableProperty (Property HasInfo) where
- combineWith sf tf (RevertableProperty x _) y = combineWith sf tf x y
-
-instance Combines RevertableProperty (Property NoInfo) where
- combineWith sf tf (RevertableProperty x _) y = combineWith sf tf x y
-
-instance Combines (Property HasInfo) RevertableProperty where
- combineWith sf tf x (RevertableProperty y _) = combineWith sf tf x y
-
-instance Combines (Property NoInfo) RevertableProperty where
- combineWith sf tf x (RevertableProperty y _) = combineWith sf tf x y
+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
+
+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)
+
+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
diff --git a/src/Utility/ConcurrentOutput.hs b/src/Utility/ConcurrentOutput.hs
new file mode 100644
index 00000000..c24744a3
--- /dev/null
+++ b/src/Utility/ConcurrentOutput.hs
@@ -0,0 +1,348 @@
+{-# LANGUAGE BangPatterns, TypeSynonymInstances, FlexibleInstances #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+
+-- |
+-- Copyright: 2013 Joey Hess <id@joeyh.name>
+-- License: BSD-2-clause
+--
+-- Concurrent output handling.
+--
+-- > import Control.Concurrent.Async
+-- > import Control.Concurrent.Output
+-- >
+-- > main = withConcurrentOutput $
+-- > outputConcurrent "washed the car\n"
+-- > `concurrently`
+-- > outputConcurrent "walked the dog\n"
+-- > `concurrently`
+-- > createProcessConcurrent (proc "ls" [])
+
+module Utility.ConcurrentOutput (
+ withConcurrentOutput,
+ flushConcurrentOutput,
+ Outputable(..),
+ outputConcurrent,
+ createProcessConcurrent,
+ waitForProcessConcurrent,
+ lockOutput,
+) where
+
+import System.IO
+import System.Posix.IO
+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.Set as S
+import qualified Data.ByteString as B
+import qualified Data.Text as T
+import Data.Text.Encoding (encodeUtf8)
+
+import Utility.Monad
+import Utility.Exception
+
+data OutputHandle = OutputHandle
+ { outputLock :: TMVar Lock
+ , outputBuffer :: TMVar Buffer
+ , outputThreads :: TMVar (S.Set (Async ()))
+ }
+
+data Lock = Locked
+
+-- | A shared global variable for the OutputHandle.
+{-# NOINLINE globalOutputHandle #-}
+globalOutputHandle :: MVar OutputHandle
+globalOutputHandle = unsafePerformIO $
+ newMVar =<< OutputHandle
+ <$> newEmptyTMVarIO
+ <*> newTMVarIO []
+ <*> newTMVarIO S.empty
+
+-- | Gets the global OutputHandle.
+getOutputHandle :: IO OutputHandle
+getOutputHandle = readMVar globalOutputHandle
+
+-- | Holds a lock while performing an action that will display output.
+-- While this is running, other threads that try to lockOutput will block,
+-- and calls to `outputConcurrent` and `createProcessConcurrent`
+-- will result in that concurrent output being buffered and not
+-- displayed until 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 = do
+ lck <- outputLock <$> getOutputHandle
+ atomically (a lck)
+
+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
+ bv <- outputBuffer <$> getOutputHandle
+ buf <- atomically $ swapTMVar bv []
+ emitBuffer stdout buf
+ return locked
+
+-- | Only safe to call after taking the output lock.
+dropOutputLock :: IO ()
+dropOutputLock = withLock $ void . takeTMVar
+
+-- | Use this around any IO actions that use `outputConcurrent`
+-- or `createProcessConcurrent`
+--
+-- This is necessary to ensure that buffered concurrent output actually
+-- gets displayed before the program exits.
+withConcurrentOutput :: IO a -> IO a
+withConcurrentOutput a = a `finally` flushConcurrentOutput
+
+-- | Blocks until any processes started by `createProcessConcurrent` have
+-- finished, and any buffered output is displayed.
+flushConcurrentOutput :: IO ()
+flushConcurrentOutput = do
+ -- Wait for all outputThreads to finish.
+ v <- outputThreads <$> getOutputHandle
+ atomically $ do
+ r <- takeTMVar v
+ if r == S.empty
+ 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 -> B.ByteString
+
+instance Outputable B.ByteString where
+ toOutput = id
+
+instance Outputable T.Text where
+ toOutput = encodeUtf8
+
+instance Outputable String where
+ toOutput = toOutput . T.pack
+
+-- | Displays a value to stdout, and flush output so it's displayed.
+--
+-- 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 v = bracket setup cleanup go
+ where
+ setup = tryTakeOutputLock
+ cleanup False = return ()
+ cleanup True = dropOutputLock
+ go True = do
+ B.hPut stdout (toOutput v)
+ hFlush stdout
+ go False = do
+ bv <- outputBuffer <$> getOutputHandle
+ oldbuf <- atomically $ takeTMVar bv
+ newbuf <- addBuffer (Output (toOutput v)) oldbuf
+ atomically $ putTMVar bv newbuf
+
+-- | This must be used to wait for processes started with
+-- `createProcessConcurrent`.
+--
+-- This is necessary because `System.Process.waitForProcess` has a
+-- race condition when two threads check the same process. If the race
+-- is triggered, one thread will successfully wait, but the other
+-- throws a DoesNotExist exception.
+waitForProcessConcurrent :: P.ProcessHandle -> IO ExitCode
+waitForProcessConcurrent h = do
+ v <- tryWhenExists (P.waitForProcess h)
+ case v of
+ Just r -> return r
+ Nothing -> maybe (waitForProcessConcurrent h) return =<< P.getProcessExitCode h
+
+-- | 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 (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.
+createProcessConcurrent :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, P.ProcessHandle)
+createProcessConcurrent p
+ | willOutput (P.std_out p) || willOutput (P.std_err p) =
+ ifM tryTakeOutputLock
+ ( firstprocess
+ , concurrentprocess
+ )
+ | otherwise = P.createProcess p
+ where
+ rediroutput ss h
+ | willOutput ss = P.UseHandle h
+ | otherwise = ss
+
+ firstprocess = do
+ r@(_, _, _, h) <- P.createProcess p
+ `onException` dropOutputLock
+ -- Wait for the process to exit and drop the lock.
+ void $ async $ do
+ void $ tryIO $ waitForProcessConcurrent h
+ dropOutputLock
+ return r
+
+ concurrentprocess = 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
+ }
+ r <- P.createProcess p'
+ outbuf <- setupBuffer stdout toouth (P.std_out p) fromouth
+ errbuf <- setupBuffer stderr toerrh (P.std_err p) fromerrh
+ void $ async $ bufferWriter [outbuf, errbuf]
+ return r
+
+ pipe = do
+ (from, to) <- createPipe
+ (,) <$> fdToHandle to <*> fdToHandle from
+
+willOutput :: P.StdStream -> Bool
+willOutput P.Inherit = True
+willOutput _ = False
+
+-- Built up with newest seen output first.
+type Buffer = [BufferedActivity]
+
+data BufferedActivity
+ = ReachedEnd
+ | Output B.ByteString
+ | InTempFile FilePath
+ deriving (Eq)
+
+setupBuffer :: Handle -> Handle -> P.StdStream -> Handle -> IO (Handle, MVar Buffer, TMVar ())
+setupBuffer h toh ss fromh = do
+ hClose toh
+ buf <- newMVar []
+ bufsig <- atomically newEmptyTMVar
+ void $ async $ outputDrainer ss fromh buf bufsig
+ return (h, buf, bufsig)
+
+-- Drain output from the handle, and buffer it.
+outputDrainer :: P.StdStream -> Handle -> MVar Buffer -> TMVar () -> IO ()
+outputDrainer ss fromh buf bufsig
+ | willOutput ss = go
+ | otherwise = atend
+ where
+ go = do
+ v <- tryIO $ B.hGetSome fromh 1048576
+ case v of
+ Right b | not (B.null b) -> do
+ modifyMVar_ buf $ addBuffer (Output b)
+ changed
+ go
+ _ -> atend
+ atend = do
+ modifyMVar_ buf $ pure . (ReachedEnd :)
+ changed
+ hClose fromh
+ changed = atomically $ do
+ void $ tryTakeTMVar bufsig
+ putTMVar bufsig ()
+
+-- Wait to lock output, and once we can, display everything
+-- that's put into the buffers, until the end.
+bufferWriter :: [(Handle, MVar Buffer, TMVar ())] -> IO ()
+bufferWriter ts = do
+ worker <- async $ void $ lockOutput $ mapConcurrently go ts
+ v <- outputThreads <$> getOutputHandle
+ atomically $ do
+ s <- takeTMVar v
+ putTMVar v (S.insert worker s)
+ void $ async $ do
+ void $ waitCatch worker
+ atomically $ do
+ s <- takeTMVar v
+ putTMVar v (S.delete worker s)
+ where
+ go v@(outh, buf, bufsig) = do
+ void $ atomically $ takeTMVar bufsig
+ l <- takeMVar buf
+ putMVar buf []
+ emitBuffer outh l
+ if any (== ReachedEnd) l
+ then return ()
+ else go v
+
+emitBuffer :: Handle -> Buffer -> IO ()
+emitBuffer outh l = forM_ (reverse l) $ \ba -> case ba of
+ Output b -> do
+ B.hPut outh b
+ hFlush outh
+ InTempFile tmp -> do
+ B.hPut outh =<< B.readFile tmp
+ void $ tryWhenExists $ removeFile tmp
+ ReachedEnd -> return ()
+
+-- Adds a value to the Buffer. 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.
+addBuffer :: BufferedActivity -> Buffer -> IO Buffer
+addBuffer (Output b) buf
+ | B.length b' <= 1048576 = return (Output b' : other)
+ | otherwise = do
+ tmpdir <- getTemporaryDirectory
+ (tmp, h) <- openTempFile tmpdir "output.tmp"
+ B.hPut h b'
+ hClose h
+ return (InTempFile tmp : other)
+ where
+ !b' = B.concat (mapMaybe getOutput this) <> b
+ !(this, other) = partition isOutput buf
+ isOutput v = case v of
+ Output _ -> True
+ _ -> False
+ getOutput v = case v of
+ Output b'' -> Just b''
+ _ -> Nothing
+addBuffer v buf = return (v:buf)
diff --git a/src/Utility/Process.hs b/src/Utility/Process.hs
index c4882a01..c6699961e 100644
--- a/src/Utility/Process.hs
+++ b/src/Utility/Process.hs
@@ -41,9 +41,12 @@ module Utility.Process (
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 Control.Applicative
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 @@ createBackgroundProcess p a = a =<< createProcess p
-- 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 @@ processTranscript' cmd opts environ input = do
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 @@ startInteractiveProcess cmd args environ = do
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 @@ debugProcess p = debugM "Utility.Process" $ unwords
-- | 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
diff --git a/src/Utility/Process/Shim.hs b/src/Utility/Process/Shim.hs
new file mode 100644
index 00000000..08694d5d
--- /dev/null
+++ b/src/Utility/Process/Shim.hs
@@ -0,0 +1,12 @@
+module Utility.Process.Shim (module X, createProcess, waitForProcess) where
+
+import System.Process as X hiding (createProcess, waitForProcess)
+import Utility.ConcurrentOutput (createProcessConcurrent, waitForProcessConcurrent)
+import System.IO
+import System.Exit
+
+createProcess :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
+createProcess = createProcessConcurrent
+
+waitForProcess :: ProcessHandle -> IO ExitCode
+waitForProcess = waitForProcessConcurrent
diff --git a/src/wrapper.hs b/src/wrapper.hs
index e367fe69..0cfe319d 100644
--- a/src/wrapper.hs
+++ b/src/wrapper.hs
@@ -50,7 +50,7 @@ netrepo :: String
netrepo = "https://github.com/joeyh/propellor.git"
main :: IO ()
-main = do
+main = withConcurrentOutput $ do
args <- getArgs
home <- myHomeDir
let propellordir = home </> ".propellor"