Skip to content

Commit 0d2943a

Browse files
snoybergsnoyberg
committed
Newer typed-process, clean up internal functions more
1 parent a7a5395 commit 0d2943a

15 files changed

Lines changed: 154 additions & 174 deletions

File tree

‎package.yaml‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -107,6 +107,7 @@ dependencies:
107107
- time
108108
- tls
109109
- transformers
110+
- typed-process >= 0.2.1.0
110111
- unicode-transforms
111112
- unix-compat
112113
- unliftio

‎src/Stack/Build/Execute.hs‎

Lines changed: 6 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -36,7 +36,7 @@ import Data.Conduit
3636
import qualified Data.Conduit.Binary as CB
3737
import qualified Data.Conduit.List as CL
3838
import Data.Conduit.Process.Typed
39-
(ExitCodeException (..), waitExitCode, withProcess,
39+
(ExitCodeException (..), waitExitCode,
4040
useHandleOpen, setStdin, setStdout, setStderr, getStdin,
4141
createPipe, runProcess_, getStdout,
4242
getStderr, createSource)
@@ -1130,7 +1130,11 @@ withSingleContext ActionContext {..} ExecuteEnv {..} task@Task {..} mdeps msuffi
11301130
runAndOutput :: CompilerVersion 'CVActual -> RIO env ()
11311131
runAndOutput compilerVer = withWorkingDir pkgDir $ withEnvOverride menv $ case mlogFile of
11321132
Just (_, h) ->
1133-
sinkProcessStderrStdoutHandle (toFilePath exeName) fullArgs h h
1133+
withProc (toFilePath exeName) fullArgs
1134+
$ runProcess_
1135+
. setStdin closed
1136+
. setStdout (useHandleOpen h)
1137+
. setStderr (useHandleOpen h)
11341138
Nothing ->
11351139
void $ sinkProcessStderrStdout (toFilePath exeName) fullArgs
11361140
(outputSink KeepTHLoading LevelWarn compilerVer)

‎src/Stack/Coverage.hs‎

Lines changed: 6 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -19,6 +19,7 @@ module Stack.Coverage
1919

2020
import Stack.Prelude
2121
import qualified Data.ByteString.Char8 as S8
22+
import qualified Data.ByteString.Lazy as BL
2223
import Data.List
2324
import qualified Data.Map.Strict as Map
2425
import qualified Data.Text as T
@@ -169,12 +170,13 @@ generateHpcReportInternal tixSrc reportDir report extraMarkupArgs extraReportArg
169170
-- Look for index files in the correct dir (relative to each pkgdir).
170171
["--hpcdir", toFilePathNoTrailingSep hpcRelDir, "--reset-hpcdirs"]
171172
logInfo $ "Generating " <> report
172-
outputLines <- liftM (map (S8.filter (/= '\r')) . S8.lines) $
173-
readProcessStdout "hpc"
173+
outputLines <- liftM (map (S8.filter (/= '\r')) . S8.lines . BL.toStrict) $
174+
withProc "hpc"
174175
( "report"
175176
: toFilePath tixSrc
176177
: (args ++ extraReportArgs)
177178
)
179+
readProcessStdout_
178180
if all ("(0/0)" `S8.isSuffixOf`) outputLines
179181
then do
180182
let msg html = T.concat
@@ -197,12 +199,13 @@ generateHpcReportInternal tixSrc reportDir report extraMarkupArgs extraReportArg
197199
-- Print output, stripping @\r@ characters because Windows.
198200
forM_ outputLines (logInfo . T.decodeUtf8)
199201
-- Generate the markup.
200-
void $ readProcessStdout "hpc"
202+
void $ withProc "hpc"
201203
( "markup"
202204
: toFilePath tixSrc
203205
: ("--destdir=" ++ toFilePathNoTrailingSep reportDir)
204206
: (args ++ extraMarkupArgs)
205207
)
208+
readProcessStdout_
206209
return (Just reportPath)
207210

208211
data HpcReportOpts = HpcReportOpts

‎src/Stack/Docker.hs‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -27,6 +27,7 @@ import qualified Crypto.Hash as Hash (Digest, MD5, hash)
2727
import Data.Aeson.Extended (FromJSON(..),(.:),(.:?),(.!=),eitherDecode)
2828
import Data.ByteString.Builder (stringUtf8,charUtf8,toLazyByteString)
2929
import qualified Data.ByteString.Char8 as BS
30+
import qualified Data.ByteString.Lazy as BL
3031
import qualified Data.ByteString.Lazy.Char8 as LBS
3132
import Data.Char (isSpace,toUpper,isAscii,isDigit)
3233
import Data.Conduit.List (sinkNull)
@@ -843,7 +844,7 @@ removeDirectoryContents path excludeDirs excludeFiles =
843844
readDockerProcess
844845
:: HasEnvOverride env
845846
=> [String] -> RIO env BS.ByteString
846-
readDockerProcess = readProcessStdout "docker"
847+
readDockerProcess args = BL.toStrict <$> withProc "docker" args readProcessStdout_ -- FIXME stderr isn't logged with logError, should it be?
847848

848849
-- | Name of home directory within docker sandbox.
849850
homeDirName :: Path Rel Dir

‎src/Stack/GhcPkg.hs‎

Lines changed: 13 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -23,6 +23,7 @@ module Stack.GhcPkg
2323

2424
import Stack.Prelude
2525
import qualified Data.ByteString.Char8 as S8
26+
import qualified Data.ByteString.Lazy as BL
2627
import Data.List
2728
import qualified Data.Text as T
2829
import qualified Data.Text.Encoding as T
@@ -65,12 +66,14 @@ ghcPkg :: HasEnvOverride env
6566
ghcPkg wc pkgDbs args = do
6667
eres <- go
6768
case eres of
68-
Left _ -> do
69-
mapM_ (createDatabase wc) pkgDbs
70-
go
71-
Right _ -> return eres
69+
Left _ -> do
70+
mapM_ (createDatabase wc) pkgDbs
71+
go
72+
Right _ -> return eres
7273
where
73-
go = tryProcessStdout (ghcPkgExeName wc) args'
74+
go = fmap (fmap BL.toStrict)
75+
$ tryAny
76+
$ withProc (ghcPkgExeName wc) args' readProcessStdout_
7477
args' = packageDbFlags pkgDbs ++ args
7578

7679
-- | Create a package database in the given directory, if it doesn't exist.
@@ -99,12 +102,9 @@ createDatabase wc db = do
99102
-- finding out it isn't the hard way
100103
ensureDir (parent db)
101104
return ["init", toFilePath db]
102-
eres <- tryProcessStdout (ghcPkgExeName wc) args
103-
case eres of
104-
Left e -> do
105-
logError $ T.pack $ "Unable to create package database at " ++ toFilePath db
106-
throwIO e
107-
Right _ -> return ()
105+
void $ withProc (ghcPkgExeName wc) args $ \pc ->
106+
readProcessStdout_ pc `onException`
107+
logError (T.pack $ "Unable to create package database at " ++ toFilePath db)
108108

109109
-- | Get the name to use for "ghc-pkg", given the compiler version.
110110
ghcPkgExeName :: WhichCompiler -> String
@@ -139,8 +139,8 @@ findGhcPkgField wc pkgDbs name field = do
139139
return $
140140
case result of
141141
Left{} -> Nothing
142-
Right lbs ->
143-
fmap (stripCR . T.decodeUtf8) $ listToMaybe $ S8.lines lbs
142+
Right bs ->
143+
fmap (stripCR . T.decodeUtf8) $ listToMaybe $ S8.lines bs
144144

145145
-- | Get the version of the package
146146
findGhcPkgVersion :: HasEnvOverride env

‎src/Stack/Hoogle.hs‎

Lines changed: 6 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -9,7 +9,7 @@ module Stack.Hoogle
99
) where
1010

