From 332636b45c022557ec0008b0e0da38dbfc30f8cb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?R=C3=A9mi=20Vion?= Date: Tue, 24 Nov 2015 23:26:22 +0100 Subject: [PATCH] fix #1410 and refactor runIn, callProcess, etc. to take a Cmd arg introduce CMD data type add runCmd' following callProcess' model actually fixes #1410 rename CMD -> Cmd move Cmd to System.Process.Run clean redundant imports remove test.dot and test.html fix callProcess call on windows in Stack.Exec --- src/Stack/Build/Execute.hs | 4 +-- src/Stack/Docker.hs | 18 +++++----- src/Stack/Exec.hs | 4 +-- src/Stack/Ide.hs | 4 +-- src/Stack/Image.hs | 22 ++++++------ src/Stack/New.hs | 2 +- src/Stack/Setup.hs | 19 +++++----- src/Stack/Upgrade.hs | 20 +++++------ src/System/Process/Run.hs | 72 +++++++++++++++++++++----------------- 9 files changed, 83 insertions(+), 82 deletions(-) diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index 551fa6e39b..28ecc8c66e 100644 --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -273,7 +273,7 @@ getSetupExe setupHs tmpdir = do , toFilePath tmpOutputPath ] ++ ["-build-runner" | wc == Ghcjs] - runIn tmpdir (compilerExeName wc) menv args Nothing + runCmd' (\cp -> cp { std_out = UseHandle stderr }) (Cmd (Just tmpdir) (compilerExeName wc) menv args) Nothing when (wc == Ghcjs) $ renameDir tmpJsExePath jsExePath renameFile tmpExePath exePath return $ Just exePath @@ -413,7 +413,7 @@ executePlan menv bopts baseConfigOpts locals globalPackages snapshotPackages loc } forM_ (boptsExec bopts) $ \(cmd, args) -> do $logProcessRun cmd args - callProcess Nothing menv' cmd args + callProcess (Cmd Nothing cmd menv' args) -- | Windows can't write over the current executable. Instead, we rename the -- current executable to something else and then do the copy. diff --git a/src/Stack/Docker.hs b/src/Stack/Docker.hs index d13d4c0253..aad9832d32 100644 --- a/src/Stack/Docker.hs +++ b/src/Stack/Docker.hs @@ -349,15 +349,17 @@ runContainerAndExit getCmdArgs oldHandler <- liftIO $ installHandler sig (Catch sigHandler) Nothing return (sig, oldHandler) #endif - e <- try (callProcess' - (if keepStdinOpen then id else (\cp -> cp { delegate_ctlc = False })) - Nothing - envOverride + let cmd = Cmd Nothing "docker" + envOverride (concat [["start"] ,["-a" | not (dockerDetach docker)] ,["-i" | keepStdinOpen] - ,[containerID]])) + ,[containerID]]) + e <- try (callProcess' + (if keepStdinOpen then id else (\cp -> cp { delegate_ctlc = False })) + cmd + ) #ifndef WINDOWS forM_ oldHandlers $ \(sig,oldHandler) -> liftIO $ installHandler sig oldHandler Nothing @@ -646,16 +648,16 @@ pullImage envOverride docker image = do $logInfo (concatT ["Pulling image from registry: '",image,"'"]) when (dockerRegistryLogin docker) (do $logInfo "You may need to log in." - callProcess + callProcess $ Cmd Nothing - envOverride "docker" + envOverride (concat [["login"] ,maybe [] (\n -> ["--username=" ++ n]) (dockerRegistryUsername docker) ,maybe [] (\p -> ["--password=" ++ p]) (dockerRegistryPassword docker) ,[takeWhile (/= '/') image]])) - e <- try (callProcess Nothing envOverride "docker" ["pull",image]) + e <- try (callProcess (Cmd Nothing "docker" envOverride ["pull",image])) case e of Left (ProcessExitedUnsuccessfully _ _) -> throwM (PullFailedException image) Right () -> return () diff --git a/src/Stack/Exec.hs b/src/Stack/Exec.hs index a6e55736a6..365fe57740 100644 --- a/src/Stack/Exec.hs +++ b/src/Stack/Exec.hs @@ -20,7 +20,7 @@ import System.Process.Read (EnvOverride) import Control.Exception.Lifted import Data.Streaming.Process (ProcessExitedUnsuccessfully(..)) import System.Exit -import System.Process.Run (callProcess) +import System.Process.Run (callProcess, Cmd(..)) #else import System.Process.Read (envHelper, preProcess) import System.Posix.Process (executeFile) @@ -50,7 +50,7 @@ exec :: (MonadIO m, MonadLogger m, MonadThrow m, MonadBaseControl IO m) exec menv cmd0 args = do $logProcessRun cmd0 args #ifdef WINDOWS - e <- try (callProcess Nothing menv cmd0 args) + e <- try (callProcess (Cmd Nothing cmd0 menv args)) liftIO $ case e of Left (ProcessExitedUnsuccessfully _ ec) -> exitWith ec Right () -> exitSuccess diff --git a/src/Stack/Ide.hs b/src/Stack/Ide.hs index 45e69a6fcb..706d87b89f 100644 --- a/src/Stack/Ide.hs +++ b/src/Stack/Ide.hs @@ -73,9 +73,9 @@ ide targets useropts = do Platform _ os <- asks getPlatform when (os == OSX) - (catch (callProcess (Just pwd) menv "stty" ["cbreak", "-imaxbel"]) + (catch (callProcess (Cmd (Just pwd) "stty" menv ["cbreak", "-imaxbel"])) (\(_ :: ProcessExitedUnsuccessfully) -> return ())) - callProcess (Just pwd) menv "stack-ide" args + callProcess (Cmd (Just pwd) "stack-ide" menv args) where includeDirs pkgopts = intercalate diff --git a/src/Stack/Image.hs b/src/Stack/Image.hs index 246337a344..6b7a0de17f 100644 --- a/src/Stack/Image.hs +++ b/src/Stack/Image.hs @@ -113,16 +113,14 @@ createDockerImage dir = do (dir $(mkRelFile "Dockerfile"))) (unlines ["FROM " ++ base, "ADD ./ /"])) - callProcess - Nothing - menv - "docker" - [ "build" - , "-t" - , fromMaybe - (imageName (parent (parent dir))) - (imgDockerImageName =<< dockerConfig) - , toFilePathNoTrailingSep dir] + let args = [ "build" + , "-t" + , fromMaybe + (imageName (parent (parent dir))) + (imgDockerImageName =<< dockerConfig) + , toFilePathNoTrailingSep dir] + callProcess $ Cmd Nothing "docker" menv args + -- | Extend the general purpose docker image with entrypoints (if -- specified). @@ -151,10 +149,10 @@ extendDockerImageWithEntrypoint dir = do , "ENTRYPOINT [\"/usr/local/bin/" ++ ep ++ "\"]" , "CMD []"])) - callProcess + callProcess $ Cmd Nothing - menv "docker" + menv [ "build" , "-t" , dockerImageName ++ "-" ++ ep diff --git a/src/Stack/New.hs b/src/Stack/New.hs index d8ad847df2..0d4af216b6 100644 --- a/src/Stack/New.hs +++ b/src/Stack/New.hs @@ -213,7 +213,7 @@ runTemplateInits dir = do case configScmInit config of Nothing -> return () Just Git -> - catch (callProcess (Just dir) menv "git" ["init"]) + catch (callProcess $ Cmd (Just dir) "git" menv ["init"]) (\(_ :: ProcessExitedUnsuccessfully) -> $logInfo "git init failed to run, ignoring ...") diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs index 8b1d471fc6..9491db215f 100644 --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -87,7 +87,7 @@ import System.FilePath (searchPathSeparator) import qualified System.FilePath as FP import System.Process (rawSystem) import System.Process.Read -import System.Process.Run (runIn) +import System.Process.Run (runCmd, Cmd(..)) import Text.Printf (printf) -- | Default location of the stack-setup.yaml file @@ -512,7 +512,7 @@ upgradeCabal menv wc = do Nothing -> error "upgradeCabal: Invariant violated, dir missing" Just dir -> return dir - runIn dir (compilerExeName wc) menv ["Setup.hs"] Nothing + runCmd (Cmd (Just dir) (compilerExeName wc) menv ["Setup.hs"]) Nothing platform <- asks getPlatform let setupExe = toFilePath $ dir (case platform of @@ -524,13 +524,10 @@ upgradeCabal menv wc = do , "dir=" , installRoot FP. name' ] - runIn dir setupExe menv - ( "configure" - : map dirArgument (words "lib bin data doc") - ) - Nothing - runIn dir setupExe menv ["build"] Nothing - runIn dir setupExe menv ["install"] Nothing + args = ( "configure": map dirArgument (words "lib bin data doc") ) + runCmd (Cmd (Just dir) setupExe menv args) Nothing + runCmd (Cmd (Just dir) setupExe menv ["build"]) Nothing + runCmd (Cmd (Just dir) setupExe menv ["install"]) Nothing $logInfo "New Cabal library installed" -- | Get the version of the system compiler, if available @@ -1077,14 +1074,14 @@ installMsys2Windows osKey si archiveFile archiveType destDir = do -- I couldn't find this officially documented anywhere, but you need to run -- the shell once in order to initialize some pacman stuff. Once that run -- happens, you can just run commands as usual. - runIn destDir "sh" menv ["--login", "-c", "true"] Nothing + runCmd (Cmd (Just destDir) "sh" menv ["--login", "-c", "true"]) Nothing -- No longer installing git, it's unreliable -- (https://github.com/commercialhaskell/stack/issues/1046) and the -- MSYS2-installed version has bad CRLF defaults. -- -- Install git. We could install other useful things in the future too. - -- runIn destDir "pacman" menv ["-Sy", "--noconfirm", "git"] Nothing + -- runCmd (Cmd (Just destDir) "pacman" menv ["-Sy", "--noconfirm", "git"]) Nothing -- | Unpack a compressed tarball using 7zip. Expects a single directory in -- the unpacked results, which is renamed to the destination directory. diff --git a/src/Stack/Upgrade.hs b/src/Stack/Upgrade.hs index 0ae9bfb1a4..01d29ba474 100644 --- a/src/Stack/Upgrade.hs +++ b/src/Stack/Upgrade.hs @@ -50,18 +50,14 @@ upgrade gitRepo mresolver builtHash = <> "built from is not available due to how it was built. " <> "Will continue by assuming an upgrade is needed " <> "because we have no information to the contrary." - if builtHash == Just latestCommit then do - $logInfo "Already up-to-date, no upgrade required" - return Nothing - else do $logInfo "Cloning stack" - runIn tmp "git" menv - [ "clone" - , repo - , "stack" - , "--depth" - , "1" - ] - Nothing + if builtHash == Just latestCommit + then do + $logInfo "Already up-to-date, no upgrade required" + return Nothing + else do + $logInfo "Cloning stack" + let args = [ "clone", repo , "stack", "--depth", "1"] + runCmd (Cmd (Just tmp) "git" menv args) Nothing return $ Just $ tmp $(mkRelDir "stack") Nothing -> do updateAllIndices menv diff --git a/src/System/Process/Run.hs b/src/System/Process/Run.hs index 63f8459068..2a5902bceb 100644 --- a/src/System/Process/Run.hs +++ b/src/System/Process/Run.hs @@ -5,14 +5,17 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} - +{-# LANGUAGE RecordWildCards #-} -- | Run sub-processes. module System.Process.Run - (runIn + (runCmd + ,runCmd' ,callProcess ,callProcess' - ,ProcessExitedUnsuccessfully) + ,ProcessExitedUnsuccessfully + ,Cmd(..) + ) where import Control.Exception.Lifted @@ -23,38 +26,54 @@ import Data.Conduit.Process hiding (callProcess) import Data.Foldable (forM_) import Data.Text (Text) import qualified Data.Text as T -import Path (Path, Abs, Dir, toFilePath) +import Path (toFilePath) import Prelude -- Fix AMP warning import System.Exit (exitWith, ExitCode (..)) import qualified System.Process import System.Process.Read +import Path (Dir, Abs, Path) + +-- | Cmd holds common infos needed to running a process in most cases +data Cmd = Cmd + { cmdDirectoryToRunIn :: Maybe (Path Abs Dir) -- ^ directory to run in + , cmdCommandToRun :: FilePath -- ^ command to run + , cmdEnvOverride::EnvOverride + , cmdCommandLineArguments :: [String] -- ^ command line arguments + } -- | Run the given command in the given directory, inheriting stdout and stderr. -- -- If it exits with anything but success, prints an error -- and then calls 'exitWith' to exit the program. -runIn :: forall (m :: * -> *). +runCmd :: forall (m :: * -> *). + (MonadLogger m,MonadIO m,MonadBaseControl IO m) + => Cmd + -> Maybe Text -- ^ optional additional error message + -> m () +runCmd = runCmd' id + +runCmd' :: forall (m :: * -> *). (MonadLogger m,MonadIO m,MonadBaseControl IO m) - => Path Abs Dir -- ^ directory to run in - -> FilePath -- ^ command to run - -> EnvOverride - -> [String] -- ^ command line arguments - -> Maybe Text -- ^ optional additional error message + => (CreateProcess -> CreateProcess) + -> Cmd + -> Maybe Text -- ^ optional additional error message -> m () -runIn wd cmd menv args errMsg = do - result <- try (callProcess (Just wd) menv cmd args) +runCmd' modCP cmd@(Cmd{..}) mbErrMsg = do + result <- try (callProcess' modCP cmd) case result of Left (ProcessExitedUnsuccessfully _ ec) -> do $logError $ T.pack $ - concat + concat $ [ "Exit code " , show ec , " while running " - , show (cmd : args) - , " in " - , toFilePath wd] - forM_ errMsg $logError + , show (cmdCommandToRun : cmdCommandLineArguments) + ] ++ (case cmdDirectoryToRunIn of + Nothing -> [] + Just mbDir -> [" in ", toFilePath mbDir] + ) + forM_ mbErrMsg $logError liftIO (exitWith ec) Right () -> return () @@ -63,14 +82,8 @@ runIn wd cmd menv args errMsg = do -- process exits unsuccessfully. -- -- Inherits stdout and stderr. -callProcess :: (MonadIO m, MonadLogger m) - => Maybe (Path Abs Dir) -- ^ optional directory to run in - -> EnvOverride - -> String -- ^ command to run - -> [String] -- ^ command line arguments - -> m () -callProcess = - callProcess' id +callProcess :: (MonadIO m, MonadLogger m) => Cmd -> m () +callProcess = callProcess' id -- | Like 'System.Process.callProcess', but takes an optional working directory and -- environment override, and throws 'ProcessExitedUnsuccessfully' if the @@ -78,13 +91,8 @@ callProcess = -- -- Inherits stdout and stderr. callProcess' :: (MonadIO m, MonadLogger m) - => (CreateProcess -> CreateProcess) - -> Maybe (Path Abs Dir) -- ^ optional directory to run in - -> EnvOverride - -> String -- ^ command to run - -> [String] -- ^ command line arguments - -> m () -callProcess' modCP wd menv cmd0 args = do + => (CreateProcess -> CreateProcess) -> Cmd -> m () +callProcess' modCP (Cmd wd cmd0 menv args) = do cmd <- preProcess wd menv cmd0 let c = modCP $ (proc cmd args) { delegate_ctlc = True , cwd = fmap toFilePath wd