From 56c3394144abbb9862dc67379d3253c76ae4df97 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Tue, 27 Oct 2015 14:34:10 -0400
Subject: Explicit Info/NoInfo for RevertableProperty (API change)
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

RevertableProperty used to be assumed to contain info, but this is now made
explicit, with RevertableProperty HasInfo or RevertableProperty NoInfo.

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
---
 src/Propellor/Property/Apache.hs                 |  6 +++---
 src/Propellor/Property/Apt.hs                    |  4 ++--
 src/Propellor/Property/Chroot.hs                 |  4 ++--
 src/Propellor/Property/Conductor.hs              |  6 +++---
 src/Propellor/Property/Debootstrap.hs            |  2 +-
 src/Propellor/Property/DiskImage.hs              |  8 ++++----
 src/Propellor/Property/Dns.hs                    |  8 ++++----
 src/Propellor/Property/DnsSec.hs                 |  4 ++--
 src/Propellor/Property/Docker.hs                 |  2 +-
 src/Propellor/Property/Git.hs                    |  2 +-
 src/Propellor/Property/Nginx.hs                  |  2 +-
 src/Propellor/Property/Prosody.hs                |  2 +-
 src/Propellor/Property/SiteSpecific/JoeySites.hs |  4 ++--
 src/Propellor/Property/Ssh.hs                    |  2 +-
 src/Propellor/Property/Systemd.hs                | 22 +++++++++++-----------
 src/Propellor/Property/Uwsgi.hs                  |  2 +-
 16 files changed, 40 insertions(+), 40 deletions(-)

(limited to 'src/Propellor/Property')

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..20871a12 100644
--- a/src/Propellor/Property/Chroot.hs
+++ b/src/Propellor/Property/Chroot.hs
@@ -116,10 +116,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])
 		<!>
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..2b0e7e7e 100644
--- a/src/Propellor/Property/Docker.hs
+++ b/src/Propellor/Property/Docker.hs
@@ -123,7 +123,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))
 		<!>
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..d6db6813 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
@@ -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
-- 
cgit v1.3-2-g0d8e


From 6e3b0022fa451181fdce8abd145e27a64a777711 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Tue, 27 Oct 2015 16:19:15 -0400
Subject: use a shared global for the MessageHandle

---
 src/Propellor/Engine.hs          |  3 +-
 src/Propellor/Message.hs         | 69 +++++++++++++++++++---------------------
 src/Propellor/Property/Chroot.hs |  2 +-
 src/Propellor/Property/Docker.hs |  2 +-
 4 files changed, 36 insertions(+), 40 deletions(-)

(limited to 'src/Propellor/Property')

diff --git a/src/Propellor/Engine.hs b/src/Propellor/Engine.hs
index a811724a..f0bcdac8 100644
--- a/src/Propellor/Engine.hs
+++ b/src/Propellor/Engine.hs
@@ -38,8 +38,7 @@ mainProperties :: Host -> IO ()
 mainProperties host = do
 	ret <- runPropellor host $
 		ensureProperties [ignoreInfo $ infoProperty "overall" (ensureProperties ps) mempty mempty]
-	h <- mkMessageHandle
-        whenConsole h $
+        whenConsole $
 		setTitle "propellor: done"
 	hFlush stdout
 	case ret of
diff --git a/src/Propellor/Message.hs b/src/Propellor/Message.hs
index 94892da8..9c6cb57c 100644
--- a/src/Propellor/Message.hs
+++ b/src/Propellor/Message.hs
@@ -9,10 +9,11 @@ import System.Log.Formatter
 import System.Log.Handler (setFormatter)
 import System.Log.Handler.Simple
 import "mtl" Control.Monad.Reader
-import Data.Maybe
 import Control.Applicative
 import System.Directory
 import Control.Monad.IfElse
+import System.IO.Unsafe (unsafePerformIO)
+import Control.Concurrent
 
 import Propellor.Types
 import Utility.Monad
@@ -20,27 +21,26 @@ 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 $ do
+	c <- hIsTerminalDevice stdout
+	newMVar $ MessageHandle c
 
-forceConsole :: IO ()
-forceConsole = void $ setEnv "PROPELLOR_CONSOLE" "1" True
+getMessageHandle :: IO MessageHandle
+getMessageHandle = readMVar globalMessageHandle
 
-isConsole :: MessageHandle -> Bool
-isConsole ConsoleMessageHandle = True
-isConsole _ = False
+forceConsole :: IO ()
+forceConsole = modifyMVar_ globalMessageHandle $ \mh ->
+	pure (mh { isConsole = True })
 
-whenConsole :: MessageHandle -> IO () -> IO ()
-whenConsole ConsoleMessageHandle a = a
-whenConsole _ _ = return ()
+whenConsole :: IO () -> IO ()
+whenConsole a = whenM (isConsole <$> getMessageHandle) a
 
 -- | Shows a message while performing an action, with a colored status
 -- display.