1111
import Stack.Prelude
12-
import qualified Data.ByteString.Char8 as S8
12+
import qualified Data.ByteString.Lazy.Char8 as BL8
1313
import Data.Char (isSpace)
1414
import Data.List (find)
1515
import qualified Data.Set as Set
@@ -157,7 +157,9 @@ hoogleCmd (args,setup,rebuild) go = withBuildConfig go $ do
157157
eres <- case mhooglePath of
158158
Nothing -> return $ Left "Hoogle isn't installed."
159159
Just hooglePath -> do
160-
result <- withEnvOverride menv $ tryProcessStdout (toFilePath hooglePath) ["--numeric-version"]
160+
result <- withEnvOverride menv
161+
$ withProc (toFilePath hooglePath) ["--numeric-version"]
162+
$ tryAny . readProcessStdout_
161163
let unexpectedResult got = Left $ T.concat
162164
[ "'"
163165
, T.pack (toFilePath hooglePath)
@@ -166,8 +168,8 @@ hoogleCmd (args,setup,rebuild) go = withBuildConfig go $ do
166168
]
167169
return $ case result of
168170
Left err -> unexpectedResult $ T.pack (show err)
169-
Right bs -> case parseVersionFromString (takeWhile (not . isSpace) (S8.unpack bs)) of
170-
Nothing -> unexpectedResult $ T.pack (S8.unpack bs)
171+
Right bs -> case parseVersionFromString (takeWhile (not . isSpace) (BL8.unpack bs)) of
172+
Nothing -> unexpectedResult $ T.pack (BL8.unpack bs)
171173
Just ver
172174
| ver >= hoogleMinVersion -> Right hooglePath
173175
| otherwise -> Left $ T.concat

