diff options
| -rw-r--r-- | debian/changelog | 2 | ||||
| -rw-r--r-- | debian/control | 2 | ||||
| -rw-r--r-- | propellor.cabal | 6 | ||||
| -rw-r--r-- | src/Propellor/Bootstrap.hs | 1 | ||||
| -rw-r--r-- | src/Utility/ConcurrentOutput.hs | 35 |
5 files changed, 32 insertions, 14 deletions
diff --git a/debian/changelog b/debian/changelog index c5538c7f..6f75bce9 100644 --- a/debian/changelog +++ b/debian/changelog @@ -20,7 +20,7 @@ propellor (2.13.0) UNRELEASED; urgency=medium * Added Propellor.Property.Concurrent for concurrent properties. * Made the execProcess exported by propellor, and everything built on it, avoid scrambled output when run concurrently. - * Propellor now depends on STM. + * Propellor now depends on STM and text. * The cabal file now builds propellor with -O. While -O0 makes ghc take less memory while building propellor, it can lead to bad memory usage at runtime due to eg, disabled stream fusion. diff --git a/debian/control b/debian/control index 2956fdaa..97fb3e6d 100644 --- a/debian/control +++ b/debian/control @@ -18,6 +18,7 @@ Build-Depends: libghc-transformers-dev, libghc-exceptions-dev (>= 0.6), libghc-stm-dev, + libghc-text-dev, Maintainer: Gergely Nagy <algernon@madhouse-project.org> Standards-Version: 3.9.6 Vcs-Git: git://git.joeyh.name/propellor @@ -41,6 +42,7 @@ Depends: ${misc:Depends}, ${shlibs:Depends}, libghc-transformers-dev, libghc-exceptions-dev (>= 0.6), libghc-stm-dev, + libghc-text-dev, git, make, Description: property-based host configuration management in haskell diff --git a/propellor.cabal b/propellor.cabal index a07109a7..6e871d6b 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -39,7 +39,7 @@ Executable propellor Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5, IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal, containers (>= 0.5), network, async, time, QuickCheck, mtl, transformers, - exceptions (>= 0.6), stm + exceptions (>= 0.6), stm, text if (! os(windows)) Build-Depends: unix @@ -51,7 +51,7 @@ Executable propellor-config Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5, IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal, containers (>= 0.5), network, async, time, QuickCheck, mtl, transformers, - exceptions, stm + exceptions, stm, text if (! os(windows)) Build-Depends: unix @@ -62,7 +62,7 @@ Library Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5, IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal, containers (>= 0.5), network, async, time, QuickCheck, mtl, transformers, - exceptions, stm + exceptions, stm, text if (! os(windows)) Build-Depends: unix diff --git a/src/Propellor/Bootstrap.hs b/src/Propellor/Bootstrap.hs index 2318b910..21772b34 100644 --- a/src/Propellor/Bootstrap.hs +++ b/src/Propellor/Bootstrap.hs @@ -82,6 +82,7 @@ depsCommand = "( " ++ intercalate " ; " (concat [osinstall, cabalinstall]) ++ " , "libghc-transformers-dev" , "libghc-exceptions-dev" , "libghc-stm-dev" + , "libghc-text-dev" , "make" ] diff --git a/src/Utility/ConcurrentOutput.hs b/src/Utility/ConcurrentOutput.hs index 94cd4202..c24744a3 100644 --- a/src/Utility/ConcurrentOutput.hs +++ b/src/Utility/ConcurrentOutput.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BangPatterns, TypeSynonymInstances, FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-tabs #-} -- | @@ -20,6 +20,7 @@ module Utility.ConcurrentOutput ( withConcurrentOutput, flushConcurrentOutput, + Outputable(..), outputConcurrent, createProcessConcurrent, waitForProcessConcurrent, @@ -40,13 +41,14 @@ import Control.Concurrent.Async import Data.Maybe import Data.List import Data.Monoid -import qualified Data.ByteString as B import qualified System.Process as P import qualified Data.Set as S +import qualified Data.ByteString as B +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) import Utility.Monad import Utility.Exception -import Utility.FileSystemEncoding data OutputHandle = OutputHandle { outputLock :: TMVar Lock @@ -137,27 +139,40 @@ flushConcurrentOutput = do -- generating output, and flush any buffered output. lockOutput $ return () --- | Displays a string to stdout, and flush output so it's displayed. +-- | Values that can be output. +class Outputable v where + toOutput :: v -> B.ByteString + +instance Outputable B.ByteString where + toOutput = id + +instance Outputable T.Text where + toOutput = encodeUtf8 + +instance Outputable String where + toOutput = toOutput . T.pack + +-- | Displays a value to stdout, and flush output so it's displayed. -- --- Uses locking to ensure that the whole string is output atomically +-- 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 string, so it will be displayed once the other +-- not block. It buffers the value, so it will be displayed once the other -- writer is done. -outputConcurrent :: String -> IO () -outputConcurrent s = bracket setup cleanup go +outputConcurrent :: Outputable v => v -> IO () +outputConcurrent v = bracket setup cleanup go where setup = tryTakeOutputLock cleanup False = return () cleanup True = dropOutputLock go True = do - putStr s + B.hPut stdout (toOutput v) hFlush stdout go False = do bv <- outputBuffer <$> getOutputHandle oldbuf <- atomically $ takeTMVar bv - newbuf <- addBuffer (Output (B.pack (decodeW8NUL s))) oldbuf + newbuf <- addBuffer (Output (toOutput v)) oldbuf atomically $ putTMVar bv newbuf -- | This must be used to wait for processes started with |