From 8deac74e2c6d07537ee0c95928af069c8558390e Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 10 Jun 2020 14:19:34 -0400 Subject: setting up joeyconfig after merge --- config.hs | 2 +- privdata/relocate | 1 + 2 files changed, 2 insertions(+), 1 deletion(-) create mode 100644 privdata/relocate diff --git a/config.hs b/config.hs index ec313725..97d90636 120000 --- a/config.hs +++ b/config.hs @@ -1 +1 @@ -config-simple.hs \ No newline at end of file +joeyconfig.hs \ No newline at end of file diff --git a/privdata/relocate b/privdata/relocate new file mode 100644 index 00000000..271692d8 --- /dev/null +++ b/privdata/relocate @@ -0,0 +1 @@ +.joeyconfig -- cgit v1.2.3 From dbd3ba3400a3097498252097540ffe8075b00833 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 10 Jun 2020 14:40:29 -0400 Subject: Added dependency on concurrent-output; removed embedded copy. Trying again what failed in 2018 (commit 02eca2ae4cf51d8e83d94d8359e15ac053451109). I hope the problem was a broken old version of concurrent-output and that it will be ok now. This commit was sponsored by Denis Dzyubenko on Patreon. --- debian/changelog | 1 + debian/control | 6 +- doc/todo/depend_on_concurrent-output.mdwn | 2 + propellor.cabal | 5 +- src/Propellor/Bootstrap.hs | 10 - src/System/Console/Concurrent.hs | 44 --- src/System/Console/Concurrent/Internal.hs | 546 ------------------------------ src/System/Process/Concurrent.hs | 34 -- 8 files changed, 6 insertions(+), 642 deletions(-) delete mode 100644 src/System/Console/Concurrent.hs delete mode 100644 src/System/Console/Concurrent/Internal.hs delete mode 100644 src/System/Process/Concurrent.hs diff --git a/debian/changelog b/debian/changelog index b46c4b4e..922e481e 100644 --- a/debian/changelog +++ b/debian/changelog @@ -3,6 +3,7 @@ propellor (5.10.3) UNRELEASED; urgency=medium * Fix display of concurrent output from processes when using Propellor.Property.Conductor. (Reversion introduced in version 5.5.0.) + * Added dependency on concurrent-output; removed embedded copy. -- Joey Hess Fri, 05 Jun 2020 11:26:21 -0400 diff --git a/debian/control b/debian/control index 5a46822f..8e61fd80 100644 --- a/debian/control +++ b/debian/control @@ -14,10 +14,9 @@ Build-Depends: libghc-ifelse-dev, libghc-network-dev, libghc-mtl-dev, - libghc-transformers-dev, libghc-exceptions-dev (>= 0.6), - libghc-text-dev, libghc-hashable-dev, + libghc-concurrent-output-dev, Maintainer: Joey Hess Standards-Version: 3.9.8 Vcs-Git: git://git.joeyh.name/propellor @@ -37,10 +36,9 @@ Depends: ${misc:Depends}, ${shlibs:Depends}, libghc-ifelse-dev, libghc-network-dev, libghc-mtl-dev, - libghc-transformers-dev, libghc-exceptions-dev (>= 0.6), - libghc-text-dev, libghc-hashable-dev, + libghc-concurrent-output-dev, git (>= 2.0), Description: property-based host configuration management in haskell Propellor ensures that the system it's run in satisfies a list of diff --git a/doc/todo/depend_on_concurrent-output.mdwn b/doc/todo/depend_on_concurrent-output.mdwn index c3641385..1bfaab03 100644 --- a/doc/todo/depend_on_concurrent-output.mdwn +++ b/doc/todo/depend_on_concurrent-output.mdwn @@ -27,3 +27,5 @@ Waiting on concurrent-output reaching Debian stable. > from debian. That is a somewhat old version and perhaps it was buggy? > However, I have not had any luck reproducing the problem there running > readProcess in ghci. --[[Joey]] + +> > [[done]] again, hope it sticks this time --[[Joey]] diff --git a/propellor.cabal b/propellor.cabal index 4aaf9c0a..93edbb13 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -49,7 +49,7 @@ Library base >= 4.9, base < 5, directory, filepath, IfElse, process, bytestring, hslogger, split, unix, unix-compat, ansi-terminal, containers (>= 0.5), network, async, - time, mtl, transformers, exceptions (>= 0.6), stm, text, hashable + time, mtl, exceptions (>= 0.6), hashable, concurrent-output if flag(WithTypeErrors) Build-Depends: type-errors CPP-Options: -DWITH_TYPE_ERRORS @@ -233,9 +233,6 @@ Library Utility.Tmp.Dir Utility.Tuple Utility.UserInfo - System.Console.Concurrent - System.Console.Concurrent.Internal - System.Process.Concurrent Paths_propellor Executable propellor-config diff --git a/src/Propellor/Bootstrap.hs b/src/Propellor/Bootstrap.hs index d772d7c7..3621cabb 100644 --- a/src/Propellor/Bootstrap.hs +++ b/src/Propellor/Bootstrap.hs @@ -148,12 +148,8 @@ depsCommand bs msys = "( " ++ intercalate " ; " (go bs) ++ ") || true" , Dep "libghc-ifelse-dev" , Dep "libghc-network-dev" , Dep "libghc-mtl-dev" - , Dep "libghc-transformers-dev" , Dep "libghc-exceptions-dev" - , Dep "libghc-text-dev" , Dep "libghc-hashable-dev" - -- Deps that are only needed on old systems. - , OldDep "libghc-stm-dev" ] debdeps Stack = [ Dep "gnupg" @@ -172,10 +168,7 @@ depsCommand bs msys = "( " ++ intercalate " ; " (go bs) ++ ") || true" , "hs-IfElse" , "hs-network" , "hs-mtl" - , "hs-transformers-base" , "hs-exceptions" - , "hs-stm" - , "hs-text" , "hs-hashable" ] fbsddeps Stack = @@ -196,10 +189,7 @@ depsCommand bs msys = "( " ++ intercalate " ; " (go bs) ++ ") || true" , "haskell-ifelse" , "haskell-network" , "haskell-mtl" - , "haskell-transformers-base" , "haskell-exceptions" - , "haskell-stm" - , "haskell-text" , "haskell-hashable" , "haskell-type-errors" ] diff --git a/src/System/Console/Concurrent.hs b/src/System/Console/Concurrent.hs deleted file mode 100644 index 12447637..00000000 --- a/src/System/Console/Concurrent.hs +++ /dev/null @@ -1,44 +0,0 @@ --- | --- 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 deleted file mode 100644 index ffe6a9e8..00000000 --- a/src/System/Console/Concurrent/Internal.hs +++ /dev/null @@ -1,546 +0,0 @@ -{-# LANGUAGE BangPatterns, TypeSynonymInstances, FlexibleInstances, TupleSections #-} -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -O2 #-} -{- Building this module with -O0 causes streams not to fuse and too much - - memory to be used. -} - --- | --- 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 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 Control.Applicative -import Prelude - -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. Also blocks while --- `lockOutput` is is use. --- --- `withConcurrentOutput` calls this at the end, so you do not normally --- need to use this. -flushConcurrentOutput :: IO () -flushConcurrentOutput = do - atomically $ do - r <- takeTMVar (outputThreads globalOutputHandle) - if r <= 0 - then putTMVar (outputThreads globalOutputHandle) r - else retry - -- Take output lock to wait for anything else that might be - -- currently generating 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 - registerOutputThread - -- Wait for the process to exit and drop the lock. - asyncProcessWaiter $ do - void $ tryIO $ P.waitForProcess h - unregisterOutputThread - 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 worker1 - 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 worker1 = 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 - -- worker1 might be blocked waiting for the output - -- lock, and we've already done its job, so cancel it - cancel worker1 - --- 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 deleted file mode 100644 index 0e00e4fd..00000000 --- a/src/System/Process/Concurrent.hs +++ /dev/null @@ -1,34 +0,0 @@ --- | --- 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 -- cgit v1.2.3 -- cgit v1.2.3 From a971958d232562e3ebd18a0266a80c7da0d3b3fd Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 10 Jun 2020 14:43:06 -0400 Subject: add concurrent-output apt dep I don't know if the other distros have a package. --- src/Propellor/Bootstrap.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Propellor/Bootstrap.hs b/src/Propellor/Bootstrap.hs index 3621cabb..66192e36 100644 --- a/src/Propellor/Bootstrap.hs +++ b/src/Propellor/Bootstrap.hs @@ -150,6 +150,7 @@ depsCommand bs msys = "( " ++ intercalate " ; " (go bs) ++ ") || true" , Dep "libghc-mtl-dev" , Dep "libghc-exceptions-dev" , Dep "libghc-hashable-dev" + , Dep "libghc-concurrent-output-dev" ] debdeps Stack = [ Dep "gnupg" -- cgit v1.2.3 -- cgit v1.2.3 -- cgit v1.2.3 -- cgit v1.2.3 -- cgit v1.2.3 -- cgit v1.2.3 From a077594770132b4a07b168936d07385ff0c618d6 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 10 Jun 2020 15:08:44 -0400 Subject: Revert "Added dependency on concurrent-output; removed embedded copy." This reverts commit dbd3ba3400a3097498252097540ffe8075b00833. Still has the same problem as in 2018! --- debian/changelog | 1 - debian/control | 6 +- doc/todo/depend_on_concurrent-output.mdwn | 2 - propellor.cabal | 5 +- src/Propellor/Bootstrap.hs | 11 +- src/System/Console/Concurrent.hs | 44 +++ src/System/Console/Concurrent/Internal.hs | 546 ++++++++++++++++++++++++++++++ src/System/Process/Concurrent.hs | 34 ++ 8 files changed, 642 insertions(+), 7 deletions(-) create mode 100644 src/System/Console/Concurrent.hs create mode 100644 src/System/Console/Concurrent/Internal.hs create mode 100644 src/System/Process/Concurrent.hs diff --git a/debian/changelog b/debian/changelog index 922e481e..b46c4b4e 100644 --- a/debian/changelog +++ b/debian/changelog @@ -3,7 +3,6 @@ propellor (5.10.3) UNRELEASED; urgency=medium * Fix display of concurrent output from processes when using Propellor.Property.Conductor. (Reversion introduced in version 5.5.0.) - * Added dependency on concurrent-output; removed embedded copy. -- Joey Hess Fri, 05 Jun 2020 11:26:21 -0400 diff --git a/debian/control b/debian/control index 8e61fd80..5a46822f 100644 --- a/debian/control +++ b/debian/control @@ -14,9 +14,10 @@ Build-Depends: libghc-ifelse-dev, libghc-network-dev, libghc-mtl-dev, + libghc-transformers-dev, libghc-exceptions-dev (>= 0.6), + libghc-text-dev, libghc-hashable-dev, - libghc-concurrent-output-dev, Maintainer: Joey Hess Standards-Version: 3.9.8 Vcs-Git: git://git.joeyh.name/propellor @@ -36,9 +37,10 @@ Depends: ${misc:Depends}, ${shlibs:Depends}, libghc-ifelse-dev, libghc-network-dev, libghc-mtl-dev, + libghc-transformers-dev, libghc-exceptions-dev (>= 0.6), + libghc-text-dev, libghc-hashable-dev, - libghc-concurrent-output-dev, git (>= 2.0), Description: property-based host configuration management in haskell Propellor ensures that the system it's run in satisfies a list of diff --git a/doc/todo/depend_on_concurrent-output.mdwn b/doc/todo/depend_on_concurrent-output.mdwn index 1bfaab03..c3641385 100644 --- a/doc/todo/depend_on_concurrent-output.mdwn +++ b/doc/todo/depend_on_concurrent-output.mdwn @@ -27,5 +27,3 @@ Waiting on concurrent-output reaching Debian stable. > from debian. That is a somewhat old version and perhaps it was buggy? > However, I have not had any luck reproducing the problem there running > readProcess in ghci. --[[Joey]] - -> > [[done]] again, hope it sticks this time --[[Joey]] diff --git a/propellor.cabal b/propellor.cabal index 93edbb13..4aaf9c0a 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -49,7 +49,7 @@ Library base >= 4.9, base < 5, directory, filepath, IfElse, process, bytestring, hslogger, split, unix, unix-compat, ansi-terminal, containers (>= 0.5), network, async, - time, mtl, exceptions (>= 0.6), hashable, concurrent-output + time, mtl, transformers, exceptions (>= 0.6), stm, text, hashable if flag(WithTypeErrors) Build-Depends: type-errors CPP-Options: -DWITH_TYPE_ERRORS @@ -233,6 +233,9 @@ Library Utility.Tmp.Dir Utility.Tuple Utility.UserInfo + System.Console.Concurrent + System.Console.Concurrent.Internal + System.Process.Concurrent Paths_propellor Executable propellor-config diff --git a/src/Propellor/Bootstrap.hs b/src/Propellor/Bootstrap.hs index 66192e36..d772d7c7 100644 --- a/src/Propellor/Bootstrap.hs +++ b/src/Propellor/Bootstrap.hs @@ -148,9 +148,12 @@ depsCommand bs msys = "( " ++ intercalate " ; " (go bs) ++ ") || true" , Dep "libghc-ifelse-dev" , Dep "libghc-network-dev" , Dep "libghc-mtl-dev" + , Dep "libghc-transformers-dev" , Dep "libghc-exceptions-dev" + , Dep "libghc-text-dev" , Dep "libghc-hashable-dev" - , Dep "libghc-concurrent-output-dev" + -- Deps that are only needed on old systems. + , OldDep "libghc-stm-dev" ] debdeps Stack = [ Dep "gnupg" @@ -169,7 +172,10 @@ depsCommand bs msys = "( " ++ intercalate " ; " (go bs) ++ ") || true" , "hs-IfElse" , "hs-network" , "hs-mtl" + , "hs-transformers-base" , "hs-exceptions" + , "hs-stm" + , "hs-text" , "hs-hashable" ] fbsddeps Stack = @@ -190,7 +196,10 @@ depsCommand bs msys = "( " ++ intercalate " ; " (go bs) ++ ") || true" , "haskell-ifelse" , "haskell-network" , "haskell-mtl" + , "haskell-transformers-base" , "haskell-exceptions" + , "haskell-stm" + , "haskell-text" , "haskell-hashable" , "haskell-type-errors" ] diff --git a/src/System/Console/Concurrent.hs b/src/System/Console/Concurrent.hs new file mode 100644 index 00000000..12447637 --- /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 index 00000000..ffe6a9e8 --- /dev/null +++ b/src/System/Console/Concurrent/Internal.hs @@ -0,0 +1,546 @@ +{-# LANGUAGE BangPatterns, TypeSynonymInstances, FlexibleInstances, TupleSections #-} +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -O2 #-} +{- Building this module with -O0 causes streams not to fuse and too much + - memory to be used. -} + +-- | +-- 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 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 Control.Applicative +import Prelude + +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. Also blocks while +-- `lockOutput` is is use. +-- +-- `withConcurrentOutput` calls this at the end, so you do not normally +-- need to use this. +flushConcurrentOutput :: IO () +flushConcurrentOutput = do + atomically $ do + r <- takeTMVar (outputThreads globalOutputHandle) + if r <= 0 + then putTMVar (outputThreads globalOutputHandle) r + else retry + -- Take output lock to wait for anything else that might be + -- currently generating 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 + registerOutputThread + -- Wait for the process to exit and drop the lock. + asyncProcessWaiter $ do + void $ tryIO $ P.waitForProcess h + unregisterOutputThread + 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 worker1 + 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 worker1 = 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 + -- worker1 might be blocked waiting for the output + -- lock, and we've already done its job, so cancel it + cancel worker1 + +-- 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 index 00000000..0e00e4fd --- /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 -- cgit v1.2.3 From ad2c6ae1f904b5d94e227944c96db657410934ee Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 10 Jun 2020 15:19:02 -0400 Subject: meh --- doc/todo/depend_on_concurrent-output.mdwn | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/doc/todo/depend_on_concurrent-output.mdwn b/doc/todo/depend_on_concurrent-output.mdwn index c3641385..2503fe2e 100644 --- a/doc/todo/depend_on_concurrent-output.mdwn +++ b/doc/todo/depend_on_concurrent-output.mdwn @@ -27,3 +27,16 @@ Waiting on concurrent-output reaching Debian stable. > from debian. That is a somewhat old version and perhaps it was buggy? > However, I have not had any luck reproducing the problem there running > readProcess in ghci. --[[Joey]] +> +> > Tried again in 2020, same bugs still happened. On a system running +> > debian unstable with concurrent-output 1.10.9, and a system running stable that +> > had cabal installed concurrent-output 1.10.11. +> > +> > The former system (kite) had the strange output problem. +> > +> > The latter system (keysafe) seemed ok but crashed at the end with +> > a STM transaction deadlock. Downgrading to concurrent-output 1.10.6 +> > eliminated that problem. +> > +> > This is really looking like a reversion, or several, in newer +> > versions of concurrent-output. --[[Joey]] -- cgit v1.2.3 From e6d4139e15b3a52f4a60178bb7d15ba96f191340 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 10 Jun 2020 16:13:10 -0400 Subject: more --- doc/todo/depend_on_concurrent-output.mdwn | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/doc/todo/depend_on_concurrent-output.mdwn b/doc/todo/depend_on_concurrent-output.mdwn index 2503fe2e..5826506e 100644 --- a/doc/todo/depend_on_concurrent-output.mdwn +++ b/doc/todo/depend_on_concurrent-output.mdwn @@ -35,8 +35,10 @@ Waiting on concurrent-output reaching Debian stable. > > The former system (kite) had the strange output problem. > > > > The latter system (keysafe) seemed ok but crashed at the end with -> > a STM transaction deadlock. Downgrading to concurrent-output 1.10.6 -> > eliminated that problem. +> > a STM transaction deadlock. Seemed to only happen when spinning the +> > host remotely, or not always; I tried to reproduce it running propellor +> > manually to bisect concurrent-output but without success. > > > > This is really looking like a reversion, or several, in newer -> > versions of concurrent-output. --[[Joey]] +> > versions of concurrent-output. The code bundled with propellor is +> > the same as concurrent-output 1.7.4. -- cgit v1.2.3 From 162e1d4e82e24f0fe3e2bd3114e4366ddb1062c0 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 10 Jun 2020 17:07:43 -0400 Subject: merge from concurrent-output This includes e6d4139e15b3a52f4a60178bb7d15ba96f191340 which I hope fixes the reversion that has been plaguing propellor when trying to use more recent versions of concurrent-output. Embedding it will let me test, and also it will be years until that fix is widely enough available to depend on it. --- src/System/Console/Concurrent.hs | 10 +- src/System/Console/Concurrent/Internal.hs | 187 ++++++++++++------------------ src/System/Process/Concurrent.hs | 16 +-- 3 files changed, 77 insertions(+), 136 deletions(-) diff --git a/src/System/Console/Concurrent.hs b/src/System/Console/Concurrent.hs index 12447637..8ab73c3d 100644 --- a/src/System/Console/Concurrent.hs +++ b/src/System/Console/Concurrent.hs @@ -7,29 +7,25 @@ -- > import Control.Concurrent.Async -- > import System.Console.Concurrent -- > --- > main = withConcurrentOutput $ +-- > main = withConcurrentOutput $ do -- > 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, + ConcurrentProcessHandle, + waitForProcessConcurrent, -- * Low level access to the output buffer OutputBuffer, StdHandle(..), diff --git a/src/System/Console/Concurrent/Internal.hs b/src/System/Console/Concurrent/Internal.hs index ffe6a9e8..de4cffaf 100644 --- a/src/System/Console/Concurrent/Internal.hs +++ b/src/System/Console/Concurrent/Internal.hs @@ -1,5 +1,4 @@ {-# LANGUAGE BangPatterns, TypeSynonymInstances, FlexibleInstances, TupleSections #-} -{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -O2 #-} {- Building this module with -O0 causes streams not to fuse and too much - memory to be used. -} @@ -15,9 +14,6 @@ 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 @@ -32,6 +28,7 @@ import Data.Monoid import qualified System.Process as P import qualified Data.Text as T import qualified Data.Text.IO as T +import qualified Data.Text.Lazy as L import Control.Applicative import Prelude @@ -43,8 +40,6 @@ data OutputHandle = OutputHandle , outputBuffer :: TMVar OutputBuffer , errorBuffer :: TMVar OutputBuffer , outputThreads :: TMVar Integer - , processWaiters :: TMVar [Async ()] - , waitForProcessLock :: TMVar () } data Lock = Locked @@ -57,8 +52,6 @@ globalOutputHandle = unsafePerformIO $ OutputHandle <*> 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 @@ -109,7 +102,8 @@ dropOutputLock :: IO () dropOutputLock = withLock $ void . takeTMVar -- | Use this around any actions that use `outputConcurrent` --- or `createProcessConcurrent` +-- or `createProcessConcurrent`, unless +-- `System.Console.Regions.displayConsoleRegions` is being used. -- -- This is necessary to ensure that buffered concurrent output actually -- gets displayed before the program exits. @@ -140,20 +134,30 @@ class Outputable v where instance Outputable T.Text where toOutput = id +-- | Note that using a lazy Text as an Outputable value +-- will buffer it all in memory. +instance Outputable L.Text where + toOutput = toOutput . L.toStrict + 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. -- +-- No newline is appended to the value, so if you want a newline, be sure +-- to include it yourself. +-- -- 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. +-- +-- When outputConcurrent is used within a call to +-- `System.Console.Regions.displayConsoleRegions`, the output is displayed +-- above the currently open console regions. Only lines ending in a newline +-- are displayed in this case (it uses `waitCompleteLines`). outputConcurrent :: Outputable v => v -> IO () outputConcurrent = outputConcurrent' StdOut @@ -179,69 +183,13 @@ outputConcurrent' stdh v = bracket setup cleanup go 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) +-- | This alias is provided to avoid breaking backwards compatibility. +type ConcurrentProcessHandle = P.ProcessHandle --- | 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` +-- | Same as `P.waitForProcess`; provided to avoid breaking backwards +-- compatibility. 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) +waitForProcessConcurrent = P.waitForProcess -- | Wrapper around `System.Process.createProcess` that prevents -- multiple processes that are running concurrently from writing @@ -260,9 +208,10 @@ asyncProcessWaiter waitaction = do -- 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) +-- Note that the the process is waited for by a background thread, +-- so unlike createProcess, neglecting to call waitForProcess will not +-- result in zombie processess. +createProcessConcurrent :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, P.ProcessHandle) createProcessConcurrent p | willOutput (P.std_out p) || willOutput (P.std_err p) = ifM tryTakeOutputLock @@ -271,56 +220,65 @@ createProcessConcurrent p ) | otherwise = do r@(_, _, _, h) <- P.createProcess p - asyncProcessWaiter $ - void $ tryIO $ P.waitForProcess h - return (toConcurrentProcessHandle r) -#endif + _ <- async $ void $ tryIO $ P.waitForProcess h + return r -- | 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) +-- +-- Note that the the process is waited for by a background thread, +-- so unlike createProcess, neglecting to call waitForProcess will not +-- result in zombie processess. +createProcessForeground :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, P.ProcessHandle) createProcessForeground p = do takeOutputLock fgProcess p -fgProcess :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle) +fgProcess :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, P.ProcessHandle) fgProcess p = do r@(_, _, _, h) <- P.createProcess p `onException` dropOutputLock registerOutputThread -- Wait for the process to exit and drop the lock. - asyncProcessWaiter $ do + _ <- async $ do void $ tryIO $ P.waitForProcess h unregisterOutputThread dropOutputLock - return (toConcurrentProcessHandle r) + return r -#ifndef mingw32_HOST_OS -bgProcess :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle) +bgProcess :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, P.ProcessHandle) 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 + { P.std_out = rediroutput (P.std_out p) + , P.std_err = rediroutput (P.std_err p) } registerOutputThread - r@(_, _, _, h) <- P.createProcess p' + (stdin_h, stdout_h, stderr_h, 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 + let r = + ( stdin_h + , mungeret (P.std_out p) stdout_h + , mungeret (P.std_err p) stderr_h + , h + ) + -- Wait for the process for symmetry with fgProcess, + -- which does the same. + _ <- async $ void $ tryIO $ P.waitForProcess h + outbuf <- setupOutputBuffer StdOut (mungebuf (P.std_out p) stdout_h) + errbuf <- setupOutputBuffer StdErr (mungebuf (P.std_err p) stderr_h) void $ async $ bufferWriter [outbuf, errbuf] - return (toConcurrentProcessHandle r) + return r where - pipe = do - (from, to) <- createPipe - (,) <$> fdToHandle to <*> fdToHandle from - rediroutput ss h - | willOutput ss = P.UseHandle h + rediroutput ss + | willOutput ss = P.CreatePipe | otherwise = ss -#endif + mungebuf ss mh + | willOutput ss = mh + | otherwise = Nothing + mungeret ss mh + | willOutput ss = Nothing + | otherwise = mh willOutput :: P.StdStream -> Bool willOutput P.Inherit = True @@ -353,32 +311,31 @@ data AtEnd = AtEnd 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 +setupOutputBuffer :: StdHandle -> Maybe Handle -> IO (StdHandle, MVar OutputBuffer, TMVar BufSig, TMVar AtEnd) +setupOutputBuffer h fromh = do buf <- newMVar (OutputBuffer []) bufsig <- atomically newEmptyTMVar bufend <- atomically newEmptyTMVar - void $ async $ outputDrainer ss fromh buf bufsig bufend + void $ async $ outputDrainer 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 +outputDrainer :: Maybe Handle -> MVar OutputBuffer -> TMVar BufSig -> TMVar AtEnd -> IO () +outputDrainer mfromh buf bufsig bufend = case mfromh of + Nothing -> atend + Just fromh -> go fromh where - go = do + go fromh = do t <- T.hGetChunk fromh if T.null t - then atend + then do + atend + hClose fromh else do modifyMVar_ buf $ addOutputBuffer (Output t) changed - go - atend = do - atomically $ putTMVar bufend AtEnd - hClose fromh + go fromh + atend = atomically $ putTMVar bufend AtEnd changed = atomically $ do void $ tryTakeTMVar bufsig putTMVar bufsig BufSig diff --git a/src/System/Process/Concurrent.hs b/src/System/Process/Concurrent.hs index 0e00e4fd..346ce2e0 100644 --- a/src/System/Process/Concurrent.hs +++ b/src/System/Process/Concurrent.hs @@ -9,26 +9,14 @@ 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) +createProcess = createProcessConcurrent -- | 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 +waitForProcess = waitForProcessConcurrent -- cgit v1.2.3 -- cgit v1.2.3 -- cgit v1.2.3 From 8418714e7139ae184f1b1ab55b5e9abed048f404 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 10 Jun 2020 17:20:21 -0400 Subject: yay, back on track to fix this in um ... 3 years --- doc/todo/depend_on_concurrent-output.mdwn | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/doc/todo/depend_on_concurrent-output.mdwn b/doc/todo/depend_on_concurrent-output.mdwn index 5826506e..48dd829e 100644 --- a/doc/todo/depend_on_concurrent-output.mdwn +++ b/doc/todo/depend_on_concurrent-output.mdwn @@ -42,3 +42,11 @@ Waiting on concurrent-output reaching Debian stable. > > This is really looking like a reversion, or several, in newer > > versions of concurrent-output. The code bundled with propellor is > > the same as concurrent-output 1.7.4. + +> > > I think I've fixed it, concurrent-output (>= 1.10.12 || <= 1.7.4) +> > > will be needed to avoid the bug. Will be several years until that's +> > > in debian stable.. +> > > +> > > I've updated the embedded concurrent-output copy, and it should +> > > be kept up-to-date as concurrent-output changes, to avoid more +> > > such reversions. --[[Joey]] -- cgit v1.2.3 -- cgit v1.2.3 From 745784f61bdd678e20b1b18743f18d458836a802 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 17 Jun 2020 17:57:04 -0400 Subject: Support bootstrapping to hosts using cabal 3.x, with new-dist directory. * Support bootstrapping to hosts using cabal 3.x, with new-dist directory. * Makefile: Fix build with cabal 3.x. This assumes that, once a new-dist directory is created, the host won't revert back to using dist. So it always prefers binaries from new-dist over dist. This commit was sponsored by LND on Patreon. --- .gitignore | 3 ++ Makefile | 35 ++++++++++++++-------- debian/changelog | 2 ++ ...ent_4_294fcbae675879cb81aeb8d37cf3b635._comment | 13 ++++++++ src/Propellor/Bootstrap.hs | 7 ++++- 5 files changed, 46 insertions(+), 14 deletions(-) create mode 100644 doc/forum/Bootstrapping_with_Cabal_on_Archlinux_fails/comment_4_294fcbae675879cb81aeb8d37cf3b635._comment diff --git a/.gitignore b/.gitignore index d9285db3..4e1b918c 100644 --- a/.gitignore +++ b/.gitignore @@ -1,6 +1,8 @@ /propellor dist/* +dist-newstyle/* tags +configured privdata/local privdata/keyring.gpg~ Setup @@ -15,4 +17,5 @@ propellor.1 .cabal-sandbox/ .dir-locals.el cabal.sandbox.config +cabal.project.local *~ diff --git a/Makefile b/Makefile index 0e4b2ca3..b5d5708b 100644 --- a/Makefile +++ b/Makefile @@ -1,35 +1,43 @@ CABAL?=cabal DATE := $(shell dpkg-parsechangelog 2>/dev/null | grep Date | cut -d " " -f2-) -build: tags propellor.1 dist/setup-config +build: tags propellor.1 configured $(CABAL) build - ln -sf dist/build/propellor-config/propellor-config propellor + @if [ -d dist-newstyle ]; then \ + ln -sf $$(find dist-newstyle/ -executable -type f | grep 'build/propellor-config/propellor-config$$') propellor; \ + else \ + ln -sf dist/build/propellor-config/propellor-config propellor; \ + fi install: install -d $(DESTDIR)/usr/bin $(DESTDIR)/usr/src/propellor - install -s dist/build/propellor/propellor $(DESTDIR)/usr/bin/propellor - mkdir -p dist/gittmp - $(CABAL) sdist - cat dist/propellor-*.tar.gz | (cd dist/gittmp && tar zx --strip-components=1) + if [ -d dist-newstyle ]; then \ + install -s $$(find dist-newstyle/ -executable -type f | grep 'build/propellor/propellor$$') $(DESTDIR)/usr/bin/propellor; \ + else \ + install -s dist/build/propellor/propellor $(DESTDIR)/usr/bin/propellor; \ + fi + mkdir -p gittmp + $(CABAL) sdist -o - | (cd gittmp && tar zx --strip-components=1) # cabal sdist does not preserve symlinks, so copy over file - cd dist/gittmp && for f in $$(find -type f); do rm -f $$f; cp -a ../../$$f $$f; done + cd gittmp && for f in $$(find -type f); do rm -f $$f; cp -a ../$$f $$f; done # reset mtime on files in git bundle so bundle is reproducible - find dist/gittmp -print0 | xargs -0r touch --no-dereference --date="$(DATE)" + find gittmp -print0 | xargs -0r touch --no-dereference --date="$(DATE)" export GIT_AUTHOR_NAME=build \ && export GIT_AUTHOR_EMAIL=build@buildhost \ && export GIT_AUTHOR_DATE="$(DATE)" \ && export GIT_COMMITTER_NAME=build \ && export GIT_COMMITTER_EMAIL=build@buildhost \ && export GIT_COMMITTER_DATE="$(DATE)" \ - && cd dist/gittmp && git init \ + && cd gittmp && git init \ && git add . \ && git commit -q -m "distributed version of propellor" \ && git bundle create $(DESTDIR)/usr/src/propellor/propellor.git master HEAD \ && git show-ref master --hash > $(DESTDIR)/usr/src/propellor/head - rm -rf dist/gittmp + rm -rf gittmp clean: - rm -rf dist Setup tags propellor propellor.1 privdata/local + rm -rf dist dist-newstyle configured Setup \ + tags propellor propellor.1 privdata/local find . -name \*.o -exec rm {} \; find . -name \*.hi -exec rm {} \; @@ -37,11 +45,12 @@ clean: # duplicate tags with Propellor.Property. removed from the start, as we # often import qualified by just the module base name. tags: - find . | grep -v /.git/ | grep -v /tmp/ | grep -v /dist/ | grep -v /doc/ | egrep '\.hs$$' | xargs hothasktags 2>/dev/null | perl -ne 'print; s/Propellor\.Property\.//; print' | sort > tags || true + @find . | grep -v /.git/ | grep -v /tmp/ | grep -v dist/ | grep -v /doc/ | egrep '\.hs$$' | xargs hothasktags 2>/dev/null | perl -ne 'print; s/Propellor\.Property\.//; print' | sort > tags || true -dist/setup-config: propellor.cabal +configured: propellor.cabal @if [ "$(CABAL)" = ./Setup ]; then ghc --make Setup; fi @$(CABAL) configure + touch configured propellor.1: doc/usage.mdwn doc/mdwn2man doc/mdwn2man propellor 1 < doc/usage.mdwn > propellor.1 diff --git a/debian/changelog b/debian/changelog index b46c4b4e..24bbf641 100644 --- a/debian/changelog +++ b/debian/changelog @@ -3,6 +3,8 @@ propellor (5.10.3) UNRELEASED; urgency=medium * Fix display of concurrent output from processes when using Propellor.Property.Conductor. (Reversion introduced in version 5.5.0.) + * Support bootstrapping to hosts using cabal 3.x, with new-dist directory. + * Makefile: Fix build with cabal 3.x. -- Joey Hess Fri, 05 Jun 2020 11:26:21 -0400 diff --git a/doc/forum/Bootstrapping_with_Cabal_on_Archlinux_fails/comment_4_294fcbae675879cb81aeb8d37cf3b635._comment b/doc/forum/Bootstrapping_with_Cabal_on_Archlinux_fails/comment_4_294fcbae675879cb81aeb8d37cf3b635._comment new file mode 100644 index 00000000..726067da --- /dev/null +++ b/doc/forum/Bootstrapping_with_Cabal_on_Archlinux_fails/comment_4_294fcbae675879cb81aeb8d37cf3b635._comment @@ -0,0 +1,13 @@ +[[!comment format=mdwn + username="joey" + subject="""comment 4""" + date="2020-06-17T21:33:14Z" + content=""" + cabal install --install-method=symlink --installdir=. exe:propellor --overwrite-policy=always + +But, this seems to do a lot of extra work, including generating a tarball +of all the source code, and possibly building the package again +unncessarily. And only works with a new enough cabal version. + +Ok, I've implemented it using `find`. +"""]] diff --git a/src/Propellor/Bootstrap.hs b/src/Propellor/Bootstrap.hs index d772d7c7..0fef92f1 100644 --- a/src/Propellor/Bootstrap.hs +++ b/src/Propellor/Bootstrap.hs @@ -81,7 +81,12 @@ buildCommand bs = intercalate " && " (go (getBuilder bs)) go Cabal = [ "cabal configure" , "cabal build -j1 propellor-config" - , "ln -sf dist/build/propellor-config/propellor-config propellor" + , intercalate "; " + [ "if [ -d dist-newstyle ]" + , "then ln -sf $(find dist-newstyle/ -executable -type f | grep 'build/propellor-config/propellor-config$') propellor" + , "else ln -sf dist/build/propellor-config/propellor-config propellor" + , "fi" + ] ] go Stack = [ "stack build :propellor-config" -- cgit v1.2.3