summaryrefslogtreecommitdiff
path: root/src/Propellor
diff options
context:
space:
mode:
authorJoey Hess2015-10-27 17:02:23 -0400
committerJoey Hess2015-10-27 17:02:23 -0400
commit20b04d366b2cff90c39d06fd424ae3e8b67e49f6 (patch)
tree2ebd3fdbacb20ab42bc7ce6b331f99336f551fed /src/Propellor
parent6e3b0022fa451181fdce8abd145e27a64a777711 (diff)
make Propellor.Message use lock to handle concurrent threads outputting messages
Not yet handled: Output from concurrent programs.
Diffstat (limited to 'src/Propellor')
-rw-r--r--src/Propellor/Engine.hs33
-rw-r--r--src/Propellor/Message.hs92
-rw-r--r--src/Propellor/PrivData.hs22
-rw-r--r--src/Propellor/Property/Concurrent.hs4
4 files changed, 99 insertions, 52 deletions
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,