@@ -54,49 +54,46 @@ actionMessageOn = actionMessage' . Just
 
 actionMessage' :: (MonadIO m, ActionResult r) => Maybe HostName -> Desc -> m r -> m r
 actionMessage' mhn desc a = do
-	h <- liftIO mkMessageHandle
-	liftIO $ whenConsole h $ do
+	liftIO $ whenConsole $ do
 		setTitle $ "propellor: " ++ desc
 		hFlush stdout
 
 	r <- a
 
 	liftIO $ do
-		whenConsole h $
+		whenConsole $
 			setTitle "propellor: running"
-		showhn h mhn
+		showhn mhn
 		putStr $ desc ++ " ... "
 		let (msg, intensity, color) = getActionResult r
-		colorLine h intensity color msg
+		colorLine intensity color msg
 		hFlush stdout
 
 	return r
   where
-	showhn _ Nothing = return ()
-	showhn h (Just hn) = do
-		whenConsole h $
+	showhn Nothing = return ()
+	showhn (Just hn) = do
+		whenConsole $
 			setSGR [SetColor Foreground Dull Cyan]
 		putStr (hn ++ " ")
-		whenConsole h $
+		whenConsole $
 			setSGR []
 
 warningMessage :: MonadIO m => String -> m ()
-warningMessage s = liftIO $ do
-	h <- mkMessageHandle
-	colorLine h Vivid Magenta $ "** warning: " ++ s
+warningMessage s = liftIO $
+	colorLine Vivid Magenta $ "** warning: " ++ s
 
 errorMessage :: MonadIO m => String -> m a
 errorMessage s = liftIO $ do
-	h <- mkMessageHandle
-	colorLine h Vivid Red $ "** error: " ++ s
+	colorLine Vivid Red $ "** error: " ++ s
 	error "Cannot continue!"
 
-colorLine :: MessageHandle -> ColorIntensity -> Color -> String -> IO ()
-colorLine h intensity color msg = do
-	whenConsole h $
+colorLine :: ColorIntensity -> Color -> String -> IO ()
+colorLine intensity color msg = do
+	whenConsole $
 		setSGR [SetColor Foreground intensity color]
 	putStr msg
-	whenConsole h $
+	whenConsole $
 		setSGR []
 	-- Note this comes after the color is reset, so that
 	-- the color set and reset happen in the same line.
diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs
index 20871a12..8b923aab 100644
--- a/src/Propellor/Property/Chroot.hs
+++ b/src/Propellor/Property/Chroot.hs
@@ -193,7 +193,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 ()
diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs
index 2b0e7e7e..5f41209a 100644
--- a/src/Propellor/Property/Docker.hs
+++ b/src/Propellor/Property/Docker.hs
@@ -555,7 +555,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)
-- 
cgit v1.3-2-g0d8e


From 20b04d366b2cff90c39d06fd424ae3e8b67e49f6 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Tue, 27 Oct 2015 17:02:23 -0400
Subject: make Propellor.Message use lock to handle concurrent threads
 outputting messages

Not yet handled: Output from concurrent programs.
---
 debian/changelog                     |  2 +-
 src/Propellor/Engine.hs              | 33 +------------
 src/Propellor/Message.hs             | 92 ++++++++++++++++++++++++++++++++----
 src/Propellor/PrivData.hs            | 22 +++++----
 src/Propellor/Property/Concurrent.hs |  4 +-
 5 files changed, 100 insertions(+), 53 deletions(-)

(limited to 'src/Propellor/Property')

diff --git a/debian/changelog b/debian/changelog
index 6b3f6940..1699b27b 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -18,7 +18,7 @@ propellor (2.13.0) UNRELEASED; urgency=medium
   * combineWith now takes an additional parameter to control how revert
     actions are combined (API change).
   * Added Propellor.Property.Concurrent for concurrent properties.
-    (Note that no output multiplexing is currently done.)
+    (Note that no command output multiplexing is currently done.)
   * Add File.isCopyOf. Thanks, Per Olofsson.
 
  -- Joey Hess <id@joeyh.name>  Sat, 24 Oct 2015 15:16:45 -0400
diff --git a/src/Propellor/Engine.hs b/src/Propellor/Engine.hs
index f0bcdac8..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,9 +34,7 @@ mainProperties :: Host -> IO ()
 mainProperties host = do
 	ret <- runPropellor host $
 		ensureProperties [ignoreInfo $ infoProperty "overall" (ensureProperties ps) mempty mempty]
-        whenConsole $
-		setTitle "propellor: done"
-	hFlush stdout
+	messagesDone
 	case ret of
 		FailedChange -> exitWith (ExitFailure 1)
 		_ -> exitWith ExitSuccess
