{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}

module Test.Tasty.Process
  ( processTest
  , TestProcess (..)
  , proc
  , shell
  , defaultProcess
  , ExitCodeCheck
  , OutputCheck
  , equals
  , ignored
  , setTimeout
  )
where

import Control.DeepSeq (deepseq)
import Data.Foldable (for_)
import Data.Maybe (fromMaybe)
import GHC.IO.Handle (Handle, hClose, hFlush, hPutStr)
import System.Exit (ExitCode)
import System.IO (hGetContents)
import System.Process
  ( CmdSpec (..)
  , CreateProcess (..)
  , ProcessHandle
  , StdStream (..)
  , cleanupProcess
  , createProcess
  , waitForProcess
  )
import qualified System.Process as P (proc, shell)
import Test.Tasty (TestName, TestTree, localOption, mkTimeout, withResource)
import Test.Tasty.Providers
  ( IsTest (..)
  , Result
  , singleTest
  , testFailed
  , testPassed
  )

{- | Create a 'TestTree' from a 'TestProcess'. Here is an example of how to use
the function to create a test.

@
exampleTest :: TestTree
exampleTest =
  setTimeout (1000000) $
    processTest
      "Simple test"
      TestProcess
        { process =
          (proc "test-executable-simple" [])
        , input = Nothing
        , exitCodeCheck = equals ExitSuccess
        , stdoutCheck = equals "Hello, world!\n"
        , stderrCheck = equals ""
        }
@
-}
processTest
  :: TestName
  -> TestProcess
  -> TestTree
processTest :: String -> TestProcess -> TestTree
processTest
  String
testName
  tp :: TestProcess
tp@TestProcess {CreateProcess
process :: CreateProcess
process :: TestProcess -> CreateProcess
process} =
    IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
    -> IO ())
-> (IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
    -> TestTree)
-> TestTree
forall a. IO a -> (a -> IO ()) -> (IO a -> TestTree) -> TestTree
withResource
      (CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess CreateProcess
process)
      (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO ()
cleanupProcess
      (\IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
io -> String
-> (TestProcess,
    IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle))
-> TestTree
forall t. IsTest t => String -> t -> TestTree
singleTest String
testName (TestProcess
tp, IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
io))

{- | 'ExitCodeCheck' represents a function that given the 'ExitCode' of a process,
returns '()' if the exit code is expected, or a reason otherwise.
-}
type ExitCodeCheck = ExitCode -> Either String ()

{- | 'OutputCheck' represents a function that given the output of a process,
returns '()' if the output is expected, or a reason otherwise.
-}
type OutputCheck = String -> Either String ()

-- | 'TestProcess' is a data type that represents a process to be tested.
data TestProcess = TestProcess
  { TestProcess -> CreateProcess
process :: CreateProcess
  -- ^ The process to be tested.
  , TestProcess -> Maybe String
input :: Maybe String
  -- ^ The input to be sent to the process. If 'Nothing', no input will be sent.
  , TestProcess -> ExitCodeCheck
exitCodeCheck :: ExitCodeCheck
  -- ^ The check to be performed on the exit code of the process.
  , TestProcess -> OutputCheck
stdoutCheck :: OutputCheck
  -- ^ The check to be performed on the @stdout@ of the process.
  , TestProcess -> OutputCheck
stderrCheck :: OutputCheck
  -- ^ The check to be performed on the @stderr@ of the process.
  }

-- | The template process configuration.
defaultProcess :: TestProcess
defaultProcess :: TestProcess
defaultProcess =
  TestProcess
    { process :: CreateProcess
process = CreateProcess
forall a. HasCallStack => a
undefined
    , input :: Maybe String
input = Maybe String
forall a. Maybe a
Nothing
    , exitCodeCheck :: ExitCodeCheck
exitCodeCheck = ExitCodeCheck
forall a. a -> Either String ()
ignored
    , stdoutCheck :: OutputCheck
stdoutCheck = OutputCheck
forall a. a -> Either String ()
ignored
    , stderrCheck :: OutputCheck
stderrCheck = OutputCheck
forall a. a -> Either String ()
ignored
    }

instance
  IsTest
    (TestProcess, IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle))
  where
  run :: OptionSet
-> (TestProcess,
    IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle))
