diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,18 @@ +concurrent-output (1.10.12) unstable; urgency=medium + + * Bugfix: createProcessConcurrent would sometimes send the process's + output to the console when it was supposed to be piped to a handle. + (1.7.5 introduced this bug) + * System.Console.Regions should be safe to use in a thread that + receives async exceptions; displayConsoleRegions and withConsoleRegion + have been made async exception safe. + (However, System.Console.Concurrent is not async exception safe.) + * Improve documentation about when withConcurrentOutput should be used. + * Remove some unused code. + * Allow building with older ansi-terminal versions, not only 0.9+. + + -- Joey Hess Wed, 10 Jun 2020 17:22:39 -0400 + concurrent-output (1.10.11) unstable; urgency=medium * Improve documentation of how to use ANSI color codes. diff --git a/System/Console/Concurrent.hs b/System/Console/Concurrent.hs --- a/System/Console/Concurrent.hs +++ b/System/Console/Concurrent.hs @@ -7,7 +7,7 @@ -- > import Control.Concurrent.Async -- > import System.Console.Concurrent -- > --- > main = withConcurrentOutput $ +-- > main = withConcurrentOutput $ do -- > outputConcurrent "washed the car\n" -- > `concurrently` -- > outputConcurrent "walked the dog\n" diff --git a/System/Console/Concurrent/Internal.hs b/System/Console/Concurrent/Internal.hs --- a/System/Console/Concurrent/Internal.hs +++ b/System/Console/Concurrent/Internal.hs @@ -102,7 +102,8 @@ 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. @@ -264,14 +265,17 @@ -- Wait for the process for symmetry with fgProcess, -- which does the same. _ <- async $ void $ tryIO $ P.waitForProcess h - outbuf <- setupOutputBuffer StdOut stdout_h - errbuf <- setupOutputBuffer StdErr stderr_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 r where rediroutput ss | willOutput ss = P.CreatePipe | otherwise = ss + mungebuf ss mh + | willOutput ss = mh + | otherwise = Nothing mungeret ss mh | willOutput ss = Nothing | otherwise = mh diff --git a/System/Console/Regions.hs b/System/Console/Regions.hs --- a/System/Console/Regions.hs +++ b/System/Console/Regions.hs @@ -145,6 +145,7 @@ -- | Controls how a region is laid out in the console. -- -- Here's an annotated example of how the console layout works. +-- Each sequence of the same letter represents a distinct region. -- -- > scrolling...... -- > scrolling...... @@ -311,7 +312,9 @@ -- | Runs the action with a new console region, closing the region when -- the action finishes or on exception. withConsoleRegion :: (MonadIO m, MonadMask m) => RegionLayout -> (ConsoleRegion -> m a) -> m a -withConsoleRegion ly = bracketIO (openConsoleRegion ly) (closeConsoleRegion) +withConsoleRegion ly = bracketIO + (openConsoleRegion ly) + (uninterruptibleMask_ . closeConsoleRegion) -- | Opens a new console region. openConsoleRegion :: LiftRegion m => RegionLayout -> m ConsoleRegion @@ -420,7 +423,9 @@ -- Note that this uses `lockOutput`, so it takes over all output to the -- console while the passed IO action is running. As well as displaying -- the console regions, this handles display of anything buffered by --- `outputConcurrent` and `createProcessConcurrent`. +-- `outputConcurrent` and `createProcessConcurrent`. So, +-- `withConcurrentOutput` and `flushConcurrentOutput` should not be run +-- while this is in use, and will block. -- -- When standard output is not an ANSI capable terminal, -- console regions are not displayed. @@ -430,17 +435,17 @@ , lockOutput $ bracket setup cleanup (const a) ) where - setup = liftIO $ do + setup = liftIO $ uninterruptibleMask $ \unmask -> do atomically $ putTMVar regionList [] endsignal <- atomically $ do s <- newTSem 1 waitTSem s return s isterm <- liftIO $ hSupportsANSI stdout - when isterm trackConsoleWidth - da <- async $ displayThread isterm endsignal + when isterm (unmask trackConsoleWidth) + da <- async $ unmask $ displayThread isterm endsignal return (isterm, da, endsignal) - cleanup (isterm, da, endsignal) = liftIO $ do + cleanup (isterm, da, endsignal) = liftIO $ uninterruptibleMask_ $ do atomically $ signalTSem endsignal void $ wait da void $ atomically $ takeTMVar regionList diff --git a/TODO b/TODO --- a/TODO +++ b/TODO @@ -0,0 +1,25 @@ +* Parts of System.Console.Concurrent may not be async exception safe. + + If a thread is running an action from that module and an async exception + is sent to it, it may result in a deadlock or other problem. + + (System.Console.Regions has been made safe.) + +* Calling setConsoleRegion with something that throws an error + will cause no further display updates to happen. + + The exception in the thunk will crash the displayThread, + and that is not waited on until the action passed to displayConsoleRegions + finishes, so the exception is deferred to that point. Of course if the + action never finishes, that hides the exception. + + It does seem this should be improved, by catching the crashing + displayThread and ideally propigating the exception immediately. + But displayConsoleRegions would need to use a different class than + the current MonadIO to be able to do that. Eg, MonadBaseControl + so lifted-async can be used, or a class that lets the action be + canceled. + + Or it could be dealt with by having setConsoleRegion force the thunk + before passing it over to the displayThread. But the instance + ToRegionContent (STM Text) seems to prevent doing that. diff --git a/Utility/Data.hs b/Utility/Data.hs deleted file mode 100644 --- a/Utility/Data.hs +++ /dev/null @@ -1,19 +0,0 @@ -{- utilities for simple data types - - - - Copyright 2013 Joey Hess - - - - License: BSD-2-clause - -} - -{-# OPTIONS_GHC -fno-warn-tabs #-} - -module Utility.Data where - -{- First item in the list that is not Nothing. -} -firstJust :: Eq a => [Maybe a] -> Maybe a -firstJust ms = case dropWhile (== Nothing) ms of - [] -> Nothing - (md:_) -> md - -eitherToMaybe :: Either a b -> Maybe b -eitherToMaybe = either (const Nothing) Just diff --git a/Utility/Exception.hs b/Utility/Exception.hs --- a/Utility/Exception.hs +++ b/Utility/Exception.hs @@ -31,8 +31,6 @@ import System.IO.Error (isDoesNotExistError, ioeGetErrorType) import GHC.IO.Exception (IOErrorType(..)) -import Utility.Data - {- Catches IO errors and returns a Bool -} catchBoolIO :: MonadCatch m => m Bool -> m Bool catchBoolIO = catchDefaultIO False @@ -86,7 +84,7 @@ tryWhenExists :: MonadCatch m => m a -> m (Maybe a) tryWhenExists a = do v <- tryJust (guard . isDoesNotExistError) a - return (eitherToMaybe v) + return (either (const Nothing) Just v) {- Catches only exceptions caused by hardware faults. - Ie, disk IO error. -} diff --git a/Utility/Monad.hs b/Utility/Monad.hs --- a/Utility/Monad.hs +++ b/Utility/Monad.hs @@ -9,62 +9,11 @@ module Utility.Monad where -import Data.Maybe -import Control.Monad - -{- Return the first value from a list, if any, satisfying the given - - predicate -} -firstM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a) -firstM _ [] = return Nothing -firstM p (x:xs) = ifM (p x) (return $ Just x , firstM p xs) - -{- Runs the action on values from the list until it succeeds, returning - - its result. -} -getM :: Monad m => (a -> m (Maybe b)) -> [a] -> m (Maybe b) -getM _ [] = return Nothing -getM p (x:xs) = maybe (getM p xs) (return . Just) =<< p x - -{- Returns true if any value in the list satisfies the predicate, - - stopping once one is found. -} -anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool -anyM p = liftM isJust . firstM p - -allM :: Monad m => (a -> m Bool) -> [a] -> m Bool -allM _ [] = return True -allM p (x:xs) = p x <&&> allM p xs - -{- Runs an action on values from a list until it succeeds. -} -untilTrue :: Monad m => [a] -> (a -> m Bool) -> m Bool -untilTrue = flip anyM - {- if with a monadic conditional. -} ifM :: Monad m => m Bool -> (m a, m a) -> m a ifM cond (thenclause, elseclause) = do c <- cond if c then thenclause else elseclause - -{- short-circuiting monadic || -} -(<||>) :: Monad m => m Bool -> m Bool -> m Bool -ma <||> mb = ifM ma ( return True , mb ) - -{- short-circuiting monadic && -} -(<&&>) :: Monad m => m Bool -> m Bool -> m Bool -ma <&&> mb = ifM ma ( mb , return False ) - -{- Same fixity as && and || -} -infixr 3 <&&> -infixr 2 <||> - -{- Runs an action, passing its value to an observer before returning it. -} -observe :: Monad m => (a -> m b) -> m a -> m a -observe observer a = do - r <- a - _ <- observer r - return r - -{- b `after` a runs first a, then b, and returns the value of a -} -after :: Monad m => m b -> m a -> m a -after = observe . const {- do nothing -} noop :: Monad m => m () diff --git a/concurrent-output.cabal b/concurrent-output.cabal --- a/concurrent-output.cabal +++ b/concurrent-output.cabal @@ -1,11 +1,11 @@ Name: concurrent-output -Version: 1.10.11 -Cabal-Version: >= 1.8 +Version: 1.10.12 +Cabal-Version: >= 1.10 License: BSD2 Maintainer: Joey Hess Author: Joey Hess, Joachim Breitner Stability: Stable -Copyright: 2015-2017 Joey Hess, 2009 Joachim Breitner +Copyright: 2015-2020 Joey Hess, 2009 Joachim Breitner License-File: LICENSE Build-Type: Simple Category: User Interfaces @@ -29,6 +29,7 @@ stmdemo.hs Library + Default-Language: Haskell98 GHC-Options: -Wall -fno-warn-tabs -O2 Build-Depends: base (>= 4.6), base < 5 , text (>= 0.11.0 && < 1.3.0) @@ -38,7 +39,7 @@ , directory (>= 1.2.0 && < 1.4.0) , transformers (>= 0.3.0 && < 0.6.0) , exceptions (>= 0.6.0 && < 0.11.0) - , ansi-terminal (>= 0.9.1 && < 0.11.0) + , ansi-terminal (>= 0.6.0 && < 0.11.0) , terminal-size (>= 0.3.0 && < 0.4.0) Exposed-Modules: System.Console.Concurrent @@ -47,7 +48,6 @@ System.Process.Concurrent Other-Modules: Utility.Monad - Utility.Data Utility.Exception if (! os(Windows))