@@ -98,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 9c6cb57c..0961a356 100644
--- a/src/Propellor/Message.hs
+++ b/src/Propellor/Message.hs
@@ -1,6 +1,26 @@
 {-# 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,
+	debug,
+	checkDebugMode,
+	enableDebugMode,
+	processChainOutput,
+	messagesDone,
+) where
 
 import System.Console.ANSI
 import System.IO
@@ -16,6 +36,7 @@ import System.IO.Unsafe (unsafePerformIO)
 import Control.Concurrent
 
 import Propellor.Types
+import Utility.PartialPrelude
 import Utility.Monad
 import Utility.Env
 import Utility.Process
@@ -23,6 +44,7 @@ import Utility.Exception
 
 data MessageHandle = MessageHandle
 	{ isConsole :: Bool
+	, outputLock :: MVar ()
 	}
 
 -- | A shared global variable for the MessageHandle.
@@ -30,30 +52,44 @@ data MessageHandle = MessageHandle
 globalMessageHandle :: MVar MessageHandle
 globalMessageHandle = unsafePerformIO $ do
 	c <- hIsTerminalDevice stdout
-	newMVar $ MessageHandle c
+	o <- newMVar ()
+	newMVar $ MessageHandle c o
 
+-- | Gets the global MessageHandle.
 getMessageHandle :: IO MessageHandle
 getMessageHandle = readMVar globalMessageHandle
 
+-- | Takes a lock while performing an action. Any other threads
+-- that try to lockOutput at the same time will block.
+lockOutput :: (MonadIO m, MonadMask m) => m a -> m a
+lockOutput a = do
+	lck <- liftIO $ outputLock <$> getMessageHandle
+	bracket_ (liftIO $ takeMVar lck) (liftIO $ putMVar lck ()) a
+
+-- | 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 })
 
+-- | Only performs the action when at the console, or when console
+-- output has been forced.
 whenConsole :: IO () -> IO ()
 whenConsole a = whenM (isConsole <$> getMessageHandle) a
 
 -- | 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' mhn desc a = do
+actionMessage' :: (MonadIO m, MonadMask m, ActionResult r) => Maybe HostName -> Desc -> m r -> m r
+actionMessage' mhn desc a = lockOutput $ do
 	liftIO $ whenConsole $ do
 		setTitle $ "propellor: " ++ desc
 		hFlush stdout
@@ -80,14 +116,18 @@ actionMessage' mhn desc a = do
 			setSGR []
 
 warningMessage :: MonadIO m => String -> m ()
-warningMessage s = liftIO $
+warningMessage s = liftIO $ lockOutput $
 	colorLine Vivid Magenta $ "** warning: " ++ s
 
+infoMessage :: MonadIO m => [String] -> m ()
+infoMessage ls = liftIO $ lockOutput $
+	mapM_ putStrLn ls
+
 errorMessage :: MonadIO m => String -> m a
-errorMessage s = liftIO $ do
+errorMessage s = liftIO $ lockOutput $ do
 	colorLine Vivid Red $ "** error: " ++ s
 	error "Cannot continue!"
-
+ 
 colorLine :: ColorIntensity -> Color -> String -> IO ()
 colorLine intensity color msg = do
 	whenConsole $
@@ -120,3 +160,37 @@ enableDebugMode = do
 		<*> pure (simpleLogFormatter "[$time] $msg")
 	updateGlobalLogger rootLoggerName $ 
 		setLevel DEBUG .  setHandlers [f]