-> (Progress -> IO ())
-> IO Result
run OptionSet
_ (TestProcess
tp, IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
io) Progress -> IO ()
_ = TestProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> IO Result
runTestProcess TestProcess
tp IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
io

  testOptions :: Tagged
  (TestProcess,
   IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle))
  [OptionDescription]
testOptions = [OptionDescription]
-> Tagged
     (TestProcess,
      IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle))
     [OptionDescription]
forall a.
a
-> Tagged
     (TestProcess,
      IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return []

runTestProcess
  :: TestProcess
  -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
  -> IO Result
runTestProcess :: TestProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> IO Result
runTestProcess
  TestProcess
    { CreateProcess
process :: TestProcess -> CreateProcess
process :: CreateProcess
process
    , Maybe String
input :: TestProcess -> Maybe String
input :: Maybe String
input
    , ExitCodeCheck
exitCodeCheck :: TestProcess -> ExitCodeCheck
exitCodeCheck :: ExitCodeCheck
exitCodeCheck
    , OutputCheck
stdoutCheck :: TestProcess -> OutputCheck
stdoutCheck :: OutputCheck
stdoutCheck
    , OutputCheck
stderrCheck :: TestProcess -> OutputCheck
stderrCheck :: OutputCheck
stderrCheck
    }
  IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
io = do
    (Maybe Handle
mbStdinH, Maybe Handle
mbStdoutH, Maybe Handle
mbStderrH, ProcessHandle
ph) <- IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
io
    -- Send input to the process.
    Maybe String -> (String -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe String
input ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \String
i -> do
      (Handle -> IO ()) -> Maybe Handle -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Handle -> String -> IO ()
`hPutStr` String
i) Maybe Handle
mbStdinH
      (Handle -> IO ()) -> Maybe Handle -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Handle -> IO ()
hFlush Maybe Handle
mbStdinH
      (Handle -> IO ()) -> Maybe Handle -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Handle -> IO ()
hClose Maybe Handle
mbStdinH
    -- Wait for the process to finish and get the exit code, stdout and stderr.
    String
stdout :: String <- String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (Maybe String -> String) -> IO (Maybe String) -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Handle -> IO String) -> Maybe Handle -> IO (Maybe String)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Maybe a -> m (Maybe b)
mapM Handle -> IO String
hGetContents Maybe Handle
mbStdoutH
    String
stderr :: String <- String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (Maybe String -> String) -> IO (Maybe String) -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Handle -> IO String) -> Maybe Handle -> IO (Maybe String)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Maybe a -> m (Maybe b)
mapM Handle -> IO String
hGetContents Maybe Handle
mbStderrH
    ExitCode
exitCode :: ExitCode <- String
stderr String -> IO ExitCode -> IO ExitCode
forall a b. NFData a => a -> b -> b
`deepseq` String
stdout String -> IO ExitCode -> IO ExitCode
forall a b. NFData a => a -> b -> b
`deepseq` ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
ph
    -- Check the exit code, stdout and stderr.
    let exitFailure' :: String -> Result
exitFailure' = CreateProcess -> ExitCode -> String -> String -> String -> Result
exitFailure CreateProcess
process ExitCode
exitCode String
stderr String
stdout
    let exitCodeCheckResult :: Either String ()
exitCodeCheckResult = ExitCodeCheck
exitCodeCheck ExitCode
exitCode
    let stderrCheckResult :: Either String ()
stderrCheckResult = OutputCheck
stderrCheck String
stderr
    let stdoutCheckResult :: Either String ()
stdoutCheckResult = OutputCheck
stdoutCheck String
stdout
    let handleNotes :: String
handleNotes =
          Maybe Handle -> String -> String
forall a. Maybe a -> String -> String
printHandleNote Maybe Handle
mbStdinH String
"stdin"
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe Handle -> String -> String
forall a. Maybe a -> String -> String
printHandleNote Maybe Handle
mbStdoutH String
"stdout"
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe Handle -> String -> String
forall a. Maybe a -> String -> String
printHandleNote Maybe Handle
mbStderrH String
"stderr"
    let res :: Result
res
          | Left String
reason <- Either String ()
exitCodeCheckResult =
              String -> Result
exitFailure' (String
"ExitCode check failed.\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
reason String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
handleNotes)
          | Left String
reason <- Either String ()
stdoutCheckResult =
              String -> Result
