Skip to content

Commit 5f9c75e

Browse files
rvionrvion
committed
refactor runIn, callProcess, callProcess' to take a CMD arg
1 parent c97a2f8 commit 5f9c75e

File tree

11 files changed

+80
-78
lines changed

11 files changed

+80
-78
lines changed

‎src/Stack/Build/Execute.hs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -273,7 +273,7 @@ getSetupExe setupHs tmpdir = do
273273
, toFilePath tmpOutputPath
274274
] ++
275275
["-build-runner" | wc == Ghcjs]
276-
runIn tmpdir (compilerExeName wc) menv args Nothing
276+
runCmd (CMD (Just tmpdir) (compilerExeName wc) menv args) Nothing
277277
when (wc == Ghcjs) $ renameDir tmpJsExePath jsExePath
278278
renameFile tmpExePath exePath
279279
return $ Just exePath
@@ -413,7 +413,7 @@ executePlan menv bopts baseConfigOpts locals globalPackages snapshotPackages loc
413413
}
414414
forM_ (boptsExec bopts) $ \(cmd, args) -> do
415415
$logProcessRun cmd args
416-
callProcess Nothing menv' cmd args
416+
callProcess (CMD Nothing cmd menv' args)
417417

418418
-- | Windows can't write over the current executable. Instead, we rename the
419419
-- current executable to something else and then do the copy.

‎src/Stack/Docker.hs‎

Lines changed: 10 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -349,15 +349,17 @@ runContainerAndExit getCmdArgs
349349
oldHandler <- liftIO $ installHandler sig (Catch sigHandler) Nothing
350350
return (sig, oldHandler)
351351
#endif
352-
e <- try (callProcess'
353-
(if keepStdinOpen then id else (\cp -> cp { delegate_ctlc = False }))
354-
Nothing
355-
envOverride
352+
let cmd = CMD Nothing
356353
"docker"
354+
envOverride
357355
(concat [["start"]
358356
,["-a" | not (dockerDetach docker)]
359357
,["-i" | keepStdinOpen]
360-
,[containerID]]))
358+
,[containerID]])
359+
e <- try (callProcess'
360+
(if keepStdinOpen then id else (\cp -> cp { delegate_ctlc = False }))
361+
cmd
362+
)
361363
#ifndef WINDOWS
362364
forM_ oldHandlers $ \(sig,oldHandler) ->
363365
liftIO $ installHandler sig oldHandler Nothing
@@ -646,16 +648,16 @@ pullImage envOverride docker image =
646648
do $logInfo (concatT ["Pulling image from registry: '",image,"'"])
647649
when (dockerRegistryLogin docker)
648650
(do $logInfo "You may need to log in."
649-
callProcess
651+
callProcess $ CMD
650652
Nothing
651-
envOverride
652653
"docker"
654+
envOverride
653655
(concat
654656
[["login"]
655657
,maybe [] (\n -> ["--username=" ++ n]) (dockerRegistryUsername docker)
656658
,maybe [] (\p -> ["--password=" ++ p]) (dockerRegistryPassword docker)
657659
,[takeWhile (/= '/') image]]))
658-
e <- try (callProcess Nothing envOverride "docker" ["pull",image])
660+
e <- try (callProcess (CMD Nothing "docker" envOverride ["pull",image]))
659661
case e of
660662
Left (ProcessExitedUnsuccessfully _ _) -> throwM (PullFailedException image)
661663
Right () -> return ()