+
+-- | 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"]
+						lockOutput $ do
+							putStrLn l
+							hFlush stdout
+						return FailedChange
+			Just s -> do
+				lockOutput $ do
+					maybe noop (\l -> unless (null l) (putStrLn l)) lastline
+					hFlush stdout
+				go (Just s)
+
+-- | Called when all messages about properties have been printed.
+messagesDone :: IO ()
+messagesDone = lockOutput $ do
+	whenConsole $
+		setTitle "propellor: done"
+	hFlush stdout
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/Property/Concurrent.hs b/src/Propellor/Property/Concurrent.hs
index c57f5228..645a5dfd 100644
--- a/src/Propellor/Property/Concurrent.hs
+++ b/src/Propellor/Property/Concurrent.hs
@@ -1,7 +1,7 @@
 {-# LANGUAGE FlexibleContexts #-}
 
--- | Note that this module does not yet arrange for any output multiplexing,
--- so the output of concurrent properties will be scrambled together.
+-- | Note that any output of commands run by
+-- concurrent properties will be scrambled together.
 
 module Propellor.Property.Concurrent (
 	concurrently,
-- 
cgit v1.3-2-g0d8e


From 51b397d0415e1efe1df412842ccb76d702140f50 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Tue, 27 Oct 2015 23:19:41 -0400
Subject: concurrent version of createProcess

Have not yet wired everything up to use this, that currently uses
Utility.Process.
---
 src/Propellor/Message.hs      | 213 +++++++++++++++++++++++++++++++++++++++---
 src/Propellor/Property/Cmd.hs |   1 +
 2 files changed, 201 insertions(+), 13 deletions(-)

(limited to 'src/Propellor/Property')

diff --git a/src/Propellor/Message.hs b/src/Propellor/Message.hs
index 0961a356..afe551cf 100644
--- a/src/Propellor/Message.hs
+++ b/src/Propellor/Message.hs
@@ -20,10 +20,12 @@ module Propellor.Message (
 	enableDebugMode,
 	processChainOutput,
 	messagesDone,
+	createProcess,
 ) where
 
 import System.Console.ANSI
 import System.IO
+import System.Posix.IO
 import System.Log.Logger
 import System.Log.Formatter
 import System.Log.Handler (setFormatter)
@@ -34,26 +36,38 @@ import System.Directory
 import Control.Monad.IfElse
 import System.IO.Unsafe (unsafePerformIO)
 import Control.Concurrent
+import Control.Concurrent.Async
+import Data.Maybe
+import Data.Char
+import Data.List
+import Data.Monoid
+import qualified Data.ByteString as B
 
 import Propellor.Types
 import Utility.PartialPrelude
 import Utility.Monad
 import Utility.Env
-import Utility.Process
 import Utility.Exception
+import qualified Utility.Process as P
 
 data MessageHandle = MessageHandle
 	{ isConsole :: Bool
-	, outputLock :: MVar ()
+	, outputLock :: MVar () -- ^ empty when locked
+	, outputLockedBy :: MVar Locker
 	}
 
+data Locker
+	= GeneralLock
+	| ProcessLock P.ProcessHandle
+
 -- | A shared global variable for the MessageHandle.
 {-# NOINLINE globalMessageHandle #-}
 globalMessageHandle :: MVar MessageHandle
-globalMessageHandle = unsafePerformIO $ do
-	c <- hIsTerminalDevice stdout
-	o <- newMVar ()
-	newMVar $ MessageHandle c o
+globalMessageHandle = unsafePerformIO $ 
+	newMVar =<< MessageHandle
+		<$> hIsTerminalDevice stdout
+		<*> newMVar ()
+		<*> newEmptyMVar
 
 -- | Gets the global MessageHandle.
 getMessageHandle :: IO MessageHandle
@@ -62,9 +76,71 @@ getMessageHandle = readMVar globalMessageHandle
 -- | Takes a lock while performing an action. Any other threads
 -- that try to lockOutput at the same time will block.
 lockOutput :: (MonadIO m, MonadMask m) => m a -> m a
-lockOutput a = do
-	lck <- liftIO $ outputLock <$> getMessageHandle
-	bracket_ (liftIO $ takeMVar lck) (liftIO $ putMVar lck ()) 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
+
+takeOutputLock' :: Bool -> IO Bool
+takeOutputLock' block = do 
+	lck <- outputLock <$> getMessageHandle
+	go =<< tryTakeMVar lck
+  where
+	-- lck was full, and we've emptied it, so we hold the lock now.
+	go (Just ()) = havelock
+	-- lck is empty, so someone else is holding the lock.
+	go Nothing = do
+		lcker <- outputLockedBy <$> getMessageHandle
+		v' <- tryTakeMVar lcker
+		case v' of
+			Just (ProcessLock h) ->
+				-- if process has exited, lock is stale
+				ifM (isJust <$> P.getProcessExitCode h)
+					( havelock
+					, if block
+						then do
+							void $ P.waitForProcess h
+							havelock
+						else do
+							putMVar lcker (ProcessLock h)
+							return False
+					)
+			Just GeneralLock -> do
+				putMVar lcker GeneralLock
+				whenblock waitlock
+			Nothing -> whenblock waitlock
+
+	havelock = do
+		updateOutputLocker GeneralLock
+		return True
+	waitlock = do
+		-- Wait for current lock holder to relinquish
+		-- it and take the lock.
+		lck <- outputLock <$> getMessageHandle
+		takeMVar lck
+		havelock
+	whenblock a = if block then a else return False
+
+-- | Only safe to call after taking the output lock.
+dropOutputLock :: IO ()
+dropOutputLock = do
+	lcker <- outputLockedBy <$> getMessageHandle
+	lck <- outputLock <$> getMessageHandle
+	takeMVar lcker
+	putMVar lck ()
+
+-- | Only safe to call after takeOutputLock; updates the Locker.
+updateOutputLocker :: Locker -> IO ()
+updateOutputLocker l = do
+	lcker <- outputLockedBy <$> getMessageHandle
+	void $ tryTakeMVar lcker
+	putMVar lcker l
+	modifyMVar_ lcker (const $ return l)
 
 -- | 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
@@ -89,14 +165,14 @@ actionMessageOn :: (MonadIO m, MonadMask m, ActionResult r) => HostName -> Desc
 actionMessageOn = actionMessage' . Just
 
 actionMessage' :: (MonadIO m, MonadMask m, ActionResult r) => Maybe HostName -> Desc -> m r -> m r
-actionMessage' mhn desc a = lockOutput $ do
-	liftIO $ whenConsole $ do
+actionMessage' mhn desc a = do
+	liftIO $ whenConsole $ lockOutput $ do
 		setTitle $ "propellor: " ++ desc
 		hFlush stdout
 
 	r <- a
 
-	liftIO $ do
+	liftIO $ lockOutput $ do
 		whenConsole $
 			setTitle "propellor: running"
 		showhn mhn
@@ -151,7 +227,7 @@ checkDebugMode = go =<< getEnv "PROPELLOR_DEBUG"
 	go Nothing = whenM (doesDirectoryExist ".git") $
 		whenM (elem "1" . lines <$> getgitconfig) enableDebugMode
 	getgitconfig = catchDefaultIO "" $
-		readProcess "git" ["config", "propellor.debug"]
+		P.readProcess "git" ["config", "propellor.debug"]
 
 enableDebugMode :: IO ()
 enableDebugMode = do
@@ -194,3 +270,114 @@ messagesDone = lockOutput $ do
 	whenConsole $
 		setTitle "propellor: done"
 	hFlush stdout
+
+-- | Wrapper around `System.Process.createProcess` that prevents processes
+-- that are running concurrently from writing to the stdout/stderr at the
+-- same time.
+--
+-- The first process run by createProcess is allowed to write to
+-- stdout and stderr in the usual way.
+--
+-- However, if a second createProcess runs concurrently with the
+-- first, any stdout or stderr that would have been displayed by it is
+-- instead buffered. The buffered output will be displayed the next time it
+-- is safe to do so (ie, after the first process exits).
+--
+-- `Propellor.Property.Cmd` has some other useful actions for running
+-- commands, which are based on this.
+--
+-- Also does debug logging of all commands run.
+createProcess :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, P.ProcessHandle) 
+createProcess p
+	| hasoutput (P.std_out p) || hasoutput (P.std_err p) =
+		ifM tryTakeOutputLock
+			( firstprocess
+			, concurrentprocess
+			)
+	| otherwise = P.createProcess p
+  where
+	hasoutput P.Inherit = True
+	hasoutput _ = False
+
+	firstprocess = do
+		r@(_, _, _, h) <- P.createProcess p
+			`onException` dropOutputLock
+		updateOutputLocker (ProcessLock h)
+		-- Output lock is still held as we return; the process
+		-- is running now, and once it exits the output lock will
+		-- be stale and can then be taken by something else.
+		return r
+	
+	concurrentprocess = do
+		(toouth, fromouth) <- pipe
+		(toerrh, fromerrh) <- pipe
+		let p' = p
+			{ P.std_out = if hasoutput (P.std_out p)
+				then P.UseHandle toouth
+				else P.std_out p
+			, P.std_err = if hasoutput (P.std_err p)
+				then P.UseHandle toerrh
+				else P.std_err p
+			}
+		r@(_, _, _, ph) <- P.createProcess p'
+		hClose toouth
+		hClose toerrh
+		buf <- newMVar []
+		void $ async $ outputDrainer fromouth stdout buf
+		void $ async $ outputDrainer fromouth stderr buf
+		void $ async $ bufferWriter buf
+		return r
+
+	pipe = do
+		(from, to) <- createPipe
+		(,) <$> fdToHandle to <*> fdToHandle from
+
+type Buffer = [(Handle, Maybe B.ByteString)]
+
+-- Drain output from the handle, and buffer it in memory.
+outputDrainer :: Handle -> Handle -> MVar Buffer -> IO ()
+outputDrainer fromh toh buf = do
+	v <- tryIO $ B.hGetSome fromh 1024
+	case v of
+		Right b | not (B.null b) -> do
+			modifyMVar_ buf (pure . addBuffer (toh, Just b))
+			outputDrainer fromh toh buf
+		_ -> do
+			modifyMVar_ buf (pure . (++ [(toh, Nothing)]))
+			hClose fromh
+
+-- Wait to lock output, and once we can, display everything 
+-- that's put into buffer, until the end is signaled by Nothing
+-- for both stdout and stderr.
+bufferWriter buf = lockOutput (go [stdout, stderr])
+  where
+  	go [] = return ()
+	go hs = do
+		l <- takeMVar buf
+		forM_ l $ \(h, mb) -> do
+			maybe noop (B.hPut h) mb
+			hFlush h
+		let hs' = filter (\h -> not (any (== (h, Nothing)) l)) hs
+		putMVar buf []
+		go hs'
+	
+-- The buffer can grow up to 1 mb in size, but after that point,
+-- it's truncated to avoid propellor using unbounded memory
+-- when a process outputs a whole lot of stuff.
+bufsz = 1000000
+
+addBuffer :: (Handle, Maybe B.ByteString) -> Buffer -> Buffer
+addBuffer v@(_, Nothing) buf = buf ++ [v]
+addBuffer (toh, Just b) buf = (toh, Just b') : other
+  where
+  	(this, other) = partition (\v -> fst v == toh && isJust (snd v)) buf
+	b' = truncateBuffer $ B.concat (mapMaybe snd this) <> b
+	
+-- Truncate a buffer by removing lines from the front until it's
+-- small enough.
+truncateBuffer :: B.ByteString -> B.ByteString
+truncateBuffer b
+	| B.length b <= bufsz = b
+	| otherwise = truncateBuffer $ snd $ B.breakByte nl b
+  where	
+	nl = fromIntegral (ord '\n')
diff --git a/src/Propellor/Property/Cmd.hs b/src/Propellor/Property/Cmd.hs
index 23816a94..f2c5b33e 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
-- 
cgit v1.3-2-g0d8e


From 894e2f7980052f1c331ba7780100ae0ad19856cb Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Tue, 27 Oct 2015 23:52:02 -0400
Subject: use execProcessConcurrent everywhere

Found a reasonable clean way to make Utility.Process use
execProcessConcurrent, while still allowing copying updates to it from
git-annex.
---
 propellor.cabal               |  2 ++
 src/Propellor/Base.hs         |  2 ++
 src/Propellor/Debug.hs        | 36 +++++++++++++++++++++++++++++++
 src/Propellor/Message.hs      | 49 ++++++++-----------------------------------
 src/Propellor/Property/Cmd.hs |  2 +-
 src/Utility/Process.hs        | 16 +++++++-------
 src/Utility/Process/Shim.hs   |  8 +++++++
 7 files changed, 66 insertions(+), 49 deletions(-)
 create mode 100644 src/Propellor/Debug.hs
 create mode 100644 src/Utility/Process/Shim.hs

(limited to 'src/Propellor/Property')

diff --git a/propellor.cabal b/propellor.cabal
index 7a9d2b5d..63fcaaa5 100644
--- a/propellor.cabal
+++ b/propellor.cabal
@@ -135,6 +135,7 @@ Library
     Propellor.CmdLine
     Propellor.Info
     Propellor.Message
+    Propellor.Debug
     Propellor.PrivData
     Propellor.Engine
     Propellor.Exception
@@ -175,6 +176,7 @@ Library
     Utility.PartialPrelude
     Utility.PosixFiles
     Utility.Process
+    Utility.Process.Shim
     Utility.SafeCommand
     Utility.Scheduled
     Utility.Table
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/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/Message.hs b/src/Propellor/Message.hs
index afe551cf..4be8263e 100644
--- a/src/Propellor/Message.hs
+++ b/src/Propellor/Message.hs
@@ -15,24 +15,16 @@ module Propellor.Message (
 	warningMessage,
 	infoMessage,
 	errorMessage,
-	debug,
-	checkDebugMode,
-	enableDebugMode,
 	processChainOutput,
 	messagesDone,
-	createProcess,
+	createProcessConcurrent,
 ) where
 
 import System.Console.ANSI
 import System.IO
 import System.Posix.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 Control.Applicative
-import System.Directory
 import Control.Monad.IfElse
 import System.IO.Unsafe (unsafePerformIO)
 import Control.Concurrent
@@ -42,13 +34,12 @@ import Data.Char
 import Data.List
 import Data.Monoid
 import qualified Data.ByteString as B
+import qualified System.Process as P
 
 import Propellor.Types
 import Utility.PartialPrelude
 import Utility.Monad
-import Utility.Env
 import Utility.Exception
-import qualified Utility.Process as P
 
 data MessageHandle = MessageHandle
 	{ isConsole :: Bool
@@ -131,7 +122,7 @@ dropOutputLock :: IO ()
 dropOutputLock = do
 	lcker <- outputLockedBy <$> getMessageHandle
 	lck <- outputLock <$> getMessageHandle
-	takeMVar lcker
+	void $ takeMVar lcker
 	putMVar lck ()
 
 -- | Only safe to call after takeOutputLock; updates the Locker.
@@ -216,27 +207,6 @@ colorLine intensity color msg = do
 	putStrLn ""
 	hFlush stdout
 
-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 "" $
-		P.readProcess "git" ["config", "propellor.debug"]
-
-enableDebugMode :: IO ()
-enableDebugMode = do
-	f <- setFormatter
-		<$> streamHandler stderr DEBUG
-		<*> pure (simpleLogFormatter "[$time] $msg")
-	updateGlobalLogger rootLoggerName $ 
-		setLevel DEBUG .  setHandlers [f]
-
 -- | Reads and displays each line from the Handle, except for the last line
 -- which is a Result.
 processChainOutput :: Handle -> IO Result
@@ -244,16 +214,13 @@ 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"]
 						lockOutput $ do
 							putStrLn l
 							hFlush stdout
@@ -287,8 +254,8 @@ messagesDone = lockOutput $ do
 -- commands, which are based on this.
 --
 -- Also does debug logging of all commands run.
-createProcess :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, P.ProcessHandle) 
-createProcess p
+createProcessConcurrent :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, P.ProcessHandle) 
+createProcessConcurrent p
 	| hasoutput (P.std_out p) || hasoutput (P.std_err p) =
 		ifM tryTakeOutputLock
 			( firstprocess
@@ -319,12 +286,12 @@ createProcess p
 				then P.UseHandle toerrh
 				else P.std_err p
 			}
-		r@(_, _, _, ph) <- P.createProcess p'
+		r <- P.createProcess p'
 		hClose toouth
 		hClose toerrh
 		buf <- newMVar []
 		void $ async $ outputDrainer fromouth stdout buf
-		void $ async $ outputDrainer fromouth stderr buf
+		void $ async $ outputDrainer fromerrh stderr buf
 		void $ async $ bufferWriter buf
 		return r
 
@@ -349,6 +316,7 @@ outputDrainer fromh toh buf = do
 -- Wait to lock output, and once we can, display everything 
 -- that's put into buffer, until the end is signaled by Nothing
 -- for both stdout and stderr.
+bufferWriter :: MVar Buffer -> IO ()
 bufferWriter buf = lockOutput (go [stdout, stderr])
   where
   	go [] = return ()
@@ -364,6 +332,7 @@ bufferWriter buf = lockOutput (go [stdout, stderr])
 -- The buffer can grow up to 1 mb in size, but after that point,
 -- it's truncated to avoid propellor using unbounded memory
 -- when a process outputs a whole lot of stuff.
+bufsz :: Int
 bufsz = 1000000
 
 addBuffer :: (Handle, Maybe B.ByteString) -> Buffer -> Buffer
diff --git a/src/Propellor/Property/Cmd.hs b/src/Propellor/Property/Cmd.hs
index f2c5b33e..9536f71d 100644
--- a/src/Propellor/Property/Cmd.hs
+++ b/src/Propellor/Property/Cmd.hs
@@ -27,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/Utility/Process.hs b/src/Utility/Process.hs
index cc113867..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
@@ -372,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 ()
@@ -392,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..0da93bf7
--- /dev/null
+++ b/src/Utility/Process/Shim.hs
@@ -0,0 +1,8 @@
+module Utility.Process.Shim (module X, createProcess) where
+
+import System.Process as X hiding (createProcess)
+import Propellor.Message (createProcessConcurrent)
+import System.IO
+
+createProcess :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) 
+createProcess = createProcessConcurrent
-- 
cgit v1.3-2-g0d8e


From 357ffb9fd34ebd36e07dece8e45450dbd2f0e8ec Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Wed, 28 Oct 2015 00:12:38 -0400
Subject: concurrency docs

---
 debian/changelog                     |  2 +-
 src/Propellor/Message.hs             | 16 ++++++++--------
 src/Propellor/Property/Concurrent.hs | 37 +++++++++++++++++++++++++++++++++---
 3 files changed, 43 insertions(+), 12 deletions(-)

(limited to 'src/Propellor/Property')

diff --git a/debian/changelog b/debian/changelog
index 1699b27b..6c154e1a 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -18,7 +18,7 @@ propellor (2.13.0) UNRELEASED; urgency=medium
   * combineWith now takes an additional parameter to control how revert
     actions are combined (API change).
   * Added Propellor.Property.Concurrent for concurrent properties.
-    (Note that no command output multiplexing is currently done.)
+  * execProcess and everything built on it is now concurrent output safe.
   * Add File.isCopyOf. Thanks, Per Olofsson.
 
  -- Joey Hess <id@joeyh.name>  Sat, 24 Oct 2015 15:16:45 -0400
diff --git a/src/Propellor/Message.hs b/src/Propellor/Message.hs
index 4be8263e..3792129b 100644
--- a/src/Propellor/Message.hs
+++ b/src/Propellor/Message.hs
@@ -238,22 +238,22 @@ messagesDone = lockOutput $ do
 		setTitle "propellor: done"
 	hFlush stdout
 
--- | Wrapper around `System.Process.createProcess` that prevents processes
--- that are running concurrently from writing to the stdout/stderr at the
--- same time.
+-- | Wrapper around `System.Process.createProcess` that prevents 
+-- multiple processes that are running concurrently from writing
+-- to stdout/stderr at the same time.
 --
--- The first process run by createProcess is allowed to write to
+-- The first process is allowed to write to
 -- stdout and stderr in the usual way.
 --
--- However, if a second createProcess runs concurrently with the
+-- However, if another process runs concurrently with the
 -- first, any stdout or stderr that would have been displayed by it is
 -- instead buffered. The buffered output will be displayed the next time it
 -- is safe to do so (ie, after the first process exits).
 --
--- `Propellor.Property.Cmd` has some other useful actions for running
--- commands, which are based on this.
---
 -- Also does debug logging of all commands run.
+--
+-- Unless you manually import System.Process, every part of propellor
+-- that runs a process uses this.
 createProcessConcurrent :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, P.ProcessHandle) 
 createProcessConcurrent p
 	| hasoutput (P.std_out p) || hasoutput (P.std_err p) =
