summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorJoey Hess2015-10-27 23:52:02 -0400
committerJoey Hess2015-10-27 23:52:02 -0400
commit894e2f7980052f1c331ba7780100ae0ad19856cb (patch)
treeaffb9ffb3c77d4d8b12bf2cb6666ec28ce6a11a4 /src
parent261d008d41e6656ce4ceafb8c0f0630d5795944a (diff)
use execProcessConcurrent everywhere
Found a reasonable clean way to make Utility.Process use execProcessConcurrent, while still allowing copying updates to it from git-annex.
Diffstat (limited to 'src')
-rw-r--r--src/Propellor/Base.hs2
-rw-r--r--src/Propellor/Debug.hs36
-rw-r--r--src/Propellor/Message.hs49
-rw-r--r--src/Propellor/Property/Cmd.hs2
-rw-r--r--src/Utility/Process.hs16
-rw-r--r--src/Utility/Process/Shim.hs8
6 files changed, 64 insertions, 49 deletions
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