‎src/Stack/Ide.hs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -73,9 +73,9 @@ ide targets useropts = do
7373
Platform _ os <- asks getPlatform
7474
when
7575
(os == OSX)
76-
(catch (callProcess (Just pwd) menv "stty" ["cbreak", "-imaxbel"])
76+
(catch (callProcess (CMD (Just pwd) "stty" menv ["cbreak", "-imaxbel"]))
7777
(\(_ :: ProcessExitedUnsuccessfully) -> return ()))
78-
callProcess (Just pwd) menv "stack-ide" args
78+
callProcess (CMD (Just pwd) "stack-ide" menv args)
7979
where
8080
includeDirs pkgopts =
8181
intercalate

‎src/Stack/Image.hs‎

Lines changed: 10 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -113,16 +113,14 @@ createDockerImage dir = do
113113
(dir </>
114114
$(mkRelFile "Dockerfile")))
115115
(unlines ["FROM " ++ base, "ADD ./ /"]))
116-
callProcess
117-
Nothing
118-
menv
119-
"docker"
120-
[ "build"
121-
, "-t"
122-
, fromMaybe
123-
(imageName (parent (parent dir)))
124-
(imgDockerImageName =<< dockerConfig)
125-
, toFilePathNoTrailingSep dir]
116+
let args = [ "build"
117+
, "-t"
118+
, fromMaybe
119+
(imageName (parent (parent dir)))
120+
(imgDockerImageName =<< dockerConfig)
121+
, toFilePathNoTrailingSep dir]
122+
callProcess $ CMD Nothing "docker" menv args
123+
126124

