From 894e2f7980052f1c331ba7780100ae0ad19856cb Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 27 Oct 2015 23:52:02 -0400 Subject: use execProcessConcurrent everywhere Found a reasonable clean way to make Utility.Process use execProcessConcurrent, while still allowing copying updates to it from git-annex. --- propellor.cabal | 2 ++ src/Propellor/Base.hs | 2 ++ src/Propellor/Debug.hs | 36 +++++++++++++++++++++++++++++++ src/Propellor/Message.hs | 49 ++++++++----------------------------------- src/Propellor/Property/Cmd.hs | 2 +- src/Utility/Process.hs | 16 +++++++------- src/Utility/Process/Shim.hs | 8 +++++++ 7 files changed, 66 insertions(+), 49 deletions(-) create mode 100644 src/Propellor/Debug.hs create mode 100644 src/Utility/Process/Shim.hs diff --git a/propellor.cabal b/propellor.cabal index 7a9d2b5d..63fcaaa5 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -135,6 +135,7 @@ Library Propellor.CmdLine Propellor.Info Propellor.Message + Propellor.Debug Propellor.PrivData Propellor.Engine Propellor.Exception @@ -175,6 +176,7 @@ Library Utility.PartialPrelude Utility.PosixFiles Utility.Process + Utility.Process.Shim Utility.SafeCommand Utility.Scheduled Utility.Table diff --git a/src/Propellor/Base.hs b/src/Propellor/Base.hs index 3c13bb7d..2a0f5cbc 100644 --- a/src/Propellor/Base.hs +++ b/src/Propellor/Base.hs @@ -15,6 +15,7 @@ module Propellor.Base ( , module Propellor.Engine , module Propellor.Exception , module Propellor.Message + , module Propellor.Debug , module Propellor.Location , module Propellor.Utilities @@ -39,6 +40,7 @@ import Propellor.Property.Cmd import Propellor.PrivData import Propellor.Types.PrivData import Propellor.Message +import Propellor.Debug import Propellor.Exception import Propellor.Info import Propellor.PropAccum diff --git a/src/Propellor/Debug.hs b/src/Propellor/Debug.hs new file mode 100644 index 00000000..ac4a56cc --- /dev/null +++ b/src/Propellor/Debug.hs @@ -0,0 +1,36 @@ +module Propellor.Debug where + +import Control.Applicative +import Control.Monad.IfElse +import System.IO +import System.Directory +import System.Log.Logger +import System.Log.Formatter +import System.Log.Handler (setFormatter) +import System.Log.Handler.Simple + +import Utility.Monad +import Utility.Env +import Utility.Exception +import Utility.Process + +debug :: [String] -> IO () +debug = debugM "propellor" . unwords + +checkDebugMode :: IO () +checkDebugMode = go =<< getEnv "PROPELLOR_DEBUG" + where + go (Just "1") = enableDebugMode + go (Just _) = noop + go Nothing = whenM (doesDirectoryExist ".git") $ + whenM (elem "1" . lines <$> getgitconfig) enableDebugMode + getgitconfig = catchDefaultIO "" $ + readProcess "git" ["config", "propellor.debug"] + +enableDebugMode :: IO () +enableDebugMode = do + f <- setFormatter + <$> streamHandler stderr DEBUG + <*> pure (simpleLogFormatter "[$time] $msg") + updateGlobalLogger rootLoggerName $ + setLevel DEBUG . setHandlers [f] diff --git a/src/Propellor/Message.hs b/src/Propellor/Message.hs index afe551cf..4be8263e 100644 --- a/src/Propellor/Message.hs +++ b/src/Propellor/Message.hs @@ -15,24 +15,16 @@ module Propellor.Message ( warningMessage, infoMessage, errorMessage, - debug, - checkDebugMode, - enableDebugMode, processChainOutput, messagesDone, - createProcess, + createProcessConcurrent, ) where import System.Console.ANSI import System.IO import System.Posix.IO -import System.Log.Logger -import System.Log.Formatter -import System.Log.Handler (setFormatter) -import System.Log.Handler.Simple import "mtl" Control.Monad.Reader import Control.Applicative -import System.Directory import Control.Monad.IfElse import System.IO.Unsafe (unsafePerformIO) import Control.Concurrent @@ -42,13 +34,12 @@ import Data.Char import Data.List import Data.Monoid import qualified Data.ByteString as B +import qualified System.Process as P import Propellor.Types import Utility.PartialPrelude import Utility.Monad -import Utility.Env import Utility.Exception -import qualified Utility.Process as P data MessageHandle = MessageHandle { isConsole :: Bool @@ -131,7 +122,7 @@ dropOutputLock :: IO () dropOutputLock = do lcker <- outputLockedBy <$> getMessageHandle lck <- outputLock <$> getMessageHandle - takeMVar lcker + void $ takeMVar lcker putMVar lck () -- | Only safe to call after takeOutputLock; updates the Locker. @@ -216,27 +207,6 @@ colorLine intensity color msg = do putStrLn "" hFlush stdout -debug :: [String] -> IO () -debug = debugM "propellor" . unwords - -checkDebugMode :: IO () -checkDebugMode = go =<< getEnv "PROPELLOR_DEBUG" - where - go (Just "1") = enableDebugMode - go (Just _) = noop - go Nothing = whenM (doesDirectoryExist ".git") $ - whenM (elem "1" . lines <$> getgitconfig) enableDebugMode - getgitconfig = catchDefaultIO "" $ - P.readProcess "git" ["config", "propellor.debug"] - -enableDebugMode :: IO () -enableDebugMode = do - f <- setFormatter - <$> streamHandler stderr DEBUG - <*> pure (simpleLogFormatter "[$time] $msg") - updateGlobalLogger rootLoggerName $ - setLevel DEBUG . setHandlers [f] - -- | Reads and displays each line from the Handle, except for the last line -- which is a Result. processChainOutput :: Handle -> IO Result @@ -244,16 +214,13 @@ processChainOutput h = go Nothing where go lastline = do v <- catchMaybeIO (hGetLine h) - debug ["read from chained propellor: ", show v] case v of Nothing -> case lastline of Nothing -> do - debug ["chained propellor output nothing; assuming it failed"] return FailedChange Just l -> case readish l of Just r -> pure r Nothing -> do - debug ["chained propellor output did not end with a Result; assuming it failed"] lockOutput $ do putStrLn l hFlush stdout @@ -287,8 +254,8 @@ messagesDone = lockOutput $ do -- commands, which are based on this. -- -- Also does debug logging of all commands run. -createProcess :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, P.ProcessHandle) -createProcess p +createProcessConcurrent :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, P.ProcessHandle) +createProcessConcurrent p | hasoutput (P.std_out p) || hasoutput (P.std_err p) = ifM tryTakeOutputLock ( firstprocess @@ -319,12 +286,12 @@ createProcess p then P.UseHandle toerrh else P.std_err p } - r@(_, _, _, ph) <- P.createProcess p' + r <- P.createProcess p' hClose toouth hClose toerrh buf <- newMVar [] void $ async $ outputDrainer fromouth stdout buf - void $ async $ outputDrainer fromouth stderr buf + void $ async $ outputDrainer fromerrh stderr buf void $ async $ bufferWriter buf return r @@ -349,6 +316,7 @@ outputDrainer fromh toh buf = do -- Wait to lock output, and once we can, display everything -- that's put into buffer, until the end is signaled by Nothing -- for both stdout and stderr. +bufferWriter :: MVar Buffer -> IO () bufferWriter buf = lockOutput (go [stdout, stderr]) where go [] = return () @@ -364,6 +332,7 @@ bufferWriter buf = lockOutput (go [stdout, stderr]) -- The buffer can grow up to 1 mb in size, but after that point, -- it's truncated to avoid propellor using unbounded memory -- when a process outputs a whole lot of stuff. +bufsz :: Int bufsz = 1000000 addBuffer :: (Handle, Maybe B.ByteString) -> Buffer -> Buffer diff --git a/src/Propellor/Property/Cmd.hs b/src/Propellor/Property/Cmd.hs index f2c5b33e..9536f71d 100644 --- a/src/Propellor/Property/Cmd.hs +++ b/src/Propellor/Property/Cmd.hs @@ -27,7 +27,7 @@ import Propellor.Types import Propellor.Property import Utility.SafeCommand import Utility.Env -import Utility.Process (createProcess, CreateProcess) +import Utility.Process (createProcess, CreateProcess, waitForProcess) -- | A property that can be satisfied by running a command. -- diff --git a/src/Utility/Process.hs b/src/Utility/Process.hs index cc113867..c6699961e 100644 --- a/src/Utility/Process.hs +++ b/src/Utility/Process.hs @@ -41,9 +41,12 @@ module Utility.Process ( devNull, ) where -import qualified System.Process -import qualified System.Process as X hiding (CreateProcess(..), createProcess, runInteractiveProcess, readProcess, readProcessWithExitCode, system, rawSystem, runInteractiveCommand, runProcess) -import System.Process hiding (createProcess, readProcess, waitForProcess) +import qualified Utility.Process.Shim +import qualified Utility.Process.Shim as X hiding (CreateProcess(..), createProcess, runInteractiveProcess, readProcess, readProcessWithExitCode, system, rawSystem, runInteractiveCommand, runProcess) +import Utility.Process.Shim hiding (createProcess, readProcess, waitForProcess) +import Utility.Misc +import Utility.Exception + import System.Exit import System.IO import System.Log.Logger @@ -58,9 +61,6 @@ import Control.Applicative import Data.Maybe import Prelude -import Utility.Misc -import Utility.Exception - type CreateProcessRunner = forall a. CreateProcess -> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO a) -> IO a data StdHandle = StdinHandle | StdoutHandle | StderrHandle @@ -372,7 +372,7 @@ startInteractiveProcess cmd args environ = do createProcess :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) createProcess p = do debugProcess p - System.Process.createProcess p + Utility.Process.Shim.createProcess p -- | Debugging trace for a CreateProcess. debugProcess :: CreateProcess -> IO () @@ -392,6 +392,6 @@ debugProcess p = debugM "Utility.Process" $ unwords -- | Wrapper around 'System.Process.waitForProcess' that does debug logging. waitForProcess :: ProcessHandle -> IO ExitCode waitForProcess h = do - r <- System.Process.waitForProcess h + r <- Utility.Process.Shim.waitForProcess h debugM "Utility.Process" ("process done " ++ show r) return r diff --git a/src/Utility/Process/Shim.hs b/src/Utility/Process/Shim.hs new file mode 100644 index 00000000..0da93bf7 --- /dev/null +++ b/src/Utility/Process/Shim.hs @@ -0,0 +1,8 @@ +module Utility.Process.Shim (module X, createProcess) where + +import System.Process as X hiding (createProcess) +import Propellor.Message (createProcessConcurrent) +import System.IO + +createProcess :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) +createProcess = createProcessConcurrent -- cgit v1.2.3