propellor 3.0.0 → 3.0.1

raw patch · 9 files changed

+698/−13 lines, 9 filesdep −concurrent-outputPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies removed: concurrent-output

API changes (from Hackage documentation)

Files

• CHANGELOG +10/−0
• debian/changelog +10/−0
• propellor.cabal +9/−8
• src/Propellor/Bootstrap.hs +0/−2
• src/Propellor/DotDir.hs +31/−2
• src/Propellor/Property/Mount.hs +1/−1
• src/System/Console/Concurrent.hs +44/−0
• src/System/Console/Concurrent/Internal.hs +559/−0
• src/System/Process/Concurrent.hs +34/−0

@@ -1,3 +1,13 @@+propellor (3.0.1) unstable; urgency=medium++  * propellor --init now runs cabal sandbox init if cabal has been+    configured with require-sandbox: True.+    Thanks, Sean Whitton+  * Re-bundled concurrent-output so propellor can be deployed to Debian+    stable systems without installing it (insecurely) from hackage.++ -- Joey Hess <id@joeyh.name>  Tue, 05 Apr 2016 13:35:54 -0400+ propellor (3.0.0) unstable; urgency=medium    * Property types have been improved to indicate what systems they target.

@@ -1,3 +1,13 @@+propellor (3.0.1) unstable; urgency=medium++  * propellor --init now runs cabal sandbox init if cabal has been+    configured with require-sandbox: True.+    Thanks, Sean Whitton+  * Re-bundled concurrent-output so propellor can be deployed to Debian+    stable systems without installing it (insecurely) from hackage.++ -- Joey Hess <id@joeyh.name>  Tue, 05 Apr 2016 13:35:54 -0400+ propellor (3.0.0) unstable; urgency=medium    * Property types have been improved to indicate what systems they target.

@@ -1,5 +1,5 @@ Name: propellor-Version: 3.0.0+Version: 3.0.1 Cabal-Version: >= 1.8 License: BSD3 Maintainer: Joey Hess <id@joeyh.name>@@ -41,12 +41,12 @@   Extensions: TypeOperators   Hs-Source-Dirs: src   Build-Depends:-    -- propellor needs to support the ghc shipped in Debian stable+    -- propellor needs to support the ghc shipped in Debian stable,+    -- and also only depends on packages in Debian stable.     base >= 4.5, base < 5,     MissingH, directory, filepath, IfElse, process, bytestring, hslogger,     unix, unix-compat, ansi-terminal, containers (>= 0.5), network, async,-    time, mtl, transformers, exceptions (>= 0.6), stm, text,-    concurrent-output+    time, mtl, transformers, exceptions (>= 0.6), stm, text  Executable propellor-config   Main-Is: config.hs@@ -57,8 +57,7 @@     base >= 4.5, base < 5,     MissingH, directory, filepath, IfElse, process, bytestring, hslogger,     unix, unix-compat, ansi-terminal, containers (>= 0.5), network, async,-    time, mtl, transformers, exceptions (>= 0.6), stm, text,-    concurrent-output+    time, mtl, transformers, exceptions (>= 0.6), stm, text  Library   GHC-Options: -Wall -fno-warn-tabs -O0@@ -68,8 +67,7 @@     base >= 4.5, base < 5,     MissingH, directory, filepath, IfElse, process, bytestring, hslogger,     unix, unix-compat, ansi-terminal, containers (>= 0.5), network, async,-    time, mtl, transformers, exceptions (>= 0.6), stm, text,-    concurrent-output+    time, mtl, transformers, exceptions (>= 0.6), stm, text    Exposed-Modules:     Propellor@@ -209,6 +207,9 @@     Utility.ThreadScheduler     Utility.Tmp     Utility.UserInfo+    System.Console.Concurrent+    System.Console.Concurrent.Internal+    System.Process.Concurrent  source-repository head   type: git

@@ -92,7 +92,6 @@ 		, "libghc-exceptions-dev" 		, "libghc-stm-dev" 		, "libghc-text-dev"-		, "libghc-concurrent-output-dev" 		, "make" 		] 	fbsddeps =@@ -111,7 +110,6 @@ 		, "hs-exceptions" 		, "hs-stm" 		, "hs-text"-		, "hs-concurrent-output" 		, "gmake" 		] 

@@ -1,4 +1,9 @@-module Propellor.DotDir where+module Propellor.DotDir+	( distrepo+	, dotPropellor+	, interactiveInit+	, checkRepoUpToDate+	) where  import Propellor.Message import Propellor.Bootstrap@@ -66,6 +71,23 @@ 		setup 	) +-- | Determine whether we need to create a cabal sandbox in ~/.propellor/,+-- which we do if the user has configured cabal to require a sandbox, and the+-- build system is cabal.+cabalSandboxRequired :: IO Bool+cabalSandboxRequired = ifM cabal+	( do+		home <- myHomeDir+		ls <- lines <$> catchDefaultIO []+			(readFile (home </> ".cabal" </> "config"))+		-- For simplicity, we assume a sane ~/.cabal/config here:+		return $ any ("True" `isInfixOf`) $+			filter ("require-sandbox:" `isPrefixOf`) ls+	, return False+	)+  where+	cabal = buildSystem >>= \bSystem -> return (bSystem == "cabal")+ say :: String -> IO () say = outputConcurrent @@ -115,7 +137,7 @@ setup = do 	sayLn "Propellor's configuration file is ~/.propellor/config.hs" 	sayLn ""-	sayLn "Lets get you started with a simple config that you can adapt"+	sayLn "Let's get you started with a simple config that you can adapt" 	sayLn "to your needs. You can start with:" 	sayLn "   A: A clone of propellor's git repository    (most flexible)" 	sayLn "   B: The bare minimum files to use propellor  (most simple)"@@ -134,6 +156,13 @@ 		, Param "propellor.buildsystem" 		, Param b 		]+	ifM cabalSandboxRequired+		( void $ boolSystem "cabal"+			[ Param "sandbox"+			, Param "init"+			]+		, return ()+		) 	buildPropellor Nothing 	sayLn "" 	sayLn "Great! Propellor is bootstrapped."

@@ -19,7 +19,7 @@ -- | A mount point for a filesystem. type MountPoint = FilePath --- | Filesystem mount options. Eg, "errors=remount-ro"+-- | Filesystem mount options. Eg, MountOpts ["errors=remount-ro"] newtype MountOpts = MountOpts [String] 	deriving Monoid 

@@ -0,0 +1,44 @@+-- | +-- Copyright: 2015 Joey Hess <id@joeyh.name>+-- 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+

@@ -0,0 +1,559 @@+{-# 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 <id@joeyh.name>+-- 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 System.Log.Logger++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+	debug ["fgProcess", showProc p]+	-- Wait for the process to exit and drop the lock.+	asyncProcessWaiter $ do+		void $ tryIO $ P.waitForProcess h+		unregisterOutputThread+		dropOutputLock+		debug ["fgProcess done", showProc p]+	return (toConcurrentProcessHandle r)+	+debug :: [String] -> IO ()+debug = debugM "concurrent-output" . unwords++showProc :: P.CreateProcess -> String+showProc = go . P.cmdspec+  where+	go (P.ShellCommand s) = s+	go (P.RawCommand c ps) = show (c, ps)++#ifndef mingw32_HOST_OS+bgProcess :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle)+bgProcess p = do+	(toouth, fromouth) <- pipe+	(toerrh, fromerrh) <- pipe+	debug ["bgProcess", showProc p]+	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

@@ -0,0 +1,34 @@+-- | +-- Copyright: 2015 Joey Hess <id@joeyh.name>+-- 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