cabal-testsuite/src/Test/Cabal/Run.hs

   1 {-# LANGUAGE DataKinds #-}
   2 {-# LANGUAGE NondecreasingIndentation #-}
   3 -- | A module for running commands in a chatty way.
   4 module Test.Cabal.Run (
   5     run,
   6     runAction,
   7     Result(..)
   8 ) where
   9
  10 import Distribution.Simple.Program.Run
  11 import Distribution.Verbosity
  12
  13 import Control.Concurrent.Async
  14 import System.Process
  15 import System.IO
  16 import System.Exit
  17 import System.Directory
  18 import System.FilePath
  19
  20 -- | The result of invoking the command line.
  21 data Result = Result
  22     { resultExitCode    :: ExitCode
  23     , resultCommand     :: String
  24     , resultOutput      :: String
  25     } deriving Show
  26
  27 -- | Run a command, streaming its output to stdout, and return a 'Result'
  28 -- with this information.
  29 run :: Verbosity -> Maybe FilePath -> [(String, Maybe String)] -> FilePath -> [String]
  30     -> Maybe String -> IO Result
  31 run verbosity mb_cwd env_overrides path0 args input =
  32     runAction verbosity mb_cwd env_overrides path0 args input (\_ -> return ())
  33
  34 runAction :: Verbosity -> Maybe FilePath -> [(String, Maybe String)] -> FilePath -> [String]
  35     -> Maybe String -> (ProcessHandle -> IO ()) -> IO Result
  36 runAction _verbosity mb_cwd env_overrides path0 args input action = do
  37     -- In our test runner, we allow a path to be relative to the
  38     -- current directory using the same heuristic as shells:
  39     -- 'foo' refers to an executable in the PATH, but './foo'
  40     -- and 'foo/bar' refer to relative files.
  41     --
  42     -- Unfortunately, we cannot just pass these relative paths directly:
  43     -- 'runProcess' resolves an executable path not with respect to the
  44     -- current working directory, but the working directory that the
  45     -- subprocess will execute in.  Thus, IF we have a relative
  46     -- path which is not a bare executable name, we have to tack on
  47     -- the CWD to make it resolve correctly
  48     cwdir <- getCurrentDirectory
  49     let path | length (splitPath path0) /= 1 && isRelative path0
  50              = cwdir </> path0
  51              | otherwise
  52              = path0
  53
  54     mb_env <- getEffectiveEnvironment env_overrides
  55     putStrLn $ "+ " ++ showCommandForUser path args
  56     (readh, writeh) <- createPipe
  57     hSetBuffering readh LineBuffering
  58     hSetBuffering writeh LineBuffering
  59     let drain = do
  60             r <- hGetContents readh
  61             putStr r -- forces the output
  62             hClose readh
  63             return r
  64     withAsync drain $ \sync -> do
  65
  66     let prc = (proc path args)
  67           { cwd = mb_cwd
  68           , env = mb_env
  69           , std_in = case input of { Just _ -> CreatePipe; Nothing -> Inherit }
  70           , std_out = UseHandle writeh
  71           , std_err = UseHandle writeh
  72           }
  73
  74     withCreateProcess prc $ \stdin_h _ _ procHandle -> do
  75
  76     case input of
  77       Just x ->
  78         case stdin_h of
  79           Just h -> hPutStr h x >> hClose h
  80           Nothing -> error "No stdin handle when input was specified!"
  81       Nothing -> return ()
  82
  83     action procHandle
  84
  85     -- wait for the program to terminate
  86     exitcode <- waitForProcess procHandle
  87     out <- wait sync
  88
  89     return Result {
  90             resultExitCode = exitcode,
  91             resultCommand = showCommandForUser path args,
  92             resultOutput = out
  93         }