From 9f733043b235f8d320213c575a91870063b93ed9 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] refactor runIn, callProcess, callProcess' to take a CMD arg --- src/Stack/Build/Execute.hs | 4 ++-- src/Stack/Docker.hs | 18 +++++++------- src/Stack/Ide.hs | 4 ++-- src/Stack/Image.hs | 22 ++++++++--------- src/Stack/New.hs | 2 +- src/Stack/Setup.hs | 19 +++++++-------- src/Stack/Types.hs | 1 + src/Stack/Types/CMD.hs | 16 +++++++++++++ src/Stack/Upgrade.hs | 22 +++++++---------- src/System/Process/Run.hs | 49 ++++++++++++++++---------------------- stack.cabal | 1 + 11 files changed, 80 insertions(+), 78 deletions(-) create mode 100644 src/Stack/Types/CMD.hs diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index 08e1bd07e0..4516754d43 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 (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..77efb1b8c8 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/Ide.hs b/src/Stack/Ide.hs index 58b8683de9..9e68c864ce 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..4db2749330 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..6c88c41cdc 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 dda1c2568f..2f586e2e4e 100644 --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -86,7 +86,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) import Text.Printf (printf) -- | Default location of the stack-setup.yaml file @@ -511,7 +511,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 @@ -523,13 +523,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 @@ -1076,14 +1073,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/Types.hs b/src/Stack/Types.hs index 4a752f03bf..2095a80428 100644 --- a/src/Stack/Types.hs +++ b/src/Stack/Types.hs @@ -17,3 +17,4 @@ import Stack.Types.Image as X import Stack.Types.Build as X import Stack.Types.Package as X import Stack.Types.Compiler as X +import Stack.Types.CMD as X diff --git a/src/Stack/Types/CMD.hs b/src/Stack/Types/CMD.hs new file mode 100644 index 0000000000..4f6d2b6f5f --- /dev/null +++ b/src/Stack/Types/CMD.hs @@ -0,0 +1,16 @@ +module Stack.Types.CMD + ( CMD(..) + ) where + +import System.Process.Read (EnvOverride) +import Path (Path, Abs, Dir) +import Data.Text (Text) +import GHC.IO.Handle (Handle) + +-- | 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 + } diff --git a/src/Stack/Upgrade.hs b/src/Stack/Upgrade.hs index e215f107f2..dde38a2d46 100644 --- a/src/Stack/Upgrade.hs +++ b/src/Stack/Upgrade.hs @@ -42,19 +42,15 @@ upgrade gitRepo mresolver = withCanonicalizedSystemTempDirectory "stack-upgrade" Just repo -> do remote <- liftIO $ readProcess "git" ["ls-remote", repo, "master"] [] let latestCommit = head . words $ remote - if latestCommit == $gitHash 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 - return $ Just $ tmp $(mkRelDir "stack") + if latestCommit == $gitHash + 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 caches <- getPackageCaches menv diff --git a/src/System/Process/Run.hs b/src/System/Process/Run.hs index 63f8459068..7657386707 100644 --- a/src/System/Process/Run.hs +++ b/src/System/Process/Run.hs @@ -5,11 +5,11 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} - +{-# LANGUAGE RecordWildCards #-} -- | Run sub-processes. module System.Process.Run - (runIn + (runCmd ,callProcess ,callProcess' ,ProcessExitedUnsuccessfully) @@ -23,38 +23,38 @@ 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 Stack.Types (CMD(..)) -- | 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) - => Path Abs Dir -- ^ directory to run in - -> FilePath -- ^ command to run - -> EnvOverride - -> [String] -- ^ command line arguments - -> Maybe Text -- ^ optional additional error message + => CMD + -> Maybe Text -- ^ optional additional error message -> m () -runIn wd cmd menv args errMsg = do - result <- try (callProcess (Just wd) menv cmd args) +runCmd cmd@(CMD{..}) mbErrMsg = do + result <- try (callProcess 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 +63,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 @@ -79,12 +73,9 @@ 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 + -> CMD -> m () -callProcess' modCP wd menv cmd0 args = do +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 diff --git a/stack.cabal b/stack.cabal index b247f08d47..c8388cc6a8 100644 --- a/stack.cabal +++ b/stack.cabal @@ -68,6 +68,7 @@ library Stack.Types Stack.Types.Internal Stack.Types.BuildPlan + Stack.Types.CMD Stack.Types.Compiler Stack.Types.Config Stack.Types.Docker