exitFailure' (String
"Stdout check failed.\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
reason String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
handleNotes)
          | Left String
reason <- Either String ()
stderrCheckResult =
              String -> Result
exitFailure' (String
"Stderr check failed.\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
reason String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
handleNotes)
          | Bool
otherwise = String -> Result
testPassed String
""
    Result -> IO Result
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Result
res

printHandleNote :: Maybe a -> String -> String
printHandleNote :: forall a. Maybe a -> String -> String
printHandleNote (Just a
_) String
_ = String
""
printHandleNote Maybe a
Nothing String
hName =
  String
hName
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" was not captured because it is not set to `CreatePipe` in `CreateProcess`.\n"

exitFailure
  :: CreateProcess -> ExitCode -> String -> String -> String -> Result
exitFailure :: CreateProcess -> ExitCode -> String -> String -> String -> Result
exitFailure CreateProcess {CmdSpec
cmdspec :: CmdSpec
cmdspec :: CreateProcess -> CmdSpec
cmdspec} ExitCode
code String
stderr String
stdout String
reason =
  String -> Result
testFailed (String -> Result) -> String -> Result
forall a b. (a -> b) -> a -> b
$
    [String] -> String
unlines
      [ CmdSpec -> String
printCmdSpec CmdSpec
cmdspec String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" exited with code " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ExitCode -> String
forall a. Show a => a -> String
show ExitCode
code
      , String
""
      , if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
stdout
          then String
"Nothing was printed to stdout."
          else String
"stdout contained:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
stdout
      , String
""
      , if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
stderr
          then String
"Nothing was printed to stderr."
          else String
"stderr contained:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
stderr
      , String
""
      , String
reason
      ]

printCmdSpec :: CmdSpec -> String
printCmdSpec :: CmdSpec -> String
printCmdSpec (ShellCommand String
x) = String
x
printCmdSpec (RawCommand String
x [String]
y) = [String] -> String
unwords (String
x String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
y)

-- | Set the timeout (in microseconds) for a 'TestTree'.
setTimeout :: Integer -> TestTree -> TestTree
setTimeout :: Integer -> TestTree -> TestTree
setTimeout = Timeout -> TestTree -> TestTree
forall v. IsOption v => v -> TestTree -> TestTree
localOption (Timeout -> TestTree -> TestTree)
-> (Integer -> Timeout) -> Integer -> TestTree -> TestTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Timeout
mkTimeout

{- | A helper function for creating equality checks.

>>> equals "str" "str"
Right ()

>>> equals ExitSuccess ExitSuccess
Right ()

>>> equals "expected value" "actual value"
Left "expected : \"expected value\"\nactual   : \"actual value\"\n"
-}
equals :: (Show a, Eq a) => a -> a -> Either String ()
equals :: forall a. (Show a, Eq a) => a -> a -> Either String ()
equals a
expected a
actual
  | a
expected a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
actual = () -> Either String ()
forall a b. b -> Either a b
Right ()
  | Bool
otherwise =
      OutputCheck
forall a b. a -> Either a b
Left OutputCheck -> OutputCheck
forall a b. (a -> b) -> a -> b
$ String
"expected : " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
expected String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\nactual   : " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
actual String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"

{- | A helper function to ignore checks.

>>> ignored "any value"
Right ()
-}
ignored :: a -> Either String ()
ignored :: forall a. a -> Either String ()
ignored a
_ = () -> Either String ()
forall a b. b -> Either a b
Right ()

{- | Re-export of 'proc' from "System.Process" with correct default values.

Construct a `CreateProcess` record for passing to `createProcess`, representing a command to be passed to the shell.
-}
proc :: FilePath -> [String] -> CreateProcess
proc :: String -> [String] -> CreateProcess
proc String
x [String]
y =
  (String -> [String] -> CreateProcess
P.proc String
x [String]
y) {std_out = CreatePipe, std_err = CreatePipe, std_in = CreatePipe}

{- | Re-export of 'shell' from "System.Process" with correct default values.

Construct a `CreateProcess` record for passing to `createProcess`, representing a raw command with arguments.
See `RawCommand` for precise semantics of the specified `FilePath`.
-}
shell :: String -> CreateProcess
shell :: String -> CreateProcess
shell String
x = (String -> CreateProcess
P.shell String
x) {std_out = CreatePipe, std_err = CreatePipe, std_in = CreatePipe}