From c59ce983999ddbfe6cb8b27e4f376b5c37d7f853 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 5 Jul 2017 13:10:59 -0400 Subject: speed up chain output displaying Avoid needing to wait for a subsequent line before displaying the previous line. --- src/Propellor/Message.hs | 25 +++++++++++++------------ 1 file changed, 13 insertions(+), 12 deletions(-) (limited to 'src/Propellor/Message.hs') diff --git a/src/Propellor/Message.hs b/src/Propellor/Message.hs index c56f0c5a..1a01875c 100644 --- a/src/Propellor/Message.hs +++ b/src/Propellor/Message.hs @@ -27,10 +27,12 @@ import System.IO.Unsafe (unsafePerformIO) import Control.Concurrent import System.Console.Concurrent import Control.Applicative +import Control.Monad import Prelude import Propellor.Types import Propellor.Types.Exception +import Propellor.Debug import Utility.PartialPrelude import Utility.Monad import Utility.Exception @@ -147,21 +149,20 @@ colorLine intensity color msg = concat <$> sequence processChainOutput :: Handle -> IO Result processChainOutput h = go Nothing where - go lastline = do + go rval = do v <- catchMaybeIO (hGetLine h) + debug ["chain process output", show v] 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 + Nothing -> case rval of + Nothing -> return FailedChange + Just r -> return r Just s -> do - outputConcurrent $ - maybe "" (\l -> if null l then "" else l ++ "\n") lastline - go (Just s) + case readish s of + Nothing -> do + unless (null s) $ + outputConcurrent (s ++ "\n") + go rval + Just rval' -> go rval' -- | Called when all messages about properties have been printed. messagesDone :: IO () -- cgit v1.3-2-g0d8e From 88c02486abcf45067483bd6a138b046397491889 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 5 Jul 2017 13:15:26 -0400 Subject: propellor spin --- src/Propellor/Message.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'src/Propellor/Message.hs') diff --git a/src/Propellor/Message.hs b/src/Propellor/Message.hs index 1a01875c..1551eb7d 100644 --- a/src/Propellor/Message.hs +++ b/src/Propellor/Message.hs @@ -151,7 +151,6 @@ processChainOutput h = go Nothing where go rval = do v <- catchMaybeIO (hGetLine h) - debug ["chain process output", show v] case v of Nothing -> case rval of Nothing -> return FailedChange @@ -159,7 +158,8 @@ processChainOutput h = go Nothing Just s -> do case readish s of Nothing -> do - unless (null s) $ + unless (null s) $ do + debug ["chain process output", show v] outputConcurrent (s ++ "\n") go rval Just rval' -> go rval' -- cgit v1.3-2-g0d8e From 4eb2a663e4d4ff00d121c5f595f2eb7248b98199 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 5 Jul 2017 13:23:33 -0400 Subject: Revert "speed up chain output displaying" This reverts commit c59ce983999ddbfe6cb8b27e4f376b5c37d7f853. That was wrong because only the *last* line of chain output is a Result. It could be that a previous line is able to be read as a Result, and the commit would make processing bail out at that point. --- src/Propellor/Message.hs | 25 ++++++++++++------------- 1 file changed, 12 insertions(+), 13 deletions(-) (limited to 'src/Propellor/Message.hs') diff --git a/src/Propellor/Message.hs b/src/Propellor/Message.hs index 1551eb7d..c56f0c5a 100644 --- a/src/Propellor/Message.hs +++ b/src/Propellor/Message.hs @@ -27,12 +27,10 @@ import System.IO.Unsafe (unsafePerformIO) import Control.Concurrent import System.Console.Concurrent import Control.Applicative -import Control.Monad import Prelude import Propellor.Types import Propellor.Types.Exception -import Propellor.Debug import Utility.PartialPrelude import Utility.Monad import Utility.Exception @@ -149,20 +147,21 @@ colorLine intensity color msg = concat <$> sequence processChainOutput :: Handle -> IO Result processChainOutput h = go Nothing where - go rval = do + go lastline = do v <- catchMaybeIO (hGetLine h) case v of - Nothing -> case rval of - Nothing -> return FailedChange - Just r -> return r - Just s -> do - case readish s of + Nothing -> case lastline of + Nothing -> do + return FailedChange + Just l -> case readish l of + Just r -> pure r Nothing -> do - unless (null s) $ do - debug ["chain process output", show v] - outputConcurrent (s ++ "\n") - go rval - Just rval' -> go rval' + 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 () -- cgit v1.3-2-g0d8e From 2b9d5ca90f053ad21fbbab89b3045bd0822400d5 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 5 Jul 2017 13:52:29 -0400 Subject: avoid buffering container chain output When provisioning a container, output was buffered until the whole process was done; now output will be displayed immediately. I know this didn't used to be a problem. I belive it was introduced by accident when propellor started using concurrent-output. I know I've seen it for a while and never was bothered enough to get to the bottom of it; apparently "a while" was longer than I thought. Also refactored code to do with chain provisioning to all be in Propellor.Engine and avoided some duplication. This commit was sponsored by Anthony DeRobertis on Patreon. --- debian/changelog | 2 ++ src/Propellor/Engine.hs | 56 ++++++++++++++++++++++++++++++++++++++++ src/Propellor/Message.hs | 23 ----------------- src/Propellor/Property/Chroot.hs | 18 +++++-------- src/Propellor/Property/Docker.hs | 10 +++---- 5 files changed, 69 insertions(+), 40 deletions(-) (limited to 'src/Propellor/Message.hs') diff --git a/debian/changelog b/debian/changelog index c52b8329..34ea28f4 100644 --- a/debian/changelog +++ b/debian/changelog @@ -14,6 +14,8 @@ propellor (4.0.7) UNRELEASED; urgency=medium be built from the bootstrapped config the first time. * Bootstrap.bootstrappedFrom: Avoid doing anything when not run in a chroot. + * When provisioning a container, output was buffered until the whole + process was done; now output will be displayed immediately. -- Joey Hess Tue, 20 Jun 2017 10:55:37 -0400 diff --git a/src/Propellor/Engine.hs b/src/Propellor/Engine.hs index 08f535e0..f54da929 100644 --- a/src/Propellor/Engine.hs +++ b/src/Propellor/Engine.hs @@ -8,6 +8,8 @@ module Propellor.Engine ( fromHost, fromHost', onlyProcess, + chainPropellor, + runChainPropellor, ) where import System.Exit @@ -17,7 +19,9 @@ import "mtl" Control.Monad.RWS.Strict import System.PosixCompat import System.Posix.IO import System.FilePath +import System.Console.Concurrent import Control.Applicative +import Control.Concurrent.Async import Prelude import Propellor.Types @@ -28,6 +32,8 @@ import Propellor.Exception import Propellor.Info import Utility.Exception import Utility.Directory +import Utility.Process +import Utility.PartialPrelude -- | Gets the Properties of a Host, and ensures them all, -- with nice display of what's being done. @@ -96,3 +102,53 @@ onlyProcess lockfile a = bracket lock unlock (const a) return l unlock = closeFd alreadyrunning = error "Propellor is already running on this host!" + +-- | Chains to a propellor sub-Process, forwarding its output on to the +-- display, except for the last line which is a Result. +chainPropellor :: CreateProcess -> IO Result +chainPropellor p = + -- We want to use outputConcurrent to display output + -- as it's received. If only stdout were captured, + -- concurrent-output would buffer all outputConcurrent. + -- Also capturing stderr avoids that problem. + withOEHandles createProcessSuccess p $ \(outh, errh) -> do + (r, ()) <- processChainOutput outh + `concurrently` forwardChainError errh + return r + +-- | Reads and displays each line from the Handle, except for the last line +-- which is a Result. +processChainOutput :: Handle -> IO Result +processChainOutput h = go Nothing + where + go lastline = do + v <- catchMaybeIO (hGetLine h) + case v of + Nothing -> case lastline of + Nothing -> do + return FailedChange + Just l -> case readish l of + Just r -> pure r + Nothing -> do + outputConcurrent (l ++ "\n") + return FailedChange + Just s -> do + outputConcurrent $ + maybe "" (\l -> if null l then "" else l ++ "\n") lastline + go (Just s) + +forwardChainError :: Handle -> IO () +forwardChainError h = do + v <- catchMaybeIO (hGetLine h) + case v of + Nothing -> return () + Just s -> do + errorConcurrent (s ++ "\n") + forwardChainError h + +-- | Used by propellor sub-Processes that are run by chainPropellor. +runChainPropellor :: Host -> Propellor Result -> IO () +runChainPropellor h a = do + r <- runPropellor h a + flushConcurrentOutput + putStrLn $ "\n" ++ show r diff --git a/src/Propellor/Message.hs b/src/Propellor/Message.hs index c56f0c5a..7715088f 100644 --- a/src/Propellor/Message.hs +++ b/src/Propellor/Message.hs @@ -14,7 +14,6 @@ module Propellor.Message ( infoMessage, errorMessage, stopPropellorMessage, - processChainOutput, messagesDone, createProcessConcurrent, withConcurrentOutput, @@ -31,7 +30,6 @@ import Prelude import Propellor.Types import Propellor.Types.Exception -import Utility.PartialPrelude import Utility.Monad import Utility.Exception @@ -142,27 +140,6 @@ colorLine intensity color msg = concat <$> sequence , pure "\n" ] --- | Reads and displays each line from the Handle, except for the last line --- which is a Result. -processChainOutput :: Handle -> IO Result -processChainOutput h = go Nothing - where - go lastline = do - v <- catchMaybeIO (hGetLine h) - case v of - Nothing -> case lastline of - Nothing -> do - return FailedChange - Just l -> case readish l of - Just r -> pure r - Nothing -> do - outputConcurrent (l ++ "\n") - return FailedChange - Just s -> do - outputConcurrent $ - maybe "" (\l -> if null l then "" else l ++ "\n") lastline - go (Just s) - -- | Called when all messages about properties have been printed. messagesDone :: IO () messagesDone = outputConcurrent diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs index ad2ae705..65749e34 100644 --- a/src/Propellor/Property/Chroot.hs +++ b/src/Propellor/Property/Chroot.hs @@ -37,7 +37,6 @@ import Utility.Split import qualified Data.Map as M import System.Posix.Directory -import System.Console.Concurrent -- | Specification of a chroot. Normally you'll use `debootstrapped` or -- `bootstrapped` to construct a Chroot value. @@ -201,9 +200,7 @@ propellChroot c@(Chroot loc _ _ _) mkproc systemdonly = property (chrootDesc c " , "--continue" , show cmd ] - let p' = p { env = Just pe } - r <- liftIO $ withHandle StdoutHandle createProcessSuccess p' - processChainOutput + r <- liftIO $ chainPropellor (p { env = Just pe }) liftIO cleanup return r @@ -223,13 +220,12 @@ chain hostlist (ChrootChain hn loc systemdonly onconsole) = go h = do changeWorkingDirectory localdir when onconsole forceConsole - onlyProcess (provisioningLock loc) $ do - r <- runPropellor (setInChroot h) $ ensureChildProperties $ - if systemdonly - then [toChildProperty Systemd.installed] - else hostProperties h - flushConcurrentOutput - putStrLn $ "\n" ++ show r + onlyProcess (provisioningLock loc) $ + runChainPropellor (setInChroot h) $ + ensureChildProperties $ + if systemdonly + then [toChildProperty Systemd.installed] + else hostProperties h chain _ _ = errorMessage "bad chain command" inChrootProcess :: Bool -> Chroot -> [String] -> IO (CreateProcess, IO ()) diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs index d53bab71..66418253 100644 --- a/src/Propellor/Property/Docker.hs +++ b/src/Propellor/Property/Docker.hs @@ -576,8 +576,7 @@ provisionContainer cid = containerDesc cid $ property "provisioned" $ liftIO $ d let p = inContainerProcess cid (if isConsole msgh then ["-it"] else []) (shim : params) - r <- withHandle StdoutHandle createProcessSuccess p $ - processChainOutput + r <- chainPropellor p when (r /= FailedChange) $ setProvisionedFlag cid return r @@ -596,10 +595,9 @@ chain hostlist hn s = case toContainerId s of where go cid h = do changeWorkingDirectory localdir - onlyProcess (provisioningLock cid) $ do - r <- runPropellor h $ ensureChildProperties $ hostProperties h - flushConcurrentOutput - putStrLn $ "\n" ++ show r + onlyProcess (provisioningLock cid) $ + runChainPropellor h $ + ensureChildProperties $ hostProperties h stopContainer :: ContainerId -> IO Bool stopContainer cid = boolSystem dockercmd [Param "stop", Param $ fromContainerId cid ] -- cgit v1.3-2-g0d8e