diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,33 @@ +propellor (2.13.0) unstable; urgency=medium + + * RevertableProperty used to be assumed to contain info, but this is + now made explicit, with RevertableProperty HasInfo or + RevertableProperty NoInfo. (API change) + 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 + instead to create the RevertableProperty. + * Various property combinators that combined a RevertableProperty + with a non-revertable property used to yield a RevertableProperty. + This was a bug, because the combined property could not be fully + reverted in many cases, and the result is now a non-revertable property. + * combineWith now takes an additional parameter to control how revert + actions are combined (API change). + * Added Propellor.Property.Concurrent for concurrent properties. + * Made the execProcess exported by propellor, and everything built on it, + avoid scrambled output when run concurrently. + * Propellor now depends on STM and text. + * The cabal file now builds propellor with -O. While -O0 makes ghc + take less memory while building propellor, it can lead to bad memory + usage at runtime due to eg, disabled stream fusion. + * Add File.isCopyOf. Thanks, Per Olofsson. + + -- Joey Hess Sun, 08 Nov 2015 14:51:15 -0400 + propellor (2.12.0) unstable; urgency=medium * The DiskImage module can now make bootable images using grub. diff --git a/config-joey.hs b/config-joey.hs --- a/config-joey.hs +++ b/config-joey.hs @@ -515,13 +515,13 @@ & Dns.secondary hosts "ikiwiki.info" & Dns.secondary hosts "olduse.net" -branchableSecondary :: RevertableProperty +branchableSecondary :: RevertableProperty HasInfo branchableSecondary = Dns.secondaryFor ["branchable.com"] hosts "branchable.com" -- Currently using kite (ns4) as primary with secondaries -- elephant (ns3) and gandi. -- kite handles all mail. -myDnsPrimary :: Bool -> Domain -> [(BindDomain, Record)] -> RevertableProperty +myDnsPrimary :: Bool -> Domain -> [(BindDomain, Record)] -> RevertableProperty HasInfo myDnsPrimary dnssec domain extras = (if dnssec then Dns.signedPrimary (Weekly Nothing) else Dns.primary) hosts domain (Dns.mkSOA "ns4.kitenet.net" 100) $ [ (RootDomain, NS $ AbsDomain "ns4.kitenet.net") diff --git a/debian/changelog b/debian/changelog --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,33 @@ +propellor (2.13.0) unstable; urgency=medium + + * RevertableProperty used to be assumed to contain info, but this is + now made explicit, with RevertableProperty HasInfo or + RevertableProperty NoInfo. (API change) + 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 + instead to create the RevertableProperty. + * Various property combinators that combined a RevertableProperty + with a non-revertable property used to yield a RevertableProperty. + This was a bug, because the combined property could not be fully + reverted in many cases, and the result is now a non-revertable property. + * combineWith now takes an additional parameter to control how revert + actions are combined (API change). + * Added Propellor.Property.Concurrent for concurrent properties. + * Made the execProcess exported by propellor, and everything built on it, + avoid scrambled output when run concurrently. + * Propellor now depends on STM and text. + * The cabal file now builds propellor with -O. While -O0 makes ghc + take less memory while building propellor, it can lead to bad memory + usage at runtime due to eg, disabled stream fusion. + * Add File.isCopyOf. Thanks, Per Olofsson. + + -- Joey Hess Sun, 08 Nov 2015 14:51:15 -0400 + propellor (2.12.0) unstable; urgency=medium * The DiskImage module can now make bootable images using grub. diff --git a/debian/control b/debian/control --- a/debian/control +++ b/debian/control @@ -17,7 +17,9 @@ libghc-mtl-dev, libghc-transformers-dev, libghc-exceptions-dev (>= 0.6), -Maintainer: Gergely Nagy + libghc-stm-dev, + libghc-text-dev, +Maintainer: Joey Hess Standards-Version: 3.9.6 Vcs-Git: git://git.joeyh.name/propellor Homepage: http://propellor.branchable.com/ @@ -39,6 +41,8 @@ libghc-mtl-dev, libghc-transformers-dev, libghc-exceptions-dev (>= 0.6), + libghc-stm-dev, + libghc-text-dev, git, make, Description: property-based host configuration management in haskell diff --git a/propellor.cabal b/propellor.cabal --- a/propellor.cabal +++ b/propellor.cabal @@ -1,5 +1,5 @@ Name: propellor -Version: 2.12.0 +Version: 2.13.0 Cabal-Version: >= 1.8 License: BSD3 Maintainer: Joey Hess @@ -34,35 +34,35 @@ Executable propellor Main-Is: wrapper.hs - GHC-Options: -threaded -O0 -Wall -fno-warn-tabs + GHC-Options: -threaded -Wall -fno-warn-tabs Hs-Source-Dirs: src Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5, IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal, containers (>= 0.5), network, async, time, QuickCheck, mtl, transformers, - exceptions (>= 0.6) + exceptions (>= 0.6), stm, text if (! os(windows)) Build-Depends: unix Executable propellor-config Main-Is: config.hs - GHC-Options: -threaded -O0 -Wall -fno-warn-tabs + GHC-Options: -threaded -Wall -fno-warn-tabs Hs-Source-Dirs: src Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5, IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal, containers (>= 0.5), network, async, time, QuickCheck, mtl, transformers, - exceptions + exceptions, stm, text if (! os(windows)) Build-Depends: unix Library - GHC-Options: -O0 -Wall -fno-warn-tabs + GHC-Options: -Wall -fno-warn-tabs Hs-Source-Dirs: src Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5, IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal, containers (>= 0.5), network, async, time, QuickCheck, mtl, transformers, - exceptions + exceptions, stm, text if (! os(windows)) Build-Depends: unix @@ -76,6 +76,7 @@ Propellor.Property.Apache Propellor.Property.Apt Propellor.Property.Cmd + Propellor.Property.Concurrent Propellor.Property.Conductor Propellor.Property.Hostname Propellor.Property.Chroot @@ -134,6 +135,7 @@ Propellor.CmdLine Propellor.Info Propellor.Message + Propellor.Debug Propellor.PrivData Propellor.Engine Propellor.Exception @@ -174,6 +176,7 @@ Utility.PartialPrelude Utility.PosixFiles Utility.Process + Utility.Process.Shim Utility.SafeCommand Utility.Scheduled Utility.Table @@ -181,6 +184,9 @@ Utility.Tmp Utility.UserInfo Utility.QuickCheck + System.Console.Concurrent + System.Console.Concurrent.Internal + System.Process.Concurrent source-repository head type: git diff --git a/src/Propellor/Base.hs b/src/Propellor/Base.hs --- a/src/Propellor/Base.hs +++ b/src/Propellor/Base.hs @@ -15,6 +15,7 @@ , module Propellor.Engine , module Propellor.Exception , module Propellor.Message + , module Propellor.Debug , module Propellor.Location , module Propellor.Utilities @@ -39,6 +40,7 @@ import Propellor.PrivData import Propellor.Types.PrivData import Propellor.Message +import Propellor.Debug import Propellor.Exception import Propellor.Info import Propellor.PropAccum diff --git a/src/Propellor/Bootstrap.hs b/src/Propellor/Bootstrap.hs --- a/src/Propellor/Bootstrap.hs +++ b/src/Propellor/Bootstrap.hs @@ -65,7 +65,7 @@ aptinstall p = "apt-get --no-upgrade --no-install-recommends -y install " ++ p - -- This is the same build deps listed in debian/control. + -- This is the same deps listed in debian/control. debdeps = [ "gnupg" , "ghc" @@ -81,6 +81,8 @@ , "libghc-mtl-dev" , "libghc-transformers-dev" , "libghc-exceptions-dev" + , "libghc-stm-dev" + , "libghc-text-dev" , "make" ] diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs --- a/src/Propellor/CmdLine.hs +++ b/src/Propellor/CmdLine.hs @@ -89,7 +89,7 @@ -- | Runs propellor on hosts, as controlled by command-line options. defaultMain :: [Host] -> IO () -defaultMain hostlist = do +defaultMain hostlist = withConcurrentOutput $ do Shim.cleanEnv checkDebugMode cmdline <- processCmdLine @@ -120,8 +120,9 @@ go False (Spin hs mrelay) = do commitSpin forM_ hs $ \hn -> withhost hn $ spin mrelay hn - go False cmdline@(SimpleRun hn) = buildFirst cmdline $ - go False (Run hn) + go False cmdline@(SimpleRun hn) = do + forceConsole + buildFirst cmdline $ go False (Run hn) go False (Run hn) = ifM ((==) 0 <$> getRealUserID) ( onlyprocess $ withhost hn mainProperties , go True (Spin [hn] Nothing) diff --git a/src/Propellor/Debug.hs b/src/Propellor/Debug.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/Debug.hs @@ -0,0 +1,36 @@ +module Propellor.Debug where + +import Control.Applicative +import Control.Monad.IfElse +import System.IO +import System.Directory +import System.Log.Logger +import System.Log.Formatter +import System.Log.Handler (setFormatter) +import System.Log.Handler.Simple + +import Utility.Monad +import Utility.Env +import Utility.Exception +import Utility.Process + +debug :: [String] -> IO () +debug = debugM "propellor" . unwords + +checkDebugMode :: IO () +checkDebugMode = go =<< getEnv "PROPELLOR_DEBUG" + where + go (Just "1") = enableDebugMode + go (Just _) = noop + go Nothing = whenM (doesDirectoryExist ".git") $ + whenM (elem "1" . lines <$> getgitconfig) enableDebugMode + getgitconfig = catchDefaultIO "" $ + readProcess "git" ["config", "propellor.debug"] + +enableDebugMode :: IO () +enableDebugMode = do + f <- setFormatter + <$> streamHandler stderr DEBUG + <*> pure (simpleLogFormatter "[$time] $msg") + updateGlobalLogger rootLoggerName $ + setLevel DEBUG . setHandlers [f] diff --git a/src/Propellor/Engine.hs b/src/Propellor/Engine.hs --- a/src/Propellor/Engine.hs +++ b/src/Propellor/Engine.hs @@ -9,14 +9,12 @@ 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.Info import Propellor.Property import Utility.Exception -import Utility.PartialPrelude -import Utility.Monad -- | Gets the Properties of a Host, and ensures them all, -- with nice display of what's being done. @@ -38,10 +34,7 @@ mainProperties host = do ret <- runPropellor host $ ensureProperties [ignoreInfo $ infoProperty "overall" (ensureProperties ps) mempty mempty] - h <- mkMessageHandle - whenConsole h $ - setTitle "propellor: done" - hFlush stdout + messagesDone case ret of FailedChange -> exitWith (ExitFailure 1) _ -> exitWith ExitSuccess @@ -55,7 +48,7 @@ -- are then also run. runPropellor :: Host -> Propellor Result -> IO Result runPropellor host a = do - (res, _s, endactions) <- runRWST (runWithHost a) host () + (res, endactions) <- evalRWST (runWithHost a) host () endres <- mapM (runEndAction host res) endactions return $ mconcat (res:endres) @@ -99,28 +92,3 @@ 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/Gpg.hs b/src/Propellor/Gpg.hs --- a/src/Propellor/Gpg.hs +++ b/src/Propellor/Gpg.hs @@ -7,6 +7,8 @@ import Data.Maybe import Data.List.Utils import Control.Monad +import System.Console.Concurrent +import System.Console.Concurrent.Internal (ConcurrentProcessHandle(..)) import Propellor.PrivData.Paths import Propellor.Message @@ -111,10 +113,7 @@ -- Commit explicitly the keyring and privdata files, as other -- changes may be staged by the user and shouldn't be committed. tocommit <- filterM doesFileExist [ privDataFile, keyring] - gitCommit $ (map File tocommit) ++ - [ Param "-m" - , Param ("propellor " ++ action) - ] + gitCommit (Just ("propellor " ++ action)) (map File tocommit) -- Adds --gpg-sign if there's a keyring. gpgSignParams :: [CommandParam] -> IO [CommandParam] @@ -124,10 +123,17 @@ ) -- Automatically sign the commit if there'a a keyring. -gitCommit :: [CommandParam] -> IO Bool -gitCommit ps = do - ps' <- gpgSignParams ps - boolSystem "git" (Param "commit" : ps') +gitCommit :: Maybe String -> [CommandParam] -> IO Bool +gitCommit msg ps = do + let ps' = Param "commit" : ps ++ + maybe [] (\m -> [Param "-m", Param m]) msg + ps'' <- gpgSignParams ps' + if isNothing msg + then do + (_, _, _, ConcurrentProcessHandle p) <- createProcessForeground $ + proc "git" (toCommand ps'') + checkSuccessProcess p + else boolSystem "git" ps'' gpgDecrypt :: FilePath -> IO String gpgDecrypt f = ifM (doesFileExist f) diff --git a/src/Propellor/Message.hs b/src/Propellor/Message.hs --- a/src/Propellor/Message.hs +++ b/src/Propellor/Message.hs @@ -1,125 +1,148 @@ -{-# LANGUAGE PackageImports #-} +-- | 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 where +module Propellor.Message ( + getMessageHandle, + isConsole, + forceConsole, + actionMessage, + actionMessageOn, + warningMessage, + infoMessage, + errorMessage, + processChainOutput, + messagesDone, + createProcessConcurrent, + withConcurrentOutput, +) where import System.Console.ANSI import System.IO -import System.Log.Logger -import System.Log.Formatter -import System.Log.Handler (setFormatter) -import System.Log.Handler.Simple -import "mtl" Control.Monad.Reader -import Data.Maybe +import Control.Monad.IO.Class (liftIO, MonadIO) import Control.Applicative -import System.Directory -import Control.Monad.IfElse +import System.IO.Unsafe (unsafePerformIO) +import Control.Concurrent +import System.Console.Concurrent import Propellor.Types +import Utility.PartialPrelude import Utility.Monad -import Utility.Env -import Utility.Process import Utility.Exception -data MessageHandle - = ConsoleMessageHandle - | TextMessageHandle +data MessageHandle = MessageHandle + { isConsole :: Bool + } -mkMessageHandle :: IO MessageHandle -mkMessageHandle = do - ifM (hIsTerminalDevice stdout <||> (isJust <$> getEnv "PROPELLOR_CONSOLE")) - ( return ConsoleMessageHandle - , return TextMessageHandle - ) +-- | A shared global variable for the MessageHandle. +{-# NOINLINE globalMessageHandle #-} +globalMessageHandle :: MVar MessageHandle +globalMessageHandle = unsafePerformIO $ + newMVar =<< MessageHandle + <$> hIsTerminalDevice stdout -forceConsole :: IO () -forceConsole = void $ setEnv "PROPELLOR_CONSOLE" "1" True +-- | Gets the global MessageHandle. +getMessageHandle :: IO MessageHandle +getMessageHandle = readMVar globalMessageHandle -isConsole :: MessageHandle -> Bool -isConsole ConsoleMessageHandle = True -isConsole _ = False +-- | Force console output. This can be used when stdout is not directly +-- connected to a console, but is eventually going to be displayed at a +-- console. +forceConsole :: IO () +forceConsole = modifyMVar_ globalMessageHandle $ \mh -> + pure (mh { isConsole = True }) -whenConsole :: MessageHandle -> IO () -> IO () -whenConsole ConsoleMessageHandle a = a -whenConsole _ _ = return () +whenConsole :: String -> IO String +whenConsole s = ifM (isConsole <$> getMessageHandle) + ( pure s + , pure "" + ) -- | Shows a message while performing an action, with a colored status -- display. -actionMessage :: (MonadIO m, ActionResult r) => Desc -> m r -> m r +actionMessage :: (MonadIO m, MonadMask m, ActionResult r) => Desc -> m r -> m r actionMessage = actionMessage' Nothing -- | Shows a message while performing an action on a specified host, -- with a colored status display. -actionMessageOn :: (MonadIO m, ActionResult r) => HostName -> Desc -> m r -> m r +actionMessageOn :: (MonadIO m, MonadMask m, ActionResult r) => HostName -> Desc -> m r -> m r actionMessageOn = actionMessage' . Just -actionMessage' :: (MonadIO m, ActionResult r) => Maybe HostName -> Desc -> m r -> m r +actionMessage' :: (MonadIO m, MonadMask m, ActionResult r) => Maybe HostName -> Desc -> m r -> m r actionMessage' mhn desc a = do - h <- liftIO mkMessageHandle - liftIO $ whenConsole h $ do - setTitle $ "propellor: " ++ desc - hFlush stdout + liftIO $ outputConcurrent + =<< whenConsole (setTitleCode $ "propellor: " ++ desc) r <- a - liftIO $ do - whenConsole h $ - setTitle "propellor: running" - showhn h mhn - putStr $ desc ++ " ... " - let (msg, intensity, color) = getActionResult r - colorLine h intensity color msg - hFlush stdout + liftIO $ outputConcurrent . concat =<< sequence + [ whenConsole $ + setTitleCode "propellor: running" + , showhn mhn + , pure $ desc ++ " ... " + , let (msg, intensity, color) = getActionResult r + in colorLine intensity color msg + ] return r where - showhn _ Nothing = return () - showhn h (Just hn) = do - whenConsole h $ - setSGR [SetColor Foreground Dull Cyan] - putStr (hn ++ " ") - whenConsole h $ - setSGR [] + showhn Nothing = return "" + showhn (Just hn) = concat <$> sequence + [ whenConsole $ + setSGRCode [SetColor Foreground Dull Cyan] + , pure (hn ++ " ") + , whenConsole $ + setSGRCode [] + ] warningMessage :: MonadIO m => String -> m () -warningMessage s = liftIO $ do - h <- mkMessageHandle - colorLine h Vivid Magenta $ "** warning: " ++ s +warningMessage s = liftIO $ + outputConcurrent =<< colorLine Vivid Magenta ("** warning: " ++ s) +infoMessage :: MonadIO m => [String] -> m () +infoMessage ls = liftIO $ outputConcurrent $ concatMap (++ "\n") ls + errorMessage :: MonadIO m => String -> m a errorMessage s = liftIO $ do - h <- mkMessageHandle - colorLine h Vivid Red $ "** error: " ++ s + outputConcurrent =<< colorLine Vivid Red ("** error: " ++ s) error "Cannot continue!" - -colorLine :: MessageHandle -> ColorIntensity -> Color -> String -> IO () -colorLine h intensity color msg = do - whenConsole h $ - setSGR [SetColor Foreground intensity color] - putStr msg - whenConsole h $ - setSGR [] + +colorLine :: ColorIntensity -> Color -> String -> IO String +colorLine intensity color msg = concat <$> sequence + [ whenConsole $ + setSGRCode [SetColor Foreground intensity color] + , pure msg + , whenConsole $ + setSGRCode [] -- Note this comes after the color is reset, so that -- the color set and reset happen in the same line. - putStrLn "" - hFlush stdout - -debug :: [String] -> IO () -debug = debugM "propellor" . unwords + , pure "\n" + ] -checkDebugMode :: IO () -checkDebugMode = go =<< getEnv "PROPELLOR_DEBUG" +-- | Reads and displays each line from the Handle, except for the last line +-- which is a Result. +processChainOutput :: Handle -> IO Result +processChainOutput h = go Nothing where - go (Just "1") = enableDebugMode - go (Just _) = noop - go Nothing = whenM (doesDirectoryExist ".git") $ - whenM (elem "1" . lines <$> getgitconfig) enableDebugMode - getgitconfig = catchDefaultIO "" $ - readProcess "git" ["config", "propellor.debug"] + 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) -enableDebugMode :: IO () -enableDebugMode = do - f <- setFormatter - <$> streamHandler stderr DEBUG - <*> pure (simpleLogFormatter "[$time] $msg") - updateGlobalLogger rootLoggerName $ - setLevel DEBUG . setHandlers [f] +-- | Called when all messages about properties have been printed. +messagesDone :: IO () +messagesDone = outputConcurrent + =<< whenConsole (setTitleCode "propellor: done") diff --git a/src/Propellor/PrivData.hs b/src/Propellor/PrivData.hs --- a/src/Propellor/PrivData.hs +++ b/src/Propellor/PrivData.hs @@ -36,6 +36,8 @@ import qualified Data.Map as M import qualified Data.Set as S import qualified Data.ByteString.Lazy as L +import System.Console.Concurrent +import System.Console.Concurrent.Internal (ConcurrentProcessHandle(..)) import Propellor.Types import Propellor.Types.PrivData @@ -54,6 +56,7 @@ import Utility.Env import Utility.Table import Utility.FileSystemEncoding +import Utility.Process -- | Allows a Property to access the value of a specific PrivDataField, -- for use in a specific Context or HostContext. @@ -106,9 +109,9 @@ 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 +124,14 @@ 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)) @@ -189,7 +195,8 @@ hClose th maybe noop (\p -> writeFileProtected' f (`L.hPut` privDataByteString p)) v editor <- getEnvDefault "EDITOR" "vi" - unlessM (boolSystem editor [File f]) $ + (_, _, _, ConcurrentProcessHandle p) <- createProcessForeground $ proc editor [f] + unlessM (checkSuccessProcess p) $ error "Editor failed; aborting." PrivData <$> readFile f setPrivDataTo field context v' @@ -207,7 +214,8 @@ showtable $ map mkrow missing section "How to set missing data:" - showSet $ map (\(f, c) -> (f, c, join $ M.lookup (f, c) descmap)) missing + mapM_ putStrLn $ showSet $ + map (\(f, c) -> (f, c, join $ M.lookup (f, c) descmap)) missing where header = ["Field", "Context", "Used by"] mkrow k@(field, Context context) = diff --git a/src/Propellor/PropAccum.hs b/src/Propellor/PropAccum.hs --- a/src/Propellor/PropAccum.hs +++ b/src/Propellor/PropAccum.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE PackageImports #-} +{-# LANGUAGE PackageImports, FlexibleContexts #-} module Propellor.PropAccum ( host @@ -46,7 +46,7 @@ (&^) = addPropFront -- | Adds a property in reverted form. -(!) :: PropAccum h => h -> RevertableProperty -> h +(!) :: IsProp (RevertableProperty i) => PropAccum h => h -> RevertableProperty i -> h h ! p = h & revert p infixl 1 & diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs --- a/src/Propellor/Property.hs +++ b/src/Propellor/Property.hs @@ -66,30 +66,43 @@ -- | Indicates that the first property depends on the second, -- so before the first is ensured, the second must be ensured. +-- +-- The combined property uses the description of the first property. requires :: Combines x y => x -> y -> CombinedType x y -requires = (<<>>) +requires = combineWith + -- Run action of y, then x + (flip (<>)) + -- When reverting, run in reverse order. + (<>) -- | Combines together two properties, resulting in one property -- that ensures the first, and if the first succeeds, ensures the second. -- -- The combined property uses the description of the first property. -before :: (IsProp x, Combines y x, IsProp (CombinedType y x)) => x -> y -> CombinedType y x -before x y = (y `requires` x) `describe` getDesc x +before :: Combines x y => x -> y -> CombinedType x y +before = combineWith + -- Run action of x, then y + (<>) + -- When reverting, run in reverse order. + (flip (<>)) -- | Whenever a change has to be made for a Property, causes a hook -- Property to also be run, but not otherwise. onChange - :: (Combines (Property x) (Property y)) - => Property x - -> Property y - -> CombinedType (Property x) (Property y) -onChange = combineWith $ \p hook -> do - r <- p - case r of - MadeChange -> do - r' <- hook - return $ r <> r' - _ -> return r + :: (Combines x y) + => x + -> y + -> CombinedType x y +onChange = combineWith combiner revertcombiner + where + combiner p hook = do + r <- p + case r of + MadeChange -> do + r' <- hook + return $ r <> r' + _ -> return r + revertcombiner = (<>) -- | Same as `onChange` except that if property y fails, a flag file -- is generated. On next run, if the flag file is present, property y @@ -99,14 +112,14 @@ -- `FailedChange`. But if this property is applied again, it returns -- `NoChange`. This behavior can cause trouble... onChangeFlagOnFail - :: (Combines (Property x) (Property y)) + :: (Combines x y) => FilePath - -> Property x - -> Property y - -> CombinedType (Property x) (Property y) -onChangeFlagOnFail flagfile = combineWith go + -> x + -> y + -> CombinedType x y +onChangeFlagOnFail flagfile = combineWith combiner revertcombiner where - go s1 s2 = do + combiner s1 s2 = do r1 <- s1 case r1 of MadeChange -> flagFailed s2 @@ -114,6 +127,7 @@ (flagFailed s2 , return r1 ) + revertcombiner = (<>) flagFailed s = do r <- s liftIO $ case r of @@ -151,12 +165,15 @@ -- | Tries the first property, but if it fails to work, instead uses -- the second. -fallback :: (Combines (Property p1) (Property p2)) => Property p1 -> Property p2 -> Property (CInfo p1 p2) -fallback = combineWith $ \a1 a2 -> do - r <- a1 - if r == FailedChange - then a2 - else return r +fallback :: (Combines p1 p2) => p1 -> p2 -> CombinedType p1 p2 +fallback = combineWith combiner revertcombiner + where + combiner a1 a2 = do + r <- a1 + if r == FailedChange + then a2 + else return r + revertcombiner = (<>) -- | Marks a Property as trivial. It can only return FailedChange or -- NoChange. @@ -184,7 +201,7 @@ withOS desc a = property desc $ a =<< getOS -- | Undoes the effect of a RevertableProperty. -revert :: RevertableProperty -> RevertableProperty +revert :: RevertableProperty i -> RevertableProperty i revert (RevertableProperty p1 p2) = RevertableProperty p2 p1 makeChange :: IO () -> Propellor Result diff --git a/src/Propellor/Property/Apache.hs b/src/Propellor/Property/Apache.hs --- a/src/Propellor/Property/Apache.hs +++ b/src/Propellor/Property/Apache.hs @@ -16,7 +16,7 @@ -- | 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 [ "" , "ServerName "++hn++":"++show p @@ -30,7 +30,7 @@ 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 @@ 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 --- a/src/Propellor/Property/Apt.hs +++ b/src/Propellor/Property/Apt.hs @@ -212,7 +212,7 @@ `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 @@ , 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 --- a/src/Propellor/Property/Chroot.hs +++ b/src/Propellor/Property/Chroot.hs @@ -31,6 +31,7 @@ import qualified Data.Map as M import Data.List.Utils import System.Posix.Directory +import System.Console.Concurrent -- | Specification of a chroot. Normally you'll use `debootstrapped` or -- `bootstrapped` to construct a Chroot value. @@ -116,10 +117,10 @@ -- Reverting this property removes the chroot. Anything mounted inside it -- is first unmounted. Note that it does not ensure that any processes -- that might be running inside the chroot are stopped. -provisioned :: Chroot -> RevertableProperty +provisioned :: Chroot -> RevertableProperty HasInfo provisioned c = provisioned' (propagateChrootInfo c) c False -provisioned' :: (Property HasInfo -> Property HasInfo) -> Chroot -> Bool -> RevertableProperty +provisioned' :: (Property HasInfo -> Property HasInfo) -> Chroot -> Bool -> RevertableProperty HasInfo provisioned' propigator c@(Chroot loc bootstrapper _) systemdonly = (propigator $ propertyList (chrootDesc c "exists") [setup]) @@ -193,7 +194,7 @@ toChain :: HostName -> Chroot -> Bool -> IO CmdLine toChain parenthost (Chroot loc _ _) systemdonly = do - onconsole <- isConsole <$> mkMessageHandle + onconsole <- isConsole <$> getMessageHandle return $ ChrootChain parenthost loc systemdonly onconsole chain :: [Host] -> CmdLine -> IO () @@ -213,6 +214,7 @@ then [Systemd.installed] else map ignoreInfo $ hostProperties h + flushConcurrentOutput putStrLn $ "\n" ++ show r chain _ _ = errorMessage "bad chain command" diff --git a/src/Propellor/Property/Cmd.hs b/src/Propellor/Property/Cmd.hs --- a/src/Propellor/Property/Cmd.hs +++ b/src/Propellor/Property/Cmd.hs @@ -16,6 +16,7 @@ safeSystemEnv, shellEscape, createProcess, + waitForProcess, ) where import Control.Applicative @@ -26,7 +27,7 @@ import Propellor.Property import Utility.SafeCommand import Utility.Env -import Utility.Process (createProcess, CreateProcess) +import Utility.Process (createProcess, CreateProcess, waitForProcess) -- | A property that can be satisfied by running a command. -- diff --git a/src/Propellor/Property/Concurrent.hs b/src/Propellor/Property/Concurrent.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/Property/Concurrent.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE FlexibleContexts #-} + +-- | 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, + concurrentSatisfy, +) where + +import Propellor.Base + +import Control.Concurrent +import qualified Control.Concurrent.Async as A +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 + -> p2 + -> CombinedType p1 p2 +concurrently p1 p2 = (combineWith go go p1 p2) + `describe` d + where + d = getDesc p1 ++ " `concurrently` " ++ getDesc p2 + -- Increase the number of capabilities right up to the number of + -- processors, so that A `concurrently` B `concurrently` C + -- runs all 3 properties on different processors when possible. + go a1 a2 = do + n <- liftIO getNumProcessors + withCapabilities n $ + concurrentSatisfy a1 a2 + +-- | Ensures all the properties in the list, with a specified amount of +-- concurrency. +-- +-- > concurrentList (pure 2) "demo" $ props +-- > & foo +-- > & bar +-- > & baz +-- +-- The above example will run foo and bar concurrently, and once either of +-- those 2 properties finishes, will start running baz. +concurrentList :: IO Int -> Desc -> PropList -> Property HasInfo +concurrentList getn d (PropList ps) = infoProperty d go mempty ps + where + go = do + n <- liftIO getn + withCapabilities n $ + startworkers n =<< liftIO (newMVar ps) + startworkers n q + | n < 1 = return NoChange + | n == 1 = worker q NoChange + | otherwise = + worker q NoChange + `concurrentSatisfy` + startworkers (n-1) q + worker q r = do + v <- liftIO $ modifyMVar q $ \v -> case v of + [] -> return ([], Nothing) + (p:rest) -> return (rest, Just p) + case v of + Nothing -> return r + -- This use of propertySatisfy does not lose any + -- Info asociated with the property, because + -- concurrentList sets all the properties as + -- children, and so propigates their info. + Just p -> do + hn <- asks hostName + r' <- actionMessageOn hn + (propertyDesc p) + (propertySatisfy p) + worker q (r <> r') + +-- | Run an action with the number of capabiities increased as necessary to +-- allow running on the specified number of cores. +-- +-- Never increases the number of capabilities higher than the actual number +-- of processors. +withCapabilities :: Int -> Propellor a -> Propellor a +withCapabilities n a = bracket setup cleanup (const a) + where + setup = do + np <- liftIO getNumProcessors + let n' = min n np + c <- liftIO getNumCapabilities + when (n' > c) $ + liftIO $ setNumCapabilities n' + return c + cleanup = liftIO . setNumCapabilities + +-- | Running Propellor actions concurrently. +concurrentSatisfy :: Propellor Result -> Propellor Result -> Propellor Result +concurrentSatisfy a1 a2 = do + h <- ask + ((r1, w1), (r2, w2)) <- liftIO $ + runp a1 h `A.concurrently` runp a2 h + tell (w1 <> w2) + return (r1 <> r2) + where + runp a h = evalRWST (runWithHost (catchPropellor a)) h () diff --git a/src/Propellor/Property/Conductor.hs b/src/Propellor/Property/Conductor.hs --- a/src/Propellor/Property/Conductor.hs +++ b/src/Propellor/Property/Conductor.hs @@ -83,7 +83,7 @@ -- | 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 @@ where desc = "not " ++ cdesc (hostName h) -conductorKnownHost :: Host -> RevertableProperty +conductorKnownHost :: Host -> RevertableProperty NoInfo conductorKnownHost h = mk Ssh.knownHost @@ -290,7 +290,7 @@ 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 --- a/src/Propellor/Property/Debootstrap.hs +++ b/src/Propellor/Property/Debootstrap.hs @@ -98,7 +98,7 @@ -- 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 --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -69,16 +69,16 @@ -- 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 @@ & 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 --- a/src/Propellor/Property/Dns.hs +++ b/src/Propellor/Property/Dns.hs @@ -60,7 +60,7 @@ -- -- 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 @@ -- 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)") @@ -164,7 +164,7 @@ `onChange` Service.reloaded "bind9" cleanup = cleanupPrimary zonefile domain - `onChange` toProp (revert (zoneSigned domain zonefile)) + `onChange` revert (zoneSigned domain zonefile) `onChange` Service.reloaded "bind9" -- Include the public keys into the zone file. @@ -184,12 +184,12 @@ -- -- 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 --- a/src/Propellor/Property/DnsSec.hs +++ b/src/Propellor/Property/DnsSec.hs @@ -7,7 +7,7 @@ -- -- 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,15 +37,15 @@ -- -- 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) - `requires` toProp (keysInstalled domain) + `requires` keysInstalled domain cleanup = File.notPresent (signedZoneFile zonefile) `before` File.notPresent dssetfile - `before` toProp (revert (keysInstalled domain)) + `before` revert (keysInstalled domain) dssetfile = dir "-" ++ domain ++ "." dir = takeDirectory zonefile diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs --- a/src/Propellor/Property/Docker.hs +++ b/src/Propellor/Property/Docker.hs @@ -64,6 +64,7 @@ import Data.List hiding (init) import Data.List.Utils import qualified Data.Map as M +import System.Console.Concurrent installed :: Property NoInfo installed = Apt.installed ["docker.io"] @@ -123,7 +124,7 @@ -- -- Reverting this property ensures that the container is stopped and -- removed. -docked :: Container -> RevertableProperty +docked :: Container -> RevertableProperty HasInfo docked ctr@(Container _ h) = (propagateContainerInfo ctr (go "docked" setup)) @@ -540,6 +541,7 @@ warningMessage "Boot provision failed!" void $ async $ job reapzombies job $ do + flushConcurrentOutput void $ tryIO $ ifM (inPath "bash") ( boolSystem "bash" [Param "-l"] , boolSystem "/bin/sh" [] @@ -555,7 +557,7 @@ provisionContainer cid = containerDesc cid $ property "provisioned" $ liftIO $ do let shim = Shim.file (localdir "propellor") (localdir shimdir cid) let params = ["--continue", show $ toChain cid] - msgh <- mkMessageHandle + msgh <- getMessageHandle let p = inContainerProcess cid (if isConsole msgh then ["-it"] else []) (shim : params) @@ -583,6 +585,7 @@ r <- runPropellor h $ ensureProperties $ map ignoreInfo $ hostProperties h + flushConcurrentOutput putStrLn $ "\n" ++ show r stopContainer :: ContainerId -> IO Bool diff --git a/src/Propellor/Property/File.hs b/src/Propellor/Property/File.hs --- a/src/Propellor/Property/File.hs +++ b/src/Propellor/Property/File.hs @@ -5,6 +5,7 @@ import System.Posix.Files import System.PosixCompat.Types +import System.Exit type Line = String @@ -133,6 +134,27 @@ then noChange else makeChange updateLink updateLink = createSymbolicLink target `viaStableTmp` link + +-- | Ensures that a file is a copy of another (regular) file. +isCopyOf :: FilePath -> FilePath -> Property NoInfo +f `isCopyOf` f' = property desc $ go =<< (liftIO $ tryIO $ getFileStatus f') + where + desc = f ++ " is copy of " ++ f' + go (Right stat) = if isRegularFile stat + then gocmp =<< (liftIO $ cmp) + else warningMessage (f' ++ " is not a regular file") >> + return FailedChange + go (Left e) = warningMessage (show e) >> return FailedChange + + cmp = safeSystem "cmp" [Param "-s", Param "--", File f, File f'] + gocmp ExitSuccess = noChange + gocmp (ExitFailure 1) = doit + gocmp _ = warningMessage "cmp failed" >> return FailedChange + + doit = makeChange $ copy f' `viaStableTmp` f + copy src dest = unlessM (runcp src dest) $ errorMessage "cp failed" + runcp src dest = boolSystem "cp" + [Param "--preserve=all", Param "--", File src, File dest] -- | Ensures that a file/dir has the specified owner and group. ownerGroup :: FilePath -> User -> Group -> Property NoInfo diff --git a/src/Propellor/Property/Git.hs b/src/Propellor/Property/Git.hs --- a/src/Propellor/Property/Git.hs +++ b/src/Propellor/Property/Git.hs @@ -11,7 +11,7 @@ -- 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/List.hs b/src/Propellor/Property/List.hs --- a/src/Propellor/Property/List.hs +++ b/src/Propellor/Property/List.hs @@ -5,6 +5,7 @@ props, PropertyList(..), PropertyListType, + PropList(..), ) where import Propellor.Types diff --git a/src/Propellor/Property/Nginx.hs b/src/Propellor/Property/Nginx.hs --- a/src/Propellor/Property/Nginx.hs +++ b/src/Propellor/Property/Nginx.hs @@ -9,7 +9,7 @@ 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 --- a/src/Propellor/Property/Prosody.hs +++ b/src/Propellor/Property/Prosody.hs @@ -11,7 +11,7 @@ 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 --- a/src/Propellor/Property/SiteSpecific/JoeySites.hs +++ b/src/Propellor/Property/SiteSpecific/JoeySites.hs @@ -298,7 +298,7 @@ , " " ] -apacheSite :: HostName -> Bool -> Apache.ConfigFile -> RevertableProperty +apacheSite :: HostName -> Bool -> Apache.ConfigFile -> RevertableProperty NoInfo apacheSite hn withssl middle = Apache.siteEnabled hn $ apachecfg hn withssl middle apachecfg :: HostName -> Bool -> Apache.ConfigFile -> Apache.ConfigFile @@ -738,7 +738,7 @@ -- This value can be included in a domain's additional records to make -- it use this domainkey. domainKey :: (BindDomain, Record) -domainKey = (RelDomain "mail._domainkey", TXT "v=DKIM1; k=rsa; t=y; p=MIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKBgQCc+/rfzNdt5DseBBmfB3C6sVM7FgVvf4h1FeCfyfwPpVcmPdW6M2I+NtJsbRkNbEICxiP6QY2UM0uoo9TmPqLgiCCG2vtuiG6XMsS0Y/gGwqKM7ntg/7vT1Go9vcquOFFuLa5PnzpVf8hB9+PMFdS4NPTvWL2c5xxshl/RJzICnQIDAQAB") +domainKey = (RelDomain "mail._domainkey", TXT "v=DKIM1; k=rsa; p=MIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKBgQCc+/rfzNdt5DseBBmfB3C6sVM7FgVvf4h1FeCfyfwPpVcmPdW6M2I+NtJsbRkNbEICxiP6QY2UM0uoo9TmPqLgiCCG2vtuiG6XMsS0Y/gGwqKM7ntg/7vT1Go9vcquOFFuLa5PnzpVf8hB9+PMFdS4NPTvWL2c5xxshl/RJzICnQIDAQAB") hasJoeyCAChain :: Property HasInfo hasJoeyCAChain = "/etc/ssl/certs/joeyca.pem" `File.hasPrivContentExposed` @@ -921,10 +921,10 @@ , "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` (toProp $ Apache.modEnabled "userdir") + `requires` Apache.modEnabled "userdir" where munge = replace "public_html" "html" conf = "/etc/apache2/mods-available/userdir.conf" diff --git a/src/Propellor/Property/Ssh.hs b/src/Propellor/Property/Ssh.hs --- a/src/Propellor/Property/Ssh.hs +++ b/src/Propellor/Property/Ssh.hs @@ -115,7 +115,7 @@ -- 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 --- a/src/Propellor/Property/Systemd.hs +++ b/src/Propellor/Property/Systemd.hs @@ -93,7 +93,7 @@ `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 @@ -- -- 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 @@ -- | 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 @@ -- -- 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 @@ -- 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 @@ -- | Bind mounts 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 @@ -- > & 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 @@ 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 --- a/src/Propellor/Property/Uwsgi.hs +++ b/src/Propellor/Property/Uwsgi.hs @@ -11,7 +11,7 @@ type AppName = String -appEnabled :: AppName -> ConfigFile -> RevertableProperty +appEnabled :: AppName -> ConfigFile -> RevertableProperty NoInfo appEnabled an cf = enable disable where enable = appVal an `File.isSymlinkedTo` appValRelativeCfg an diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs --- a/src/Propellor/Spin.hs +++ b/src/Propellor/Spin.hs @@ -33,7 +33,8 @@ commitSpin :: IO () commitSpin = do void $ actionMessage "Git commit" $ - gitCommit [Param "--allow-empty", Param "-a", Param "-m", Param spinCommitMessage] + gitCommit (Just spinCommitMessage) + [Param "--allow-empty", Param "-a"] -- Push to central origin repo first, if possible. -- The remote propellor will pull from there, which avoids -- us needing to send stuff directly to the remote host. @@ -60,7 +61,7 @@ updateServer target relay hst (proc "ssh" $ cacheparams ++ [sshtarget, shellWrap probecmd]) (proc "ssh" $ cacheparams ++ [sshtarget, shellWrap updatecmd]) - getprivdata + =<< getprivdata -- And now we can run it. unlessM (boolSystem "ssh" (map Param $ cacheparams ++ ["-t", sshtarget, shellWrap runcmd])) $ @@ -189,16 +190,16 @@ -> Host -> CreateProcess -> CreateProcess - -> IO PrivMap + -> PrivMap -> IO () -updateServer target relay hst connect haveprecompiled getprivdata = +updateServer target relay hst connect haveprecompiled privdata = withIOHandles createProcessSuccess connect go where hn = fromMaybe target relay go (toh, fromh) = do let loop = go (toh, fromh) - let restart = updateServer hn relay hst connect haveprecompiled getprivdata + let restart = updateServer hn relay hst connect haveprecompiled privdata let done = return () v <- maybe Nothing readish <$> getMarked fromh statusMarker case v of @@ -206,7 +207,7 @@ sendRepoUrl toh loop (Just NeedPrivData) -> do - sendPrivData hn toh =<< getprivdata + sendPrivData hn toh privdata loop (Just NeedGitClone) -> do hClose toh @@ -217,7 +218,7 @@ hClose toh hClose fromh sendPrecompiled hn - updateServer hn relay hst haveprecompiled (error "loop") getprivdata + updateServer hn relay hst haveprecompiled (error "loop") privdata (Just NeedGitPush) -> do sendGitUpdate hn fromh toh hClose fromh @@ -336,8 +337,9 @@ old_head <- getCurrentGitSha1 branch old_commit <- findLastNonSpinCommit rungit "reset" [Param old_commit] - rungit "commit" [Param "-a", Param "--allow-empty"] - rungit "merge" =<< gpgSignParams [Param "-s", Param "ours", Param old_head] + unlessM (gitCommit Nothing [Param "-a", Param "--allow-empty"]) $ + error "git commit failed" + rungit "merge" =<< gpgSignParams [Param "-s", Param "ours", Param old_head, Param "--no-edit"] current_commit <- getCurrentGitSha1 branch rungit "update-ref" [Param branchref, Param current_commit] rungit "checkout" [Param branch] diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs --- a/src/Propellor/Types.hs +++ b/src/Propellor/Types.hs @@ -27,7 +27,6 @@ , IsProp(..) , Combines(..) , CombinedType - , combineWith , Propellor(..) , LiftPropellor(..) , EndAction(..) @@ -157,9 +156,6 @@ propertySatisfy (IProperty _ a _ _) = a propertySatisfy (SProperty _ a _) = a -instance Show (Property i) where - show p = "property " ++ show (propertyDesc p) - -- | Changes the action that is performed to satisfy a property. adjustPropertySatisfy :: Property i -> (Propellor Result -> Propellor Result) -> Property i adjustPropertySatisfy (IProperty d s i cs) f = IProperty d (f s) i cs @@ -173,6 +169,9 @@ propertyDesc (IProperty d _ _ _) = d propertyDesc (SProperty d _ _) = d +instance Show (Property i) where + show p = "property " ++ show (propertyDesc p) + -- | A Property can include a list of child properties that it also -- satisfies. This allows them to be introspected to collect their info, etc. propertyChildren :: Property i -> [Property i] @@ -181,12 +180,24 @@ -- | A property that can be reverted. The first Property is run -- normally and the second is run when it's reverted. -data RevertableProperty = RevertableProperty (Property HasInfo) (Property HasInfo) +data RevertableProperty i = RevertableProperty (Property i) (Property i) --- | Shorthand to construct a revertable property. -() :: Property i1 -> Property i2 -> RevertableProperty -p1 p2 = RevertableProperty (toIProperty p1) (toIProperty p2) +instance Show (RevertableProperty i) where + show (RevertableProperty p _) = show p +class MkRevertableProperty i1 i2 where + -- | Shorthand to construct a revertable property. + () :: Property i1 -> Property i2 -> RevertableProperty (CInfo i1 i2) + +instance MkRevertableProperty HasInfo HasInfo where + x y = RevertableProperty x y +instance MkRevertableProperty NoInfo NoInfo where + x y = RevertableProperty x y +instance MkRevertableProperty NoInfo HasInfo where + x y = RevertableProperty (toProp x) y +instance MkRevertableProperty HasInfo NoInfo where + x y = RevertableProperty x (toProp y) + -- | Class of types that can be used as properties of a host. class IsProp p where setDesc :: p -> Desc -> p @@ -208,70 +219,116 @@ getDesc = propertyDesc getInfoRecursive _ = mempty -instance IsProp RevertableProperty where - -- | Sets the description of both sides. - setDesc (RevertableProperty p1 p2) d = - RevertableProperty (setDesc p1 d) (setDesc p2 ("not " ++ d)) +instance IsProp (RevertableProperty HasInfo) where + setDesc = setDescR getDesc (RevertableProperty p1 _) = getDesc p1 toProp (RevertableProperty p1 _) = p1 -- | Return the Info of the currently active side. getInfoRecursive (RevertableProperty p1 _p2) = getInfoRecursive p1 +instance IsProp (RevertableProperty NoInfo) where + setDesc = setDescR + getDesc (RevertableProperty p1 _) = getDesc p1 + toProp (RevertableProperty p1 _) = toProp p1 + getInfoRecursive (RevertableProperty _ _) = mempty +-- | Sets the description of both sides. +setDescR :: IsProp (Property i) => RevertableProperty i -> Desc -> RevertableProperty i +setDescR (RevertableProperty p1 p2) d = + RevertableProperty (setDesc p1 d) (setDesc p2 ("not " ++ d)) + -- | Type level calculation of the type that results from combining two -- types of properties. type family CombinedType x y type instance CombinedType (Property x) (Property y) = Property (CInfo x y) -type instance CombinedType RevertableProperty (Property NoInfo) = RevertableProperty -type instance CombinedType RevertableProperty (Property HasInfo) = RevertableProperty -type instance CombinedType RevertableProperty RevertableProperty = RevertableProperty +type instance CombinedType (RevertableProperty x) (RevertableProperty y) = RevertableProperty (CInfo x y) +-- When only one of the properties is revertable, the combined property is +-- not fully revertable, so is not a RevertableProperty. +type instance CombinedType (RevertableProperty x) (Property y) = Property (CInfo x y) +type instance CombinedType (Property x) (RevertableProperty y) = Property (CInfo x y) -class Combines x y where - -- | Combines two properties. The second property is ensured - -- first, and only once it is successfully ensures will the first - -- be ensured. The combined property will have the description of - -- the first property. - (<<>>) :: x -> y -> CombinedType x y +type ResultCombiner = Propellor Result -> Propellor Result -> Propellor Result --- | Combines together two properties, yielding a property that --- has the description and info of the first, and that has the second --- property as a child. The two actions to satisfy the properties --- are passed to a function that can combine them in arbitrary ways. -combineWith - :: (Combines (Property x) (Property y)) - => (Propellor Result -> Propellor Result -> Propellor Result) - -> Property x - -> Property y - -> CombinedType (Property x) (Property y) -combineWith f x y = adjustPropertySatisfy (x <<>> y) $ \_ -> - f (propertySatisfy $ toSProperty x) (propertySatisfy $ toSProperty y) +class Combines x y where + -- | Combines together two properties, yielding a property that + -- has the description and info of the first, and that has the second + -- property as a child. + combineWith + :: ResultCombiner + -- ^ How to combine the actions to satisfy the properties. + -> ResultCombiner + -- ^ Used when combining revertable properties, to combine + -- their reversion actions. + -> x + -> y + -> CombinedType x y instance Combines (Property HasInfo) (Property HasInfo) where - (IProperty d1 a1 i1 cs1) <<>> y@(IProperty _d2 a2 _i2 _cs2) = - IProperty d1 (a2 <> a1) i1 (y : cs1) + combineWith f _ (IProperty d1 a1 i1 cs1) y@(IProperty _d2 a2 _i2 _cs2) = + IProperty d1 (f a1 a2) i1 (y : cs1) instance Combines (Property HasInfo) (Property NoInfo) where - (IProperty d1 a1 i1 cs1) <<>> y@(SProperty _d2 a2 _cs2) = - IProperty d1 (a2 <> a1) i1 (toIProperty y : cs1) + combineWith f _ (IProperty d1 a1 i1 cs1) y@(SProperty _d2 a2 _cs2) = + IProperty d1 (f a1 a2) i1 (toIProperty y : cs1) instance Combines (Property NoInfo) (Property HasInfo) where - (SProperty d1 a1 cs1) <<>> y@(IProperty _d2 a2 _i2 _cs2) = - IProperty d1 (a2 <> a1) mempty (y : map toIProperty cs1) + combineWith f _ (SProperty d1 a1 cs1) y@(IProperty _d2 a2 _i2 _cs2) = + IProperty d1 (f a1 a2) mempty (y : map toIProperty cs1) instance Combines (Property NoInfo) (Property NoInfo) where - (SProperty d1 a1 cs1) <<>> y@(SProperty _d2 a2 _cs2) = - SProperty d1 (a2 <> a1) (y : cs1) + combineWith f _ (SProperty d1 a1 cs1) y@(SProperty _d2 a2 _cs2) = + SProperty d1 (f a1 a2) (y : cs1) -instance Combines RevertableProperty (Property HasInfo) where - (RevertableProperty p1 p2) <<>> y = - RevertableProperty (p1 <<>> y) p2 +instance Combines (RevertableProperty NoInfo) (RevertableProperty NoInfo) where + combineWith = combineWithRR +instance Combines (RevertableProperty HasInfo) (RevertableProperty HasInfo) where + combineWith = combineWithRR +instance Combines (RevertableProperty HasInfo) (RevertableProperty NoInfo) where + combineWith = combineWithRR +instance Combines (RevertableProperty NoInfo) (RevertableProperty HasInfo) where + combineWith = combineWithRR +instance Combines (RevertableProperty NoInfo) (Property HasInfo) where + combineWith = combineWithRP +instance Combines (RevertableProperty NoInfo) (Property NoInfo) where + combineWith = combineWithRP +instance Combines (RevertableProperty HasInfo) (Property HasInfo) where + combineWith = combineWithRP +instance Combines (RevertableProperty HasInfo) (Property NoInfo) where + combineWith = combineWithRP +instance Combines (Property HasInfo) (RevertableProperty NoInfo) where + combineWith = combineWithPR +instance Combines (Property NoInfo) (RevertableProperty NoInfo) where + combineWith = combineWithPR +instance Combines (Property HasInfo) (RevertableProperty HasInfo) where + combineWith = combineWithPR +instance Combines (Property NoInfo) (RevertableProperty HasInfo) where + combineWith = combineWithPR -instance Combines RevertableProperty (Property NoInfo) where - (RevertableProperty p1 p2) <<>> y = - RevertableProperty (p1 <<>> toIProperty y) p2 +combineWithRR + :: Combines (Property x) (Property y) + => ResultCombiner + -> ResultCombiner + -> RevertableProperty x + -> RevertableProperty y + -> RevertableProperty (CInfo x y) +combineWithRR sf tf (RevertableProperty s1 t1) (RevertableProperty s2 t2) = + RevertableProperty + (combineWith sf tf s1 s2) + (combineWith tf sf t1 t2) -instance Combines RevertableProperty RevertableProperty where - (RevertableProperty x1 x2) <<>> (RevertableProperty y1 y2) = - RevertableProperty - (x1 <<>> y1) - -- when reverting, run actions in reverse order - (y2 <<>> x2) +combineWithRP + :: Combines (Property i) y + => (Propellor Result -> Propellor Result -> Propellor Result) + -> (Propellor Result -> Propellor Result -> Propellor Result) + -> RevertableProperty i + -> y + -> CombinedType (Property i) y +combineWithRP sf tf (RevertableProperty x _) y = combineWith sf tf x y + +combineWithPR + :: Combines x (Property i) + => (Propellor Result -> Propellor Result -> Propellor Result) + -> (Propellor Result -> Propellor Result -> Propellor Result) + -> x + -> RevertableProperty i + -> CombinedType x (Property i) +combineWithPR sf tf x (RevertableProperty y _) = combineWith sf tf x y diff --git a/src/System/Console/Concurrent.hs b/src/System/Console/Concurrent.hs new file mode 100644 --- /dev/null +++ b/src/System/Console/Concurrent.hs @@ -0,0 +1,44 @@ +-- | +-- Copyright: 2015 Joey Hess +-- License: BSD-2-clause +-- +-- Concurrent output handling. +-- +-- > import Control.Concurrent.Async +-- > import System.Console.Concurrent +-- > +-- > main = withConcurrentOutput $ +-- > outputConcurrent "washed the car\n" +-- > `concurrently` +-- > outputConcurrent "walked the dog\n" +-- > `concurrently` +-- > createProcessConcurrent (proc "ls" []) + +{-# LANGUAGE CPP #-} + +module System.Console.Concurrent ( + -- * Concurrent output + withConcurrentOutput, + Outputable(..), + outputConcurrent, + errorConcurrent, + ConcurrentProcessHandle, +#ifndef mingw32_HOST_OS + createProcessConcurrent, +#endif + waitForProcessConcurrent, + createProcessForeground, + flushConcurrentOutput, + lockOutput, + -- * Low level access to the output buffer + OutputBuffer, + StdHandle(..), + bufferOutputSTM, + outputBufferWaiterSTM, + waitAnyBuffer, + waitCompleteLines, + emitOutputBuffer, +) where + +import System.Console.Concurrent.Internal + diff --git a/src/System/Console/Concurrent/Internal.hs b/src/System/Console/Concurrent/Internal.hs new file mode 100644 --- /dev/null +++ b/src/System/Console/Concurrent/Internal.hs @@ -0,0 +1,538 @@ +{-# LANGUAGE BangPatterns, TypeSynonymInstances, FlexibleInstances, TupleSections #-} +{-# LANGUAGE CPP #-} + +-- | +-- Copyright: 2015 Joey Hess +-- License: BSD-2-clause +-- +-- Concurrent output handling, internals. +-- +-- May change at any time. + +module System.Console.Concurrent.Internal where + +import System.IO +#ifndef mingw32_HOST_OS +import System.Posix.IO +#endif +import System.Directory +import System.Exit +import Control.Monad +import Control.Monad.IO.Class (liftIO, MonadIO) +import Control.Applicative +import System.IO.Unsafe (unsafePerformIO) +import Control.Concurrent +import Control.Concurrent.STM +import Control.Concurrent.Async +import Data.Maybe +import Data.List +import Data.Monoid +import qualified System.Process as P +import qualified Data.Text as T +import qualified Data.Text.IO as T + +import Utility.Monad +import Utility.Exception + +data OutputHandle = OutputHandle + { outputLock :: TMVar Lock + , outputBuffer :: TMVar OutputBuffer + , errorBuffer :: TMVar OutputBuffer + , outputThreads :: TMVar Integer + , processWaiters :: TMVar [Async ()] + , waitForProcessLock :: TMVar () + } + +data Lock = Locked + +-- | A shared global variable for the OutputHandle. +{-# NOINLINE globalOutputHandle #-} +globalOutputHandle :: OutputHandle +globalOutputHandle = unsafePerformIO $ OutputHandle + <$> newEmptyTMVarIO + <*> newTMVarIO (OutputBuffer []) + <*> newTMVarIO (OutputBuffer []) + <*> newTMVarIO 0 + <*> newTMVarIO [] + <*> newEmptyTMVarIO + +-- | Holds a lock while performing an action. This allows the action to +-- perform its own output to the console, without using functions from this +-- module. +-- +-- While this is running, other threads that try to lockOutput will block. +-- Any calls to `outputConcurrent` and `createProcessConcurrent` will not +-- block, but the output will be buffered and displayed only once the +-- action is done. +lockOutput :: (MonadIO m, MonadMask m) => m a -> m a +lockOutput = bracket_ (liftIO takeOutputLock) (liftIO dropOutputLock) + +-- | Blocks until we have the output lock. +takeOutputLock :: IO () +takeOutputLock = void $ takeOutputLock' True + +-- | Tries to take the output lock, without blocking. +tryTakeOutputLock :: IO Bool +tryTakeOutputLock = takeOutputLock' False + +withLock :: (TMVar Lock -> STM a) -> IO a +withLock a = atomically $ a (outputLock globalOutputHandle) + +takeOutputLock' :: Bool -> IO Bool +takeOutputLock' block = do + locked <- withLock $ \l -> do + v <- tryTakeTMVar l + case v of + Just Locked + | block -> retry + | otherwise -> do + -- Restore value we took. + putTMVar l Locked + return False + Nothing -> do + putTMVar l Locked + return True + when locked $ do + (outbuf, errbuf) <- atomically $ (,) + <$> swapTMVar (outputBuffer globalOutputHandle) (OutputBuffer []) + <*> swapTMVar (errorBuffer globalOutputHandle) (OutputBuffer []) + emitOutputBuffer StdOut outbuf + emitOutputBuffer StdErr errbuf + return locked + +-- | Only safe to call after taking the output lock. +dropOutputLock :: IO () +dropOutputLock = withLock $ void . takeTMVar + +-- | Use this around any actions that use `outputConcurrent` +-- or `createProcessConcurrent` +-- +-- This is necessary to ensure that buffered concurrent output actually +-- gets displayed before the program exits. +withConcurrentOutput :: (MonadIO m, MonadMask m) => m a -> m a +withConcurrentOutput a = a `finally` liftIO flushConcurrentOutput + +-- | Blocks until any processes started by `createProcessConcurrent` have +-- finished, and any buffered output is displayed. +-- +-- `withConcurrentOutput` calls this at the end; you can call it anytime +-- you want to flush output. +flushConcurrentOutput :: IO () +flushConcurrentOutput = do + -- Wait for all outputThreads to finish. + let v = outputThreads globalOutputHandle + atomically $ do + r <- takeTMVar v + if r <= 0 + then putTMVar v r + else retry + -- Take output lock to ensure that nothing else is currently + -- generating output, and flush any buffered output. + lockOutput $ return () + +-- | Values that can be output. +class Outputable v where + toOutput :: v -> T.Text + +instance Outputable T.Text where + toOutput = id + +instance Outputable String where + toOutput = toOutput . T.pack + +-- | Displays a value to stdout. +-- +-- No newline is appended to the value, so if you want a newline, be sure +-- to include it yourself. +-- +-- Uses locking to ensure that the whole output occurs atomically +-- even when other threads are concurrently generating output. +-- +-- When something else is writing to the console at the same time, this does +-- not block. It buffers the value, so it will be displayed once the other +-- writer is done. +outputConcurrent :: Outputable v => v -> IO () +outputConcurrent = outputConcurrent' StdOut + +-- | Like `outputConcurrent`, but displays to stderr. +-- +-- (Does not throw an exception.) +errorConcurrent :: Outputable v => v -> IO () +errorConcurrent = outputConcurrent' StdErr + +outputConcurrent' :: Outputable v => StdHandle -> v -> IO () +outputConcurrent' stdh v = bracket setup cleanup go + where + setup = tryTakeOutputLock + cleanup False = return () + cleanup True = dropOutputLock + go True = do + T.hPutStr h (toOutput v) + hFlush h + go False = do + oldbuf <- atomically $ takeTMVar bv + newbuf <- addOutputBuffer (Output (toOutput v)) oldbuf + atomically $ putTMVar bv newbuf + h = toHandle stdh + bv = bufferFor stdh + +newtype ConcurrentProcessHandle = ConcurrentProcessHandle P.ProcessHandle + +toConcurrentProcessHandle :: (Maybe Handle, Maybe Handle, Maybe Handle, P.ProcessHandle) -> (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle) +toConcurrentProcessHandle (i, o, e, h) = (i, o, e, ConcurrentProcessHandle h) + +-- | Use this to wait for processes started with +-- `createProcessConcurrent` and `createProcessForeground`, and get their +-- exit status. +-- +-- Note that such processes are actually automatically waited for +-- internally, so not calling this explicitly will not result +-- in zombie processes. This behavior differs from `P.waitForProcess` +waitForProcessConcurrent :: ConcurrentProcessHandle -> IO ExitCode +waitForProcessConcurrent (ConcurrentProcessHandle h) = + bracket lock unlock checkexit + where + lck = waitForProcessLock globalOutputHandle + lock = atomically $ tryPutTMVar lck () + unlock True = atomically $ takeTMVar lck + unlock False = return () + checkexit locked = maybe (waitsome locked) return + =<< P.getProcessExitCode h + waitsome True = do + let v = processWaiters globalOutputHandle + l <- atomically $ readTMVar v + if null l + -- Avoid waitAny [] which blocks forever + then P.waitForProcess h + else do + -- Wait for any of the running + -- processes to exit. It may or may not + -- be the one corresponding to the + -- ProcessHandle. If it is, + -- getProcessExitCode will succeed. + void $ tryIO $ waitAny l + checkexit True + waitsome False = do + -- Another thread took the lck first. Wait for that thread to + -- wait for one of the running processes to exit. + atomically $ do + putTMVar lck () + takeTMVar lck + checkexit False + +-- Registers an action that waits for a process to exit, +-- adding it to the processWaiters list, and removing it once the action +-- completes. +asyncProcessWaiter :: IO () -> IO () +asyncProcessWaiter waitaction = do + regdone <- newEmptyTMVarIO + waiter <- async $ do + self <- atomically (takeTMVar regdone) + waitaction `finally` unregister self + register waiter regdone + where + v = processWaiters globalOutputHandle + register waiter regdone = atomically $ do + l <- takeTMVar v + putTMVar v (waiter:l) + putTMVar regdone waiter + unregister waiter = atomically $ do + l <- takeTMVar v + putTMVar v (filter (/= waiter) l) + +-- | Wrapper around `System.Process.createProcess` that prevents +-- multiple processes that are running concurrently from writing +-- to stdout/stderr at the same time. +-- +-- If the process does not output to stdout or stderr, it's run +-- by createProcess entirely as usual. Only processes that can generate +-- output are handled specially: +-- +-- A process is allowed to write to stdout and stderr in the usual +-- way, assuming it can successfully take the output lock. +-- +-- When the output lock is held (ie, by another concurrent process, +-- or because `outputConcurrent` is being called at the same time), +-- the process is instead run with its stdout and stderr +-- redirected to a buffer. The buffered output will be displayed as soon +-- as the output lock becomes free. +-- +-- Currently only available on Unix systems, not Windows. +#ifndef mingw32_HOST_OS +createProcessConcurrent :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle) +createProcessConcurrent p + | willOutput (P.std_out p) || willOutput (P.std_err p) = + ifM tryTakeOutputLock + ( fgProcess p + , bgProcess p + ) + | otherwise = do + r@(_, _, _, h) <- P.createProcess p + asyncProcessWaiter $ + void $ tryIO $ P.waitForProcess h + return (toConcurrentProcessHandle r) +#endif + +-- | Wrapper around `System.Process.createProcess` that makes sure a process +-- is run in the foreground, with direct access to stdout and stderr. +-- Useful when eg, running an interactive process. +createProcessForeground :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle) +createProcessForeground p = do + takeOutputLock + fgProcess p + +fgProcess :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle) +fgProcess p = do + r@(_, _, _, h) <- P.createProcess p + `onException` dropOutputLock + -- Wait for the process to exit and drop the lock. + asyncProcessWaiter $ do + void $ tryIO $ P.waitForProcess h + dropOutputLock + return (toConcurrentProcessHandle r) + +#ifndef mingw32_HOST_OS +bgProcess :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle) +bgProcess p = do + (toouth, fromouth) <- pipe + (toerrh, fromerrh) <- pipe + let p' = p + { P.std_out = rediroutput (P.std_out p) toouth + , P.std_err = rediroutput (P.std_err p) toerrh + } + registerOutputThread + r@(_, _, _, h) <- P.createProcess p' + `onException` unregisterOutputThread + asyncProcessWaiter $ void $ tryIO $ P.waitForProcess h + outbuf <- setupOutputBuffer StdOut toouth (P.std_out p) fromouth + errbuf <- setupOutputBuffer StdErr toerrh (P.std_err p) fromerrh + void $ async $ bufferWriter [outbuf, errbuf] + return (toConcurrentProcessHandle r) + where + pipe = do + (from, to) <- createPipe + (,) <$> fdToHandle to <*> fdToHandle from + rediroutput ss h + | willOutput ss = P.UseHandle h + | otherwise = ss +#endif + +willOutput :: P.StdStream -> Bool +willOutput P.Inherit = True +willOutput _ = False + +-- | Buffered output. +data OutputBuffer = OutputBuffer [OutputBufferedActivity] + deriving (Eq) + +data StdHandle = StdOut | StdErr + +toHandle :: StdHandle -> Handle +toHandle StdOut = stdout +toHandle StdErr = stderr + +bufferFor :: StdHandle -> TMVar OutputBuffer +bufferFor StdOut = outputBuffer globalOutputHandle +bufferFor StdErr = errorBuffer globalOutputHandle + +data OutputBufferedActivity + = Output T.Text + | InTempFile + { tempFile :: FilePath + , endsInNewLine :: Bool + } + deriving (Eq) + +data AtEnd = AtEnd + deriving Eq + +data BufSig = BufSig + +setupOutputBuffer :: StdHandle -> Handle -> P.StdStream -> Handle -> IO (StdHandle, MVar OutputBuffer, TMVar BufSig, TMVar AtEnd) +setupOutputBuffer h toh ss fromh = do + hClose toh + buf <- newMVar (OutputBuffer []) + bufsig <- atomically newEmptyTMVar + bufend <- atomically newEmptyTMVar + void $ async $ outputDrainer ss fromh buf bufsig bufend + return (h, buf, bufsig, bufend) + +-- Drain output from the handle, and buffer it. +outputDrainer :: P.StdStream -> Handle -> MVar OutputBuffer -> TMVar BufSig -> TMVar AtEnd -> IO () +outputDrainer ss fromh buf bufsig bufend + | willOutput ss = go + | otherwise = atend + where + go = do + t <- T.hGetChunk fromh + if T.null t + then atend + else do + modifyMVar_ buf $ addOutputBuffer (Output t) + changed + go + atend = do + atomically $ putTMVar bufend AtEnd + hClose fromh + changed = atomically $ do + void $ tryTakeTMVar bufsig + putTMVar bufsig BufSig + +registerOutputThread :: IO () +registerOutputThread = do + let v = outputThreads globalOutputHandle + atomically $ putTMVar v . succ =<< takeTMVar v + +unregisterOutputThread :: IO () +unregisterOutputThread = do + let v = outputThreads globalOutputHandle + atomically $ putTMVar v . pred =<< takeTMVar v + +-- Wait to lock output, and once we can, display everything +-- that's put into the buffers, until the end. +-- +-- If end is reached before lock is taken, instead add the command's +-- buffers to the global outputBuffer and errorBuffer. +bufferWriter :: [(StdHandle, MVar OutputBuffer, TMVar BufSig, TMVar AtEnd)] -> IO () +bufferWriter ts = do + activitysig <- atomically newEmptyTMVar + worker1 <- async $ lockOutput $ + ifM (atomically $ tryPutTMVar activitysig ()) + ( void $ mapConcurrently displaybuf ts + , noop -- buffers already moved to global + ) + worker2 <- async $ void $ globalbuf activitysig + void $ async $ do + void $ waitCatch worker1 + void $ waitCatch worker2 + unregisterOutputThread + where + displaybuf v@(outh, buf, bufsig, bufend) = do + change <- atomically $ + (Right <$> takeTMVar bufsig) + `orElse` + (Left <$> takeTMVar bufend) + l <- takeMVar buf + putMVar buf (OutputBuffer []) + emitOutputBuffer outh l + case change of + Right BufSig -> displaybuf v + Left AtEnd -> return () + globalbuf activitysig = do + ok <- atomically $ do + -- signal we're going to handle it + -- (returns false if the displaybuf already did) + ok <- tryPutTMVar activitysig () + -- wait for end of all buffers + when ok $ + mapM_ (\(_outh, _buf, _bufsig, bufend) -> takeTMVar bufend) ts + return ok + when ok $ do + -- add all of the command's buffered output to the + -- global output buffer, atomically + bs <- forM ts $ \(outh, buf, _bufsig, _bufend) -> + (outh,) <$> takeMVar buf + atomically $ + forM_ bs $ \(outh, b) -> + bufferOutputSTM' outh b + +-- Adds a value to the OutputBuffer. When adding Output to a Handle, +-- it's cheaper to combine it with any already buffered Output to that +-- same Handle. +-- +-- When the total buffered Output exceeds 1 mb in size, it's moved out of +-- memory, to a temp file. This should only happen rarely, but is done to +-- avoid some verbose process unexpectedly causing excessive memory use. +addOutputBuffer :: OutputBufferedActivity -> OutputBuffer -> IO OutputBuffer +addOutputBuffer (Output t) (OutputBuffer buf) + | T.length t' <= 1048576 = return $ OutputBuffer (Output t' : other) + | otherwise = do + tmpdir <- getTemporaryDirectory + (tmp, h) <- openTempFile tmpdir "output.tmp" + let !endnl = endsNewLine t' + let i = InTempFile + { tempFile = tmp + , endsInNewLine = endnl + } + T.hPutStr h t' + hClose h + return $ OutputBuffer (i : other) + where + !t' = T.concat (mapMaybe getOutput this) <> t + !(this, other) = partition isOutput buf + isOutput v = case v of + Output _ -> True + _ -> False + getOutput v = case v of + Output t'' -> Just t'' + _ -> Nothing +addOutputBuffer v (OutputBuffer buf) = return $ OutputBuffer (v:buf) + +-- | Adds a value to the output buffer for later display. +-- +-- Note that buffering large quantities of data this way will keep it +-- resident in memory until it can be displayed. While `outputConcurrent` +-- uses temp files if the buffer gets too big, this STM function cannot do +-- so. +bufferOutputSTM :: Outputable v => StdHandle -> v -> STM () +bufferOutputSTM h v = bufferOutputSTM' h (OutputBuffer [Output (toOutput v)]) + +bufferOutputSTM' :: StdHandle -> OutputBuffer -> STM () +bufferOutputSTM' h (OutputBuffer newbuf) = do + (OutputBuffer buf) <- takeTMVar bv + putTMVar bv (OutputBuffer (newbuf ++ buf)) + where + bv = bufferFor h + +-- | A STM action that waits for some buffered output to become +-- available, and returns it. +-- +-- The function can select a subset of output when only some is desired; +-- the fst part is returned and the snd is left in the buffer. +-- +-- This will prevent it from being displayed in the usual way, so you'll +-- need to use `emitOutputBuffer` to display it yourself. +outputBufferWaiterSTM :: (OutputBuffer -> (OutputBuffer, OutputBuffer)) -> STM (StdHandle, OutputBuffer) +outputBufferWaiterSTM selector = waitgetbuf StdOut `orElse` waitgetbuf StdErr + where + waitgetbuf h = do + let bv = bufferFor h + (selected, rest) <- selector <$> takeTMVar bv + when (selected == OutputBuffer []) + retry + putTMVar bv rest + return (h, selected) + +waitAnyBuffer :: OutputBuffer -> (OutputBuffer, OutputBuffer) +waitAnyBuffer b = (b, OutputBuffer []) + +-- | Use with `outputBufferWaiterSTM` to make it only return buffered +-- output that ends with a newline. Anything buffered without a newline +-- is left in the buffer. +waitCompleteLines :: OutputBuffer -> (OutputBuffer, OutputBuffer) +waitCompleteLines (OutputBuffer l) = + let (selected, rest) = span completeline l + in (OutputBuffer selected, OutputBuffer rest) + where + completeline (v@(InTempFile {})) = endsInNewLine v + completeline (Output b) = endsNewLine b + +endsNewLine :: T.Text -> Bool +endsNewLine t = not (T.null t) && T.last t == '\n' + +-- | Emits the content of the OutputBuffer to the Handle +-- +-- If you use this, you should use `lockOutput` to ensure you're the only +-- thread writing to the console. +emitOutputBuffer :: StdHandle -> OutputBuffer -> IO () +emitOutputBuffer stdh (OutputBuffer l) = + forM_ (reverse l) $ \ba -> case ba of + Output t -> emit t + InTempFile tmp _ -> do + emit =<< T.readFile tmp + void $ tryWhenExists $ removeFile tmp + where + outh = toHandle stdh + emit t = void $ tryIO $ do + T.hPutStr outh t + hFlush outh diff --git a/src/System/Process/Concurrent.hs b/src/System/Process/Concurrent.hs new file mode 100644 --- /dev/null +++ b/src/System/Process/Concurrent.hs @@ -0,0 +1,34 @@ +-- | +-- Copyright: 2015 Joey Hess +-- License: BSD-2-clause +-- +-- The functions exported by this module are intended to be drop-in +-- replacements for those from System.Process, when converting a whole +-- program to use System.Console.Concurrent. + +module System.Process.Concurrent where + +import System.Console.Concurrent +import System.Console.Concurrent.Internal (ConcurrentProcessHandle(..)) +import System.Process hiding (createProcess, waitForProcess) +import System.IO +import System.Exit + +-- | Calls `createProcessConcurrent` +-- +-- You should use the waitForProcess in this module on the resulting +-- ProcessHandle. Using System.Process.waitForProcess instead can have +-- mildly unexpected results. +createProcess :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) +createProcess p = do + (i, o, e, ConcurrentProcessHandle h) <- createProcessConcurrent p + return (i, o, e, h) + +-- | Calls `waitForProcessConcurrent` +-- +-- You should only use this on a ProcessHandle obtained by calling +-- createProcess from this module. Using this with a ProcessHandle +-- obtained from System.Process.createProcess etc will have extremely +-- unexpected results; it can wait a very long time before returning. +waitForProcess :: ProcessHandle -> IO ExitCode +waitForProcess = waitForProcessConcurrent . ConcurrentProcessHandle diff --git a/src/Utility/Process.hs b/src/Utility/Process.hs --- a/src/Utility/Process.hs +++ b/src/Utility/Process.hs @@ -41,9 +41,12 @@ 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 Data.Maybe import Prelude -import Utility.Misc -import Utility.Exception - type CreateProcessRunner = forall a. CreateProcess -> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO a) -> IO a data StdHandle = StdinHandle | StdoutHandle | StderrHandle @@ -172,22 +172,21 @@ -- returns a transcript combining its stdout and stderr, and -- whether it succeeded or failed. processTranscript :: String -> [String] -> (Maybe String) -> IO (String, Bool) -processTranscript cmd opts = processTranscript' cmd opts Nothing +processTranscript = processTranscript' id -processTranscript' :: String -> [String] -> Maybe [(String, String)] -> (Maybe String) -> IO (String, Bool) -processTranscript' cmd opts environ input = do +processTranscript' :: (CreateProcess -> CreateProcess) -> String -> [String] -> Maybe String -> IO (String, Bool) +processTranscript' modproc cmd opts input = do #ifndef mingw32_HOST_OS {- This implementation interleves stdout and stderr in exactly the order - the process writes them. -} (readf, writef) <- System.Posix.IO.createPipe readh <- System.Posix.IO.fdToHandle readf writeh <- System.Posix.IO.fdToHandle writef - p@(_, _, _, pid) <- createProcess $ + p@(_, _, _, pid) <- createProcess $ modproc $ (proc cmd opts) { std_in = if isJust input then CreatePipe else Inherit , std_out = UseHandle writeh , std_err = UseHandle writeh - , env = environ } hClose writeh @@ -199,12 +198,11 @@ return (transcript, ok) #else {- This implementation for Windows puts stderr after stdout. -} - p@(_, _, _, pid) <- createProcess $ + p@(_, _, _, pid) <- createProcess $ modproc $ (proc cmd opts) { std_in = if isJust input then CreatePipe else Inherit , std_out = CreatePipe , std_err = CreatePipe - , env = environ } getout <- mkreader (stdoutHandle p) @@ -374,7 +372,7 @@ createProcess :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) createProcess p = do debugProcess p - System.Process.createProcess p + Utility.Process.Shim.createProcess p -- | Debugging trace for a CreateProcess. debugProcess :: CreateProcess -> IO () @@ -394,6 +392,6 @@ -- | 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 --- /dev/null +++ b/src/Utility/Process/Shim.hs @@ -0,0 +1,4 @@ +module Utility.Process.Shim (module X, createProcess, waitForProcess) where + +import System.Process as X hiding (createProcess, waitForProcess) +import System.Process.Concurrent diff --git a/src/wrapper.hs b/src/wrapper.hs --- a/src/wrapper.hs +++ b/src/wrapper.hs @@ -50,7 +50,7 @@ netrepo = "https://github.com/joeyh/propellor.git" main :: IO () -main = do +main = withConcurrentOutput $ do args <- getArgs home <- myHomeDir let propellordir = home ".propellor"