diff --git a/src/Propellor/Property/Concurrent.hs b/src/Propellor/Property/Concurrent.hs
index 645a5dfd..74afecc4 100644
--- a/src/Propellor/Property/Concurrent.hs
+++ b/src/Propellor/Property/Concurrent.hs
@@ -1,14 +1,38 @@
 {-# LANGUAGE FlexibleContexts #-}
 
--- | Note that any output of commands run by
--- 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
-- 
cgit v1.3-2-g0d8e


From 86a115aaa0c216e4c46e57a324b58177c8b78435 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Wed, 28 Oct 2015 20:10:11 -0400
Subject: have to flush concurrent output before printing result when chaining

---
 src/Propellor/Message.hs         |  2 +-
 src/Propellor/Property/Chroot.hs |  1 +
 src/Propellor/Property/Docker.hs |  2 ++
 src/Utility/ConcurrentOutput.hs  | 30 +++++++++++++++++-------------
 4 files changed, 21 insertions(+), 14 deletions(-)

(limited to 'src/Propellor/Property')

diff --git a/src/Propellor/Message.hs b/src/Propellor/Message.hs
index 7439c362..7df5104a 100644
--- a/src/Propellor/Message.hs
+++ b/src/Propellor/Message.hs
@@ -135,7 +135,7 @@ processChainOutput h = go Nothing
 				Just l -> case readish l of
 					Just r -> pure r
 					Nothing -> do
-						outputConcurrent l
+						outputConcurrent (l ++ "\n")
 						return FailedChange
 			Just s -> do
 				outputConcurrent $
diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs
index 8b923aab..e72d1bd9 100644
--- a/src/Propellor/Property/Chroot.hs
+++ b/src/Propellor/Property/Chroot.hs
@@ -213,6 +213,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/Docker.hs b/src/Propellor/Property/Docker.hs
index 5f41209a..9082460f 100644
--- a/src/Propellor/Property/Docker.hs
+++ b/src/Propellor/Property/Docker.hs
@@ -540,6 +540,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" []
@@ -583,6 +584,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/Utility/ConcurrentOutput.hs b/src/Utility/ConcurrentOutput.hs
index db0bae0a..3f28068a 100644
--- a/src/Utility/ConcurrentOutput.hs
+++ b/src/Utility/ConcurrentOutput.hs
@@ -5,6 +5,7 @@
 
 module Utility.ConcurrentOutput (
 	withConcurrentOutput,
+	flushConcurrentOutput,
 	outputConcurrent,
 	createProcessConcurrent,
 	waitForProcessConcurrent,
@@ -105,19 +106,22 @@ dropOutputLock = withLock $ void . takeTMVar
 -- 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` drain
-  where
-	-- Wait for all outputThreads to finish. Then, take the output lock
-	-- to ensure that nothing is currently generating output, and flush
-	-- any buffered output.
-	drain = do
-		v <- outputThreads <$> getOutputHandle
-		atomically $ do
-			r <- takeTMVar v
-			if r == S.empty
-				then return ()
-				else retry
-		lockOutput $ return ()
+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 return ()
+			else retry
+	-- Take output lock to ensure that nothing else is currently
+	-- generating output, and flush any buffered output.
+	lockOutput $ return ()
 
 -- | Displays a string to stdout, and flush output so it's displayed.
 --
-- 
cgit v1.3-2-g0d8e


From 7f1e82da152b8eb085e91cddc369831fbfdb7a37 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Wed, 28 Oct 2015 20:12:06 -0400
Subject: propellor spin

---
 src/Propellor/Property/Chroot.hs | 1 +
 src/Propellor/Property/Docker.hs | 1 +
 2 files changed, 2 insertions(+)

(limited to 'src/Propellor/Property')

diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs
index e72d1bd9..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
diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs
index 9082460f..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
-- 
cgit v1.3-2-g0d8e


From b218820da0b069e826507150cba118f0fa69d409 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Sun, 1 Nov 2015 11:30:25 -0400
Subject: take dkim out of test mode

---
 src/Propellor/Property/SiteSpecific/JoeySites.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

(limited to 'src/Propellor/Property')

diff --git a/src/Propellor/Property/SiteSpecific/JoeySites.hs b/src/Propellor/Property/SiteSpecific/JoeySites.hs
index d6db6813..d6a50309 100644
--- a/src/Propellor/Property/SiteSpecific/JoeySites.hs
+++ b/src/Propellor/Property/SiteSpecific/JoeySites.hs
@@ -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`
-- 
cgit v1.3-2-g0d8e