127125
-- | Extend the general purpose docker image with entrypoints (if
128126
-- specified).
@@ -151,10 +149,10 @@ extendDockerImageWithEntrypoint dir = do
151149
, "ENTRYPOINT [\"/usr/local/bin/" ++
152150
ep ++ "\"]"
153151
, "CMD []"]))
154-
callProcess
152+
callProcess $ CMD
155153
Nothing
156-
menv
157154
"docker"
155+
menv
158156
[ "build"
159157
, "-t"
160158
, dockerImageName ++ "-" ++ ep

‎src/Stack/New.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -213,7 +213,7 @@ runTemplateInits dir = do
213213
case configScmInit config of
214214
Nothing -> return ()
215215
Just Git ->
216-
catch (callProcess (Just dir) menv "git" ["init"])
216+
catch (callProcess $ CMD (Just dir) "git" menv ["init"])
217217
(\(_ :: ProcessExitedUnsuccessfully) ->
218218
$logInfo "git init failed to run, ignoring ...")
219219

‎src/Stack/Setup.hs‎

Lines changed: 8 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -87,7 +87,7 @@ import System.FilePath (searchPathSeparator)
8787
import qualified System.FilePath as FP
8888
import System.Process (rawSystem)
8989
import System.Process.Read
90-
import System.Process.Run (runIn)
90+
import System.Process.Run (runCmd)
9191
import Text.Printf (printf)
9292

9393
-- | Default location of the stack-setup.yaml file
@@ -512,7 +512,7 @@ upgradeCabal menv wc = do
512512
Nothing -> error "upgradeCabal: Invariant violated, dir missing"
513513
Just dir -> return dir
514514

515-
runIn dir (compilerExeName wc) menv ["Setup.hs"] Nothing
515+
runCmd (CMD (Just dir) (compilerExeName wc) menv ["Setup.hs"]) Nothing
516516
platform <- asks getPlatform
517517
let setupExe = toFilePath $ dir </>
518518
(case platform of
@@ -524,13 +524,10 @@ upgradeCabal menv wc = do
524524
, "dir="
525525
, installRoot FP.</> name'
526526
]
527-
runIn dir setupExe menv
528-
( "configure"
529-
: map dirArgument (words "lib bin data doc")
530-
)
531-
Nothing
532-
runIn dir setupExe menv ["build"] Nothing
533-
runIn dir setupExe menv ["install"] Nothing
527+
args = ( "configure": map dirArgument (words "lib bin data doc") )
528+
runCmd (CMD (Just dir) setupExe menv args) Nothing
529+
runCmd (CMD (Just dir) setupExe menv ["build"]) Nothing
530+
runCmd (CMD (Just dir) setupExe menv ["install"]) Nothing
534531
$logInfo "New Cabal library installed"
535532

536533
-- | Get the version of the system compiler, if available
@@ -1077,14 +1074,14 @@ installMsys2Windows osKey si archiveFile archiveType destDir = do
10771074
-- I couldn't find this officially documented anywhere, but you need to run
10781075
-- the shell once in order to initialize some pacman stuff. Once that run
10791076
-- happens, you can just run commands as usual.
1080-
runIn destDir "sh" menv ["--login", "-c", "true"] Nothing
1077+
runCmd (CMD (Just destDir) "sh" menv ["--login", "-c", "true"]) Nothing
10811078

10821079
-- No longer installing git, it's unreliable
10831080
-- (https://github.com/commercialhaskell/stack/issues/1046) and the
10841081
-- MSYS2-installed version has bad CRLF defaults.
10851082
--
10861083
-- Install git. We could install other useful things in the future too.
1087-
-- runIn destDir "pacman" menv ["-Sy", "--noconfirm", "git"] Nothing
1084+
-- runCmd (CMD (Just destDir) "pacman" menv ["-Sy", "--noconfirm", "git"]) Nothing
10881085

10891086
-- | Unpack a compressed tarball using 7zip. Expects a single directory in
10901087
-- the unpacked results, which is renamed to the destination directory.

‎src/Stack/Types.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -17,3 +17,4 @@ import Stack.Types.Image as X
1717
import Stack.Types.Build as X
1818
import Stack.Types.Package as X
1919
import Stack.Types.Compiler as X
20+
import Stack.Types.CMD as X

‎src/Stack/Types/CMD.hs‎

Lines changed: 16 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,16 @@
1+
module Stack.Types.CMD
2+
( CMD(..)
3+
) where
4+
5+
import System.Process.Read (EnvOverride)
6+
import Path (Path, Abs, Dir)
7+
import Data.Text (Text)
8+
import GHC.IO.Handle (Handle)
9+
10+
-- | CMD holds common infos needed to running a process in most cases
11+
data CMD = CMD
12+
{ cmdDirectoryToRunIn :: Maybe (Path Abs Dir) -- ^ directory to run in
13+
, cmdCommandToRun :: FilePath -- ^ command to run
14+
, cmdEnvOverride::EnvOverride
15+
, cmdCommandLineArguments :: [String] -- ^ command line arguments
16+
}

‎src/Stack/Upgrade.hs‎

Lines changed: 9 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -42,19 +42,15 @@ upgrade gitRepo mresolver = withCanonicalizedSystemTempDirectory "stack-upgrade"
4242
Just repo -> do
4343
remote <- liftIO $ readProcess "git" ["ls-remote", repo, "master"] []
4444
let latestCommit = head . words $ remote
45-
if latestCommit == $gitHash then do
46-
$logInfo "Already up-to-date, no upgrade required"
47-
return Nothing
48-
else do $logInfo "Cloning stack"
49-
runIn tmp "git" menv
50-
[ "clone"
51-
, repo
52-
, "stack"
53-
, "--depth"
54-
, "1"
55-
]
56-
Nothing
57-
return $ Just $ tmp </> $(mkRelDir "stack")
45+
if latestCommit == $gitHash
46+
then do
47+
$logInfo "Already up-to-date, no upgrade required"
48+
return Nothing
49+
else do
50+
$logInfo "Cloning stack"
51+
let args = [ "clone", repo , "stack", "--depth", "1"]
52+
runCmd (CMD (Just tmp) "git" menv args) Nothing
53+
return $ Just $ tmp </> $(mkRelDir "stack")
5854
Nothing -> do
5955
updateAllIndices menv
6056
caches <- getPackageCaches menv

‎src/System/Process/Run.hs‎

Lines changed: 20 additions & 29 deletions
Original file line numberDiff line numberDiff line change
@@ -5,11 +5,11 @@
55
{-# LANGUAGE TemplateHaskell #-}
66
{-# LANGUAGE OverloadedStrings #-}
77
{-# LANGUAGE FlexibleContexts #-}
8-
8+
{-# LANGUAGE RecordWildCards #-}
99
-- | Run sub-processes.
1010

1111
module System.Process.Run
12-
(runIn
12+
(runCmd
1313
,callProcess
1414
,callProcess'
1515
,ProcessExitedUnsuccessfully)
@@ -23,38 +23,38 @@ import Data.Conduit.Process hiding (callProcess)
2323
import Data.Foldable (forM_)
2424
import Data.Text (Text)
2525
import qualified Data.Text as T
26-
import Path (Path, Abs, Dir, toFilePath)
26+
import Path (toFilePath)
2727
import Prelude -- Fix AMP warning
2828
import System.Exit (exitWith, ExitCode (..))
2929
import qualified System.Process
3030
import System.Process.Read
31+
import Stack.Types (CMD(..))
3132

3233
-- | Run the given command in the given directory, inheriting stdout and stderr.
3334
--
3435
-- If it exits with anything but success, prints an error
3536
-- and then calls 'exitWith' to exit the program.
36-
runIn :: forall (m :: * -> *).
37+
runCmd :: forall (m :: * -> *).
3738
(MonadLogger m,MonadIO m,MonadBaseControl IO m)
38-
=> Path Abs Dir -- ^ directory to run in
39-
-> FilePath -- ^ command to run
40-
-> EnvOverride
41-
-> [String] -- ^ command line arguments
42-
-> Maybe Text -- ^ optional additional error message
39+
=> CMD
40+
-> Maybe Text -- ^ optional additional error message
4341
-> m ()
44-
runIn wd cmd menv args errMsg = do
45-
result <- try (callProcess (Just wd) menv cmd args)
42+
runCmd cmd@(CMD{..}) mbErrMsg = do
43+
result <- try (callProcess cmd)
4644
case result of
4745
Left (ProcessExitedUnsuccessfully _ ec) -> do
4846
$logError $
4947
T.pack $
50-
concat
48+
concat $
5149
[ "Exit code "
5250
, show ec
5351
, " while running "
54-
, show (cmd : args)
55-
, " in "
56-
, toFilePath wd]
57-
forM_ errMsg $logError
52+
, show (cmdCommandToRun : cmdCommandLineArguments)
53+
] ++ (case cmdDirectoryToRunIn of
54+
Nothing -> []
55+
Just mbDir -> [" in ", toFilePath mbDir]
56+
)
57+
forM_ mbErrMsg $logError
5858
liftIO (exitWith ec)
5959
Right () -> return ()
6060

@@ -63,14 +63,8 @@ runIn wd cmd menv args errMsg = do
6363
-- process exits unsuccessfully.
6464
--
6565
-- Inherits stdout and stderr.
66-
callProcess :: (MonadIO m, MonadLogger m)
67-
=> Maybe (Path Abs Dir) -- ^ optional directory to run in
68-
-> EnvOverride
69-
-> String -- ^ command to run
70-
-> [String] -- ^ command line arguments
71-
-> m ()
72-
callProcess =
73-
callProcess' id
66+
callProcess :: (MonadIO m, MonadLogger m) => CMD -> m ()
67+
callProcess = callProcess' id
7468

7569
-- | Like 'System.Process.callProcess', but takes an optional working directory and
7670
-- environment override, and throws 'ProcessExitedUnsuccessfully' if the
@@ -79,12 +73,9 @@ callProcess =
7973
-- Inherits stdout and stderr.
8074
callProcess' :: (MonadIO m, MonadLogger m)
8175
=> (CreateProcess -> CreateProcess)
82-
-> Maybe (Path Abs Dir) -- ^ optional directory to run in
83-
-> EnvOverride
84-
-> String -- ^ command to run
85-
-> [String] -- ^ command line arguments
76+
-> CMD
8677
-> m ()
87-
callProcess' modCP wd menv cmd0 args = do
78+
callProcess' modCP (CMD wd cmd0 menv args) = do
8879
cmd <- preProcess wd menv cmd0
8980
let c = modCP $ (proc cmd args) { delegate_ctlc = True
9081
, cwd = fmap toFilePath wd

0 commit comments

Comments
 (0)