From 56c3394144abbb9862dc67379d3253c76ae4df97 Mon Sep 17 00:00:00 2001 From: Joey Hess 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/Chroot.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'src/Propellor/Property/Chroot.hs') 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]) -- cgit v1.3-2-g0d8e From 6e3b0022fa451181fdce8abd145e27a64a777711 Mon Sep 17 00:00:00 2001 From: Joey Hess 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/Chroot.hs') 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 86a115aaa0c216e4c46e57a324b58177c8b78435 Mon Sep 17 00:00:00 2001 From: Joey Hess 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/Chroot.hs') 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 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/Chroot.hs') 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