Merge pull request #3497 from khanage/3264-add-cwd-to-exec

Implement #3264 adding --cwd to exec
commercialhaskell · Oct 18, 2017 · 986bca5 · 986bca5
2 parents 154e547 + 6885470
commit 986bca5
Show file tree

Hide file tree

Showing 3 changed files with 24 additions and 2 deletions.
diff --git a/src/Stack/Options/ExecParser.hs b/src/Stack/Options/ExecParser.hs
@@ -43,6 +43,7 @@ execOptsExtraParser = eoPlainParser <|>
                          <$> eoEnvSettingsParser
                          <*> eoPackagesParser
                          <*> eoRtsOptionsParser
+                         <*> eoCwdParser
   where
     eoEnvSettingsParser :: Parser EnvSettings
     eoEnvSettingsParser = EnvSettings
@@ -70,3 +71,11 @@ execOptsExtraParser = eoPlainParser <|>
     eoPlainParser = flag' ExecOptsPlain
                           (long "plain" <>
                            help "Use an unmodified environment (only useful with Docker)")
+
+    eoCwdParser :: Parser (Maybe FilePath)
+    eoCwdParser = optional
+                  (strOption (long "cwd"
+                             <> help "Sets the working directory before executing"
+                             <> metavar "DIR"
+                             <> completer dirCompleter)
+                  )
diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs
@@ -430,6 +430,7 @@ data ExecOptsExtra
         { eoEnvSettings :: !EnvSettings
         , eoPackages :: ![String]
         , eoRtsOptions :: ![String]
+        , eoCwd :: !(Maybe FilePath)
         }
     deriving (Show)
 

diff --git a/src/main/Main.hs b/src/main/Main.hs
@@ -105,7 +105,7 @@ import qualified Stack.Upload as Upload
 import qualified System.Directory as D
 import           System.Environment (getProgName, getArgs, withArgs)
 import           System.Exit
-import           System.FilePath (pathSeparator)
+import           System.FilePath (isValid, pathSeparator)
 import           System.IO (hIsTerminalDevice, stderr, stdin, stdout, hSetBuffering, BufferMode(..), hPutStrLn, hGetEncoding, hSetEncoding)
 
 -- | Change the character encoding of the given Handle to transliterate
@@ -767,7 +767,8 @@ execCmd ExecOpts {..} go@GlobalOpts{..} =
                     (ExecRunGhc, args) ->
                         getGhcCmd "run" menv eoPackages args
                 munlockFile lk -- Unlock before transferring control away.
-                exec menv cmd args
+
+                runWithPath eoCwd $ exec menv cmd args
   where
       -- return the package-id of the first package in GHC_PACKAGE_PATH
       getPkgId menv wc name = do
@@ -788,6 +789,12 @@ execCmd ExecOpts {..} go@GlobalOpts{..} =
           pkgopts <- getPkgOpts menv wc pkgs
           return (prefix ++ compilerExeName wc, pkgopts ++ args)
 
+      runWithPath :: Maybe FilePath -> RIO EnvConfig () -> RIO EnvConfig ()
+      runWithPath path callback = case path of
+        Nothing                  -> callback
+        Just p | not (isValid p) -> throwIO $ InvalidPathForExec p
+        Just p                   -> withUnliftIO $ \ul -> D.withCurrentDirectory p $ unliftIO ul callback
+
 -- | Evaluate some haskell code inline.
 evalCmd :: EvalOpts -> GlobalOpts -> IO ()
 evalCmd EvalOpts {..} go@GlobalOpts {..} = execCmd execOpts go
@@ -923,6 +930,7 @@ hpcReportCmd hropts go = withBuildConfig go $ generateHpcReportForTargets hropts
 
 data MainException = InvalidReExecVersion String String
                    | UpgradeCabalUnusable
+                   | InvalidPathForExec FilePath
      deriving (Typeable)
 instance Exception MainException
 instance Show MainException where
@@ -934,3 +942,7 @@ instance Show MainException where
         , "; found: "
         , actual]
     show UpgradeCabalUnusable = "--upgrade-cabal cannot be used when nix is activated"
+    show (InvalidPathForExec path) = concat
+        [ "Got an invalid --cwd argument for stack exec ("
+        , path
+        , ")"]