hasufell
/
ghcup-hs
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Implement proper build log scrolling

This commit is contained in:
Julian Ospald 2020-03-24 16:49:18 +01:00
parent 3ff6be5435
commit 31a8316bfa
5 changed files with 482 additions and 242 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
app/ghcup-gen/GHCupDownloads.hs
View File

@ -1680,7 +1680,7 @@ ghcupDownloads = M.fromList
) )
, ( GHCup , ( GHCup
, M.fromList , M.fromList
[ ( [vver|0.1.0|] [ ( [vver|0.0.0|]
, VersionInfo [Recommended, Latest] Nothing $ M.fromList , VersionInfo [Recommended, Latest] Nothing $ M.fromList
[ ( A_64 [ ( A_64
, M.fromList , M.fromList

565
ghcup.cabal
View File

@ -1,236 +1,371 @@
cabal-version: 2.2 cabal-version: 3.0
name: ghcup
version: 0.1.0.0
synopsis: ghc toolchain installer as an exe/library
description:
A rewrite of the shell script ghcup, for providing
a more stable user experience and exposing an API.
name: ghcup homepage: https://github.com/hasufell/ghcup-hs
version: 0.1.0.0 bug-reports: https://github.com/hasufell/ghcup-hs/issues
synopsis: ghc toolchain installer as an exe/library license: LGPL-3.0-only
description: A rewrite of the shell script ghcup, for providing license-file: LICENSE
a more stable user experience and exposing an API. author: Julian Ospald
homepage: https://github.com/hasufell/ghcup-hs maintainer: hasufell@posteo.de
bug-reports: https://github.com/hasufell/ghcup-hs/issues copyright: Julian Ospald 2020
license: LGPL-3.0-only category: System
license-file: LICENSE build-type: Simple
author: Julian Ospald extra-source-files: CHANGELOG.md
maintainer: hasufell@posteo.de
copyright: Julian Ospald 2020
category: System
build-type: Simple
extra-source-files: CHANGELOG.md
source-repository head source-repository head
type: git type: git
location: https://github.com/hasufell/ghcup-hs location: https://github.com/hasufell/ghcup-hs
common HsOpenSSL { build-depends: HsOpenSSL >= 0.11 } common HsOpenSSL
common aeson { build-depends: aeson >= 1.4 } build-depends: HsOpenSSL >=0.11
common aeson-pretty { build-depends: aeson-pretty >= 0.8.8 }
common ascii-string { build-depends: ascii-string >= 1.0 }
common async { build-depends: async >= 0.8 }
common attoparsec { build-depends: attoparsec >= 0.13 }
common base { build-depends: base >= 4.12 && < 5 }
common binary { build-depends: binary >= 0.8.6.0 }
common bytestring { build-depends: bytestring >= 0.10 }
common bzlib { build-depends: bzlib >= 0.5.0.5 }
common case-insensitive { build-depends: case-insensitive >= 1.2.1.0 }
common containers { build-depends: containers >= 0.6 }
common generics-sop { build-depends: generics-sop >= 0.5 }
common haskus-utils-types { build-depends: haskus-utils-types >= 1.5 }
common haskus-utils-variant { build-depends: haskus-utils-variant >= 3.0 }
common hopenssl { build-depends: hopenssl >= 2.2.4 }
common hpath { build-depends: hpath >= 0.11 }
common hpath-directory { build-depends: hpath-directory >= 0.13.2 }
common hpath-filepath { build-depends: hpath-filepath >= 0.10.3 }
common hpath-io { build-depends: hpath-io >= 0.13.1 }
common hpath-posix { build-depends: hpath-posix >= 0.11.1 }
common http-io-streams { build-depends: http-io-streams >= 0.1.2.0 }
common io-streams { build-depends: io-streams >= 1.5 }
common language-bash { build-depends: language-bash >= 0.9 }
common lzma { build-depends: lzma >= 0.0.0.3 }
common megaparsec { build-depends: megaparsec >= 3.5.3 }
common monad-logger { build-depends: monad-logger >= 0.3.31 }
common mtl { build-depends: mtl >= 2.2 }
common optics { build-depends: optics >= 0.2 }
common optics-vl { build-depends: optics-vl >= 0.2 }
common optparse-applicative { build-depends: optparse-applicative >= 0.15.1.0 }
common parsec { build-depends: parsec >= 3.1 }
common pretty-terminal { build-depends: pretty-terminal >= 0.1.0.0 }
common regex-posix { build-depends: regex-posix >= 0.96 }
common resourcet { build-depends: resourcet >= 1.2.2 }
common safe { build-depends: safe >= 0.3.18 }
common safe-exceptions { build-depends: safe-exceptions >= 0.1 }
common streamly { build-depends: streamly >= 0.7.1 }
common streamly-posix { build-depends: streamly-posix >= 0.1.0.0 }
common streamly-bytestring { build-depends: streamly-bytestring >= 0.1.2 }
common strict-base { build-depends: strict-base >= 0.4 }
common string-interpolate { build-depends: string-interpolate >= 0.2.0.0 }
common table-layout { build-depends: table-layout >= 0.8 }
common tar-bytestring { build-depends: tar-bytestring >= 0.6.3.1 }
common template-haskell { build-depends: template-haskell >= 2.7 }
common terminal-progress-bar { build-depends: terminal-progress-bar >= 0.4.1 }
common text { build-depends: text >= 1.2 }
common time { build-depends: time >= 1.9.3 }
common transformers { build-depends: transformers >= 0.5 }
common unix { build-depends: unix >= 2.7 }
common unix-bytestring { build-depends: unix-bytestring >= 0.3 }
common uri-bytestring { build-depends: uri-bytestring >= 0.3.2.2 }
common utf8-string { build-depends: utf8-string >= 1.0 }
common vector { build-depends: vector >= 0.12 }
common versions { build-depends: versions >= 3.5 }
common waargonaut { build-depends: waargonaut >= 0.8 }
common word8 { build-depends: word8 >= 0.1.3 }
common zlib { build-depends: zlib >= 0.6.2.1 }
common aeson
build-depends: aeson >=1.4
common aeson-pretty
build-depends: aeson-pretty >=0.8.8
common ascii-string
build-depends: ascii-string >=1.0
common async
build-depends: async >=0.8
common attoparsec
build-depends: attoparsec >=0.13
common base
build-depends: base >=4.12 && <5
common binary
build-depends: binary >=0.8.6.0
common bytestring
build-depends: bytestring >=0.10
common bzlib
build-depends: bzlib >=0.5.0.5
common case-insensitive
build-depends: case-insensitive >=1.2.1.0
common concurrent-output
build-depends: concurrent-output >=1.10.11
common containers
build-depends: containers >=0.6
common generics-sop
build-depends: generics-sop >=0.5
common haskus-utils-types
build-depends: haskus-utils-types >=1.5
common haskus-utils-variant
build-depends: haskus-utils-variant >=3.0
common hopenssl
build-depends: hopenssl >=2.2.4
common hpath
build-depends: hpath >=0.11
common hpath-directory
build-depends: hpath-directory >=0.13.2
common hpath-filepath
build-depends: hpath-filepath >=0.10.3
common hpath-io
build-depends: hpath-io >=0.13.1
common hpath-posix
build-depends: hpath-posix >=0.11.1
common http-io-streams
build-depends: http-io-streams >=0.1.2.0
common io-streams
build-depends: io-streams >=1.5
common language-bash
build-depends: language-bash >=0.9
common lzma
build-depends: lzma >=0.0.0.3
common megaparsec
build-depends: megaparsec >=8.0.0
common monad-logger
build-depends: monad-logger >=0.3.31
common mtl
build-depends: mtl >=2.2
common optics
build-depends: optics >=0.2
common optics-vl
build-depends: optics-vl >=0.2
common optparse-applicative
build-depends: optparse-applicative >=0.15.1.0
common parsec
build-depends: parsec >=3.1
common pretty-terminal
build-depends: pretty-terminal >=0.1.0.0
common regex-posix
build-depends: regex-posix >=0.96
common resourcet
build-depends: resourcet >=1.2.2
common safe
build-depends: safe >=0.3.18
common safe-exceptions
build-depends: safe-exceptions >=0.1
common streamly
build-depends: streamly >=0.7.1
common streamly-posix
build-depends: streamly-posix >=0.1.0.0
common streamly-bytestring
build-depends: streamly-bytestring >=0.1.2
common strict-base
build-depends: strict-base >=0.4
common string-interpolate
build-depends: string-interpolate >=0.2.0.0
common table-layout
build-depends: table-layout >=0.8
common tar-bytestring
build-depends: tar-bytestring >=0.6.3.1
common template-haskell
build-depends: template-haskell >=2.7
common terminal-progress-bar
build-depends: terminal-progress-bar >=0.4.1
common text
build-depends: text >=1.2
common time
build-depends: time >=1.9.3
common transformers
build-depends: transformers >=0.5
common unix
build-depends: unix >=2.7
common unix-bytestring
build-depends: unix-bytestring >=0.3
common uri-bytestring
build-depends: uri-bytestring >=0.3.2.2
common utf8-string
build-depends: utf8-string >=1.0
common vector
build-depends: vector >=0.12
common versions
build-depends: versions >=3.5
common waargonaut
build-depends: waargonaut >=0.8
common word8
build-depends: word8 >=0.1.3
common zlib
build-depends: zlib >=0.6.2.1
common config common config
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -threaded ghc-options:
default-extensions: LambdaCase -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns
, MultiWayIf -fwarn-incomplete-record-updates -threaded
, PackageImports
, RecordWildCards default-extensions:
, ScopedTypeVariables LambdaCase
, StrictData MultiWayIf
, Strict PackageImports
, TupleSections RecordWildCards
ScopedTypeVariables
Strict
StrictData
TupleSections
library library
import: config import:
, base config
-- deps , base
, HsOpenSSL , HsOpenSSL
, aeson , aeson
, ascii-string , ascii-string
, async , async
, attoparsec , attoparsec
, binary , binary
, bytestring , bytestring
, bzlib , bzlib
, case-insensitive , case-insensitive
, containers , concurrent-output
, generics-sop , containers
, haskus-utils-types , generics-sop
, haskus-utils-variant , haskus-utils-types
, hopenssl , haskus-utils-variant
, hpath , hopenssl
, hpath-directory , hpath
, hpath-filepath , hpath-directory
, hpath-io , hpath-filepath
, hpath-posix , hpath-io
, http-io-streams , hpath-posix
, io-streams , http-io-streams
, language-bash , io-streams
, lzma , language-bash
, monad-logger , lzma
, mtl , monad-logger
, optics , mtl
, optics-vl , optics
, parsec , optics-vl
, pretty-terminal , parsec
, regex-posix , pretty-terminal
, resourcet , regex-posix
, safe , resourcet
, safe-exceptions , safe
, streamly , safe-exceptions
, streamly-posix , streamly
, streamly-bytestring , streamly-posix
, strict-base , streamly-bytestring
, string-interpolate , strict-base
, tar-bytestring , string-interpolate
, template-haskell , tar-bytestring
, terminal-progress-bar , template-haskell
, text , terminal-progress-bar
, time , text
, transformers , time
, unix , transformers
, unix-bytestring , unix
, uri-bytestring , unix-bytestring
, utf8-string , uri-bytestring
, vector , utf8-string
, versions , vector
, word8 , versions
, zlib , word8
exposed-modules: GHCup , zlib
GHCup.Download
GHCup.Errors -- deps
GHCup.Platform -- cabal-fmt: expand lib
GHCup.Types exposed-modules:
GHCup.Types.JSON GHCup
GHCup.Types.Optics GHCup.Download
GHCup.Utils GHCup.Errors
GHCup.Utils.Bash GHCup.Platform
GHCup.Utils.Dirs GHCup.Types
GHCup.Utils.File GHCup.Types.JSON
GHCup.Utils.Logger GHCup.Types.Optics
GHCup.Utils.Prelude GHCup.Utils
GHCup.Utils.String.QQ GHCup.Utils.Bash
GHCup.Utils.Version.QQ GHCup.Utils.Dirs
GHCup.Version GHCup.Utils.File
GHCup.Utils.Logger
GHCup.Utils.Prelude
GHCup.Utils.String.QQ
GHCup.Utils.Version.QQ
GHCup.Version
-- other-modules: -- other-modules:
-- other-extensions: -- other-extensions:
hs-source-dirs: lib hs-source-dirs: lib
executable ghcup executable ghcup
import: config import:
, base config
-- , base
, bytestring , bytestring
, containers , containers
, haskus-utils-variant , haskus-utils-variant
, monad-logger , monad-logger
, megaparsec , megaparsec
, mtl , mtl
, optparse-applicative , optparse-applicative
, text , text
, versions , versions
, hpath , hpath
, hpath-io , hpath-io
, pretty-terminal , pretty-terminal
, resourcet , resourcet
, string-interpolate , string-interpolate
, table-layout , table-layout
, uri-bytestring , uri-bytestring
, utf8-string , utf8-string
main-is: Main.hs
--
main-is: Main.hs
-- other-modules: -- other-modules:
-- other-extensions: -- other-extensions:
build-depends: ghcup build-depends: ghcup
hs-source-dirs: app/ghcup hs-source-dirs: app/ghcup
default-language: Haskell2010 default-language: Haskell2010
executable ghcup-gen executable ghcup-gen
import: config import:
, base config
-- , base
, aeson , aeson
, aeson-pretty , aeson-pretty
, bytestring , bytestring
, containers , containers
, safe-exceptions , safe-exceptions
, haskus-utils-variant , haskus-utils-variant
, monad-logger , monad-logger
, mtl , mtl
, optics , optics
, optparse-applicative , optparse-applicative
, text , text
, versions , versions
, hpath , hpath
, pretty-terminal , pretty-terminal
, resourcet , resourcet
, string-interpolate , string-interpolate
, table-layout , table-layout
, transformers , transformers
, uri-bytestring , uri-bytestring
, utf8-string , utf8-string
main-is: Main.hs
other-modules: GHCupDownloads --
Validate main-is: Main.hs
other-modules:
GHCupDownloads
Validate
-- other-extensions: -- other-extensions:
build-depends: ghcup build-depends: ghcup
hs-source-dirs: app/ghcup-gen hs-source-dirs: app/ghcup-gen
default-language: Haskell2010 default-language: Haskell2010
test-suite ghcup-test test-suite ghcup-test
default-language: Haskell2010 default-language: Haskell2010
type: exitcode-stdio-1.0 type: exitcode-stdio-1.0
hs-source-dirs: test hs-source-dirs: test
main-is: MyLibTest.hs main-is: MyLibTest.hs
build-depends: base ^>=4.12.0.0 build-depends: base >=4.12.0.0

8
lib/GHCup.hs
View File

@ -138,7 +138,7 @@ installGHCBin bDls ver mpfReq = do
lEM $ liftIO $ execLogged "./configure" lEM $ liftIO $ execLogged "./configure"
False False
["--prefix=" <> toFilePath inst] ["--prefix=" <> toFilePath inst]
[rel|ghc-configure.log|] [rel|ghc-configure|]
(Just path) (Just path)
Nothing Nothing
lEM $ liftIO $ make ["install"] (Just path) lEM $ liftIO $ make ["install"] (Just path)
@ -516,7 +516,7 @@ GhcWithLlvmCodeGen = YES|]
"./configure" "./configure"
False False
["--prefix=" <> toFilePath ghcdir] ["--prefix=" <> toFilePath ghcdir]
[rel|ghc-configure.log|] [rel|ghc-conf|]
(Just workdir) (Just workdir)
(Just (("GHC", toFilePath bghcPath) : newEnv)) (Just (("GHC", toFilePath bghcPath) : newEnv))
| otherwise -> do | otherwise -> do
@ -524,7 +524,7 @@ GhcWithLlvmCodeGen = YES|]
"./configure" "./configure"
False False
["--prefix=" <> toFilePath ghcdir, "--with-ghc=" <> toFilePath bghc] ["--prefix=" <> toFilePath ghcdir, "--with-ghc=" <> toFilePath bghc]
[rel|ghc-configure.log|] [rel|ghc-conf|]
(Just workdir) (Just workdir)
(Just newEnv) (Just newEnv)
@ -612,7 +612,7 @@ compileCabal dls tver bver jobs = do
lEM $ liftIO $ execLogged "./bootstrap.sh" lEM $ liftIO $ execLogged "./bootstrap.sh"
False False
(maybe [] (\j -> ["-j", fS (show j)]) jobs) (maybe [] (\j -> ["-j", fS (show j)]) jobs)
[rel|cabal-bootstrap.log|] [rel|cabal-bootstrap|]
(Just workdir) (Just workdir)
(Just newEnv) (Just newEnv)

2
lib/GHCup/Utils.hs
View File

@ -335,4 +335,4 @@ make args workdir = do
spaths <- catMaybes . fmap parseAbs <$> getSearchPath spaths <- catMaybes . fmap parseAbs <$> getSearchPath
has_gmake <- isJust <$> searchPath spaths [rel|gmake|] has_gmake <- isJust <$> searchPath spaths [rel|gmake|]
let mymake = if has_gmake then "gmake" else "make" let mymake = if has_gmake then "gmake" else "make"
execLogged mymake True args [rel|ghc-make.log|] workdir Nothing execLogged mymake True args [rel|ghc-make|] workdir Nothing

147
lib/GHCup/Utils/File.hs
View File

@ -1,18 +1,21 @@
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module GHCup.Utils.File where module GHCup.Utils.File where
import GHCup.Utils.Dirs import GHCup.Utils.Dirs
import GHCup.Utils.Prelude import GHCup.Utils.Prelude
import Control.Concurrent
import Control.Exception.Safe import Control.Exception.Safe
import Control.Monad import Control.Monad
import Data.ByteString import Data.ByteString ( ByteString )
import Data.ByteString.Unsafe ( unsafeUseAsCStringLen ) import Data.ByteString.Unsafe ( unsafeUseAsCStringLen )
import Data.Char import Data.Char
import Data.Foldable import Data.Foldable
import Data.Functor import Data.Functor
import Data.IORef
import Data.Maybe import Data.Maybe
import GHC.Foreign ( peekCStringLen ) import GHC.Foreign ( peekCStringLen )
import GHC.IO.Encoding ( getLocaleEncoding ) import GHC.IO.Encoding ( getLocaleEncoding )
@ -23,7 +26,10 @@ import Optics
import Streamly import Streamly
import Streamly.External.ByteString import Streamly.External.ByteString
import Streamly.External.ByteString.Lazy import Streamly.External.ByteString.Lazy
import System.Console.Pretty
import System.Console.Regions
import System.IO import System.IO
import System.IO.Error
import System.Posix.Directory.ByteString import System.Posix.Directory.ByteString
import System.Posix.FD as FD import System.Posix.FD as FD
import System.Posix.FilePath hiding ( (</>) ) import System.Posix.FilePath hiding ( (</>) )
@ -34,6 +40,9 @@ import System.Posix.Process ( ProcessStatus(..) )
import System.Posix.Types import System.Posix.Types
import qualified Control.Exception as EX
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import qualified System.Posix.Process.ByteString import qualified System.Posix.Process.ByteString
as SPPB as SPPB
import Streamly.External.Posix.DirStream import Streamly.External.Posix.DirStream
@ -42,7 +51,16 @@ import qualified Streamly.Internal.Memory.ArrayStream
import qualified Streamly.FileSystem.Handle as FH import qualified Streamly.FileSystem.Handle as FH
import qualified Streamly.Internal.Data.Unfold as SU import qualified Streamly.Internal.Data.Unfold as SU
import qualified Streamly.Prelude as S import qualified Streamly.Prelude as S
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
import qualified "unix-bytestring" System.Posix.IO.ByteString
as SPIB
data StopThread = StopThread Bool
deriving Show
instance Exception StopThread
data ProcessError = NonZeroExit Int ByteString [ByteString] data ProcessError = NonZeroExit Int ByteString [ByteString]
@ -99,7 +117,7 @@ findExecutable ex = do
-- | Execute the given command and collect the stdout, stderr and the exit code. -- | Execute the given command and collect the stdout, stderr and the exit code.
-- The command is run in a subprocess. -- The command is run in a subprocess.
executeOut :: Path b -- ^ command as filename, e.g. 'ls' executeOut :: Path b -- ^ command as filename, e.g. 'ls'
-> [ByteString] -- ^ arguments to the command -> [ByteString] -- ^ arguments to the command
-> Maybe (Path Abs) -- ^ chdir to this path -> Maybe (Path Abs) -- ^ chdir to this path
-> IO CapturedProcess -> IO CapturedProcess
@ -116,26 +134,110 @@ execLogged :: ByteString -- ^ thing to execute
-> Maybe [(ByteString, ByteString)] -- ^ optional environment -> Maybe [(ByteString, ByteString)] -- ^ optional environment
-> IO (Either ProcessError ()) -> IO (Either ProcessError ())
execLogged exe spath args lfile chdir env = do execLogged exe spath args lfile chdir env = do
ldir <- ghcupLogsDir ldir <- ghcupLogsDir
let logfile = ldir </> lfile logfile <- (ldir </>) <$> parseRel (toFilePath lfile <> ".log")
bracket (createFile (toFilePath logfile) newFilePerms) closeFd action bracket (createFile (toFilePath logfile) newFilePerms) closeFd action
where where
action fd = do action fd = do
pid <- SPPB.forkProcess $ do actionWithPipes $ \(stdoutRead, stdoutWrite) -> do
-- dup stdout -- start the thread that logs to stdout in a region
void $ dupTo fd stdOutput done <- newEmptyMVar
tid <-
forkIO
$ EX.handle (\(_ :: StopThread) -> pure ())
$ EX.handle (\(_ :: IOException) -> pure ())
$ flip finally (putMVar done ())
$ printToRegion fd stdoutRead 6
-- dup stderr -- fork our subprocess
void $ dupTo fd stdError pid <- SPPB.forkProcess $ do
void $ dupTo stdoutWrite stdOutput
void $ dupTo stdoutWrite stdError
closeFd stdoutWrite
closeFd stdoutRead
-- execute the action -- execute the action
maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
SPPB.executeFile exe spath args env SPPB.executeFile exe spath args env
closeFd stdoutWrite
-- wait for the subprocess to finish
e <- SPPB.getProcessStatus True True pid >>= \case
i@(Just (SPPB.Exited _)) -> pure $ toProcessError exe args i
i -> pure $ toProcessError exe args i
-- make sure the logging thread stops
case e of
Left _ -> EX.throwTo tid (StopThread False)
Right _ -> EX.throwTo tid (StopThread True)
takeMVar done
closeFd stdoutRead
pure e
-- Reads fdIn and logs the output in a continous scrolling area
-- of 'size' terminal lines. Also writes to a log file.
printToRegion fileFd fdIn size = do
ref <- newIORef ([] :: [ByteString])
displayConsoleRegions $ do
rs <- sequence . replicate size . openConsoleRegion $ Linear
flip finally (readTilEOF (lineAction ref rs) fdIn) -- make sure the last few lines don't get cut off
$ handle
(\(StopThread b) -> do
when b (forM_ rs closeConsoleRegion)
EX.throw (StopThread b)
)
$ readForever (lineAction ref rs) fdIn
where
-- action to perform line by line
lineAction ref rs bs' = do
modifyIORef' ref (swapRegs bs')
regs <- readIORef ref
forM (zip regs rs) $ \(bs, r) -> do
setConsoleRegion r $ do
w <- consoleWidth
return
. T.pack
. color Blue
. T.unpack
. E.decodeUtf8
. trim w
. (\b -> "[ " <> toFilePath lfile <> " ] " <> b)
$ bs
SPIB.fdWrite fileFd (bs <> "\n")
SPPB.getProcessStatus True True pid >>= \case swapRegs bs regs | length regs < size = regs ++ [bs]
i@(Just (SPPB.Exited _)) -> pure $ toProcessError exe args i | otherwise = tail regs ++ [bs]
i -> pure $ toProcessError exe args i
-- trim output line to terminal width
trim w bs | BS.length bs > w && w > 5 = BS.take (w - 4) bs <> "..."
| otherwise = bs
-- read an entire line from the file descriptor (removes the newline char)
readLine fd' = do
bs <-
handle
(\(e :: IOError) -> do
if isEOFError e then threadDelay 1000 >> pure "" else throw e
)
$ SPIB.fdRead fd' 1
if
| bs == "\n" -> pure ""
| bs == "" -> pure ""
| otherwise -> fmap (bs <>) $ readLine fd'
readForever action' fd' = do
bs <- readLine fd'
if not $ BS.null bs
then action' bs >> readForever action' fd'
else readForever action' fd'
readTilEOF action' fd' = do
bs <- readLine fd'
when (not $ BS.null bs) (action' bs >> readTilEOF action' fd')
-- | Capture the stdout and stderr of the given action, which -- | Capture the stdout and stderr of the given action, which
@ -176,10 +278,13 @@ captureOutStreams action =
} }
_ -> throwIO $ userError $ ("No such PID " ++ show pid) _ -> throwIO $ userError $ ("No such PID " ++ show pid)
where
actionWithPipes a = actionWithPipes :: ((Fd, Fd) -> IO b) -> IO b
createPipe >>= \(p1, p2) -> (flip finally) (cleanup [p1, p2]) $ a (p1, p2) actionWithPipes a =
cleanup fds = for_ fds $ \fd -> handleIO (\_ -> pure ()) $ closeFd fd createPipe >>= \(p1, p2) -> (flip finally) (cleanup [p1, p2]) $ a (p1, p2)
cleanup :: [Fd] -> IO ()
cleanup fds = for_ fds $ \fd -> handleIO (\_ -> pure ()) $ closeFd fd