‎src/Stack/Prelude.hs‎

Lines changed: 60 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,10 +1,14 @@
11
{-# LANGUAGE NoImplicitPrelude #-}
22
{-# LANGUAGE OverloadedStrings #-}
3+
{-# LANGUAGE ScopedTypeVariables #-}
34
module Stack.Prelude
45
( withSourceFile
56
, withSinkFile
67
, withSinkFileCautious
78
, withSystemTempDir
9+
, sinkProcessStderrStdout
10+
, sinkProcessStdout
11+
, logProcessStderrStdout
812
, module X
913
) where
1014

@@ -13,13 +17,19 @@ import Path as X (Abs, Dir, File, Path, Rel,
1317
toFilePath)
1418
import qualified Path.IO
1519

16-
import Data.Conduit.Binary (sourceHandle, sinkHandle)
17-
1820
import qualified System.IO as IO
1921
import qualified System.Directory as Dir
2022
import qualified System.FilePath as FP
2123
import System.IO.Error (isDoesNotExistError)
2224

25+
import Data.Conduit.Binary (sourceHandle, sinkHandle)
26+
import qualified Data.Conduit.Binary as CB
27+
import qualified Data.Conduit.List as CL
28+
import Data.Conduit.Process.Typed (withLoggedProcess_, createSource)
29+
import RIO.Process (HasEnvOverride, setStdin, closed, getStderr, getStdout, withProc, withProcess_, setStdout, setStderr)
30+
import Data.Text.Encoding (decodeUtf8With)
31+
import Data.Text.Encoding.Error (lenientDecode)
32+
2333
-- | Get a source for a file. Unlike @sourceFile@, doesn't require
2434
-- @ResourceT@. Unlike explicit @withBinaryFile@ and @sourceHandle@
2535
-- usage, you can't accidentally use @WriteMode@ instead of
@@ -53,3 +63,51 @@ withSinkFileCautious fp inner =
5363
-- | Path version
5464
withSystemTempDir :: MonadUnliftIO m => String -> (Path Abs Dir -> m a) -> m a
5565
withSystemTempDir str inner = withRunInIO $ \run -> Path.IO.withSystemTempDir str $ run . inner
66+
67+
-- | Consume the stdout and stderr of a process feeding strict 'ByteString's to the consumers.
68+
--
69+
-- Throws a 'ReadProcessException' if unsuccessful in launching, or 'ProcessExitedUnsuccessfully' if the process itself fails.
70+
sinkProcessStderrStdout
71+
:: forall e o env. HasEnvOverride env
72+
=> String -- ^ Command
73+
-> [String] -- ^ Command line arguments
74+
-> ConduitM ByteString Void (RIO env) e -- ^ Sink for stderr
75+
-> ConduitM ByteString Void (RIO env) o -- ^ Sink for stdout
76+
-> RIO env (e,o)
77+
sinkProcessStderrStdout name args sinkStderr sinkStdout =
78+
withProc name args $ \pc0 -> do
79+
let pc = setStdin closed
80+
$ setStdout createSource
81+
$ setStderr createSource
82+
pc0
83+
withProcess_ pc $ \p ->
84+
runConduit (getStderr p .| sinkStderr) `concurrently`
85+
runConduit (getStdout p .| sinkStdout)
86+
87+
-- | Consume the stdout of a process feeding strict 'ByteString's to a consumer.
88+
-- If the process fails, spits out stdout and stderr as error log
89+
-- level. Should not be used for long-running processes or ones with
90+
-- lots of output; for that use 'sinkProcessStdoutLogStderr'.
91+
--
92+
-- Throws a 'ReadProcessException' if unsuccessful.
93+
sinkProcessStdout
94+
:: HasEnvOverride env
95+
=> String -- ^ Command
96+
-> [String] -- ^ Command line arguments
97+
-> ConduitM ByteString Void (RIO env) a -- ^ Sink for stdout
98+
-> RIO env a
99+
sinkProcessStdout name args sinkStdout =
100+
withProc name args $ \pc ->
101+
withLoggedProcess_ (setStdin closed pc) $ \p -> runConcurrently
102+
$ Concurrently (runConduit $ getStderr p .| CL.sinkNull)
103+
*> Concurrently (runConduit $ getStdout p .| sinkStdout)
104+
105+
logProcessStderrStdout
106+
:: (HasCallStack, HasEnvOverride env)
107+
=> String
108+
-> [String]
109+
-> RIO env ()
110+
logProcessStderrStdout name args = do
111+
let logLines = CB.lines .| CL.mapM_ (logInfo . decodeUtf8With lenientDecode)
112+
((), ()) <- sinkProcessStderrStdout name args logLines logLines
113+
return ()

‎src/Stack/Setup.hs‎

Lines changed: 18 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -39,8 +39,8 @@ import Control.Monad.State (get, put, modify)
3939
import "cryptonite" Crypto.Hash (SHA1(..), SHA256(..))
4040
import Data.Aeson.Extended
4141
import qualified Data.ByteString as S
42-
import qualified Data.ByteString.Char8 as S8
4342
import qualified Data.ByteString.Lazy as LBS
43+
import qualified Data.ByteString.Lazy.Char8 as BL8
4444
import Data.Char (isSpace)
4545
import Data.Conduit (await, yield, awaitForever)
4646
import Data.Conduit.Lazy (lazyConsume)
@@ -570,10 +570,14 @@ getGhcBuilds = do
570570
"PATH"
571571
("/sbin:/usr/sbin" <> maybe "" (":" <>) (Map.lookup "PATH" m))
572572
m
573-
eldconfigOut <- withModifyEnvOverride sbinEnv $ tryProcessStdout "ldconfig" ["-p"]
573+
eldconfigOut
574+
<- withModifyEnvOverride sbinEnv
575+
$ withProc "ldconfig" ["-p"]
576+
$ tryAny . readProcessStdout_
574577
let firstWords = case eldconfigOut of
575578
Right ldconfigOut -> mapMaybe (listToMaybe . T.words) $
576-
T.lines $ T.decodeUtf8With T.lenientDecode ldconfigOut
579+
T.lines $ T.decodeUtf8With T.lenientDecode
580+
$ LBS.toStrict ldconfigOut
577581
Left _ -> []
578582
checkLib lib
579583
| libT `elem` firstWords = do
@@ -754,10 +758,10 @@ getSystemCompiler wc = do
754758
exists <- doesExecutableExist menv exeName
755759
if exists
756760
then do
757-
eres <- tryProcessStdout exeName ["--info"]
761+
eres <- withProc exeName ["--info"] $ tryAny . readProcessStdout_
758762
let minfo = do
759-
Right bs <- Just eres
760-
pairs_ <- readMaybe $ S8.unpack bs :: Maybe [(String, String)]
763+
Right lbs <- Just eres
764+
pairs_ <- readMaybe $ BL8.unpack lbs :: Maybe [(String, String)]
761765
version <- lookup "Project version" pairs_ >>= parseVersionFromString
762766
arch <- lookup "Target platform" pairs_ >>= simpleParse . takeWhile (/= '-')
763767
return (version, arch)
@@ -1330,10 +1334,10 @@ buildInGhcjsEnv envConfig boptsCli = do
13301334

13311335
getCabalInstallVersion :: HasEnvOverride env => RIO env (Maybe Version)
13321336
getCabalInstallVersion = do
1333-
ebs <- tryProcessStdout "cabal" ["--numeric-version"]
1334-
liftIO $ case ebs of
1337+
ebs <- withProc "cabal" ["--numeric-version"] $ tryAny . readProcessStdout_
1338+
case ebs of
13351339
Left _ -> return Nothing
1336-
Right bs -> Just <$> parseVersion (T.dropWhileEnd isSpace (T.decodeUtf8 bs))
1340+
Right bs -> Just <$> parseVersion (T.dropWhileEnd isSpace (T.decodeUtf8 (LBS.toStrict bs)))
13371341

13381342
-- | Check if given processes appear to be present, throwing an exception if
13391343
-- missing.
@@ -1628,10 +1632,10 @@ sanityCheck wc = withSystemTempDir "stack-sanity-check" $ \dir -> do
16281632
menv <- view envOverrideL
16291633
ghc <- liftIO $ join $ findExecutable menv exeName
16301634
logDebug $ "Performing a sanity check on: " <> T.pack (toFilePath ghc)
1631-
eres <- withWorkingDir dir $ tryProcessStdout exeName
1635+
eres <- withWorkingDir dir $ withProc exeName
16321636
[ fp
16331637
, "-no-user-package-db"
1634-
]
1638+
] $ try . readProcessStdout_
16351639
case eres of
16361640
Left e -> throwIO $ GHCSanityCheckCompileFailed e ghc
16371641
Right _ -> return () -- TODO check that the output of running the command is correct
@@ -1687,7 +1691,7 @@ getUtf8EnvVars compilerVer =
16871691
Map.empty
16881692
else do
16891693
-- Get a list of known locales by running @locale -a@.
1690-
elocales <- tryProcessStdout "locale" ["-a"]
1694+
elocales <- tryAny $ withProc "locale" ["-a"] readProcessStdout_
16911695
let
16921696
-- Filter the list to only include locales with UTF-8 encoding.
16931697
utf8Locales =
@@ -1698,8 +1702,8 @@ getUtf8EnvVars compilerVer =
16981702
isUtf8Locale
16991703
(T.lines $
17001704
T.decodeUtf8With
1701-
T.lenientDecode
1702-
locales)
1705+
T.lenientDecode $
1706+
LBS.toStrict locales)
17031707
mfallback = getFallbackLocale utf8Locales
17041708
when
17051709
(isNothing mfallback)

‎src/Stack/Setup/Installed.hs‎

Lines changed: 5 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -26,6 +26,7 @@ module Stack.Setup.Installed
2626
import Stack.Prelude
2727
import qualified Data.ByteString as B
2828
import qualified Data.ByteString.Char8 as S8
29+
import qualified Data.ByteString.Lazy as BL
2930
import Data.List hiding (concat, elem, maximumBy)
3031
import qualified Data.Text as T
3132
import qualified Data.Text.Encoding as T
@@ -95,8 +96,8 @@ getCompilerVersion wc =
9596
case wc of
9697
Ghc -> do
9798
logDebug "Asking GHC for its version"
98-
bs <- readProcessStdout "ghc" ["--numeric-version"]
99-
let (_, ghcVersion) = versionFromEnd bs
99+
bs <- withProc "ghc" ["--numeric-version"] readProcessStdout_
100+
let (_, ghcVersion) = versionFromEnd $ BL.toStrict bs
100101
x <- GhcVersion <$> parseVersion (T.decodeUtf8 ghcVersion)
101102
logDebug $ "GHC version is: " <> compilerVersionText x
102103
return x
@@ -105,8 +106,8 @@ getCompilerVersion wc =
105106
-- Output looks like
106107
--
107108
-- The Glorious Glasgow Haskell Compilation System for JavaScript, version 0.1.0 (GHC 7.10.2)
108-
bs <- readProcessStdout "ghcjs" ["--version"]
109-
let (rest, ghcVersion) = T.decodeUtf8 <$> versionFromEnd bs
109+
bs <- withProc "ghcjs" ["--version"] readProcessStdout_
110+
let (rest, ghcVersion) = T.decodeUtf8 <$> versionFromEnd (BL.toStrict bs)
110111
(_, ghcjsVersion) = T.decodeUtf8 <$> versionFromEnd rest
111112
GhcjsVersion <$> parseVersion ghcjsVersion <*> parseVersion ghcVersion
112113
where

0 commit comments

Comments
 (0)