{-# LANGUAGE CPP #-}
--
-- Copyright (c) 2005,2009,2012,2013   Stefan Wehr - http://www.stefanwehr.de
--
-- This library is free software; you can redistribute it and/or
-- modify it under the terms of the GNU Lesser General Public
-- License as published by the Free Software Foundation; either
-- version 2.1 of the License, or (at your option) any later version.
--
-- This library is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-- Lesser General Public License for more details.
--
-- You should have received a copy of the GNU Lesser General Public
-- License along with this library; if not, write to the Free Software
-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA
--

{- |

A /black box test/ in the terminology of the HTF consists of a
driver program that is run in various input files. For each input
file, the HTF checks that the driver program exits with the
correct exit code and that it produces the expected output.
The samples directory of the HTF source tree shows an example
for a black box test, see <https://github.com/skogsbaer/HTF/tree/master/sample>.

/NOTE:/ If you use black box tests, you have to compile your program
with the @-threaded@ option. Otherwise, your program just blocks
indefinitely!

-}
module Test.Framework.BlackBoxTest (

  BBTArgs(..), defaultBBTArgs,

  blackBoxTests,

  Diff, defaultDiff

) where

#if !MIN_VERSION_base(4,6,0)
import Prelude hiding ( catch )
#endif

import System.Exit
import System.Directory
import qualified Data.Map as Map

import Test.Framework.Process
import Test.Framework.TestInterface
import Test.Framework.TestManager
import Test.Framework.Utils

{- |
The type of a function comparing the content of a file
against a string, similar to the unix tool @diff@.
The first parameter is the name of the file containing the
expected output. If this parameter is 'Nothing', then output
should not be checked. The second parameter is the actual output produced.
If the result is 'Nothing' then no difference was found.
Otherwise, a 'Just' value contains a string explaining the
difference.
-}
type Diff = Maybe FilePath -> String -> IO (Maybe String)

data BlackBoxTestCfg = BlackBoxTestCfg
                       { bbtCfg_shouldFail  :: Bool
                       , bbtCfg_cmd         :: String
                       , bbtCfg_stdinFile   :: Maybe FilePath
                       , bbtCfg_stdoutFile  :: Maybe FilePath -- ^ path to file holding expected output on stdout
                       , bbtCfg_stderrFile  :: Maybe FilePath -- ^ path to file holding expected output on stderr
                       , bbtCfg_verbose     :: Bool
                       -- functions for comparing output on stdout and stderr.
                       , bbtCfg_stdoutCmp   :: Diff
                       , bbtCfg_stderrCmp   :: Diff
                       }

runBlackBoxTest :: BlackBoxTestCfg -> Assertion
runBlackBoxTest bbt =
    do inp <- case bbtCfg_stdinFile bbt of
                Nothing -> return Nothing
                Just f -> do s <- readFile f
                             return $ Just s
       (out,err,exit) <- popenShell (bbtCfg_cmd bbt) inp
       case exit of
         ExitSuccess | bbtCfg_shouldFail bbt
           -> blackBoxTestFail ("test is supposed to fail but succeeded")
         ExitFailure i | not $ bbtCfg_shouldFail bbt
           -> do let details =
                         if (bbtCfg_verbose bbt)
                            then ("stderr for " ++ show (bbtCfg_cmd bbt) ++ ":\n" ++
                                  err ++ endOfOutput "stderr" ++ "\n" ++
                                  "stdout for " ++ show (bbtCfg_cmd bbt) ++ ":\n" ++
                                  out ++ endOfOutput "stdout") ++ "\n"
                            else ""
                 blackBoxTestFail (details ++
                                   "test is supposed to succeed but failed " ++
                                   "with exit code " ++ show i)
         _ -> do cmpOut <- cmp (bbtCfg_stdoutFile bbt) (bbtCfg_stdoutCmp bbt)
                             out "Mismatch on stdout:\n"
                 cmpErr <- cmp (bbtCfg_stderrFile bbt) (bbtCfg_stderrCmp bbt)
                             err "Mismatch on stderr:\n"
                 case (cmpOut, cmpErr) of
                  (Nothing, Nothing) -> return ()
                  (x1, x2) ->
                      do let details = ensureNewline (x1 `concatMaybes` x2)
                         blackBoxTestFail details
    where cmp expectFile cmpAction real label =
              do res <- cmpAction expectFile real
                 case res of
                   Nothing -> return Nothing
                   Just s -> return $ Just (label ++ s)
          concatMaybes Nothing Nothing = ""
          concatMaybes (Just s) Nothing = s
          concatMaybes (Nothing) (Just s) = s
          concatMaybes (Just s1) (Just s2) = s1 ++ "\n" ++ s2

endOfOutput :: String -> String
endOfOutput s = "[end of " ++ s ++ "]"

blackBoxTestFail :: String -> Assertion
blackBoxTestFail s = failHTF $ mkFullTestResult Fail (Just s)

{- |
Use a value of this datatype to customize various aspects
of your black box tests.
-}
data BBTArgs = BBTArgs { bbtArgs_stdinSuffix    :: String -- ^ File extension for the file used as stdin.
                       , bbtArgs_stdoutSuffix   :: String -- ^ File extension for the file specifying expected output on stdout.
                       , bbtArgs_stderrSuffix   :: String -- ^ File extension for the file specifying expected output on stderr.
                       , bbtArgs_dynArgsName    :: String -- ^ Name of a file defining various arguments for executing the tests contained in a subdirectory of the test hierarchy. If a directory contains a such-named file, the arguments apply to all testfiles directly contained in this directory. See the documentation of 'blackBoxTests' for a specification of the argument file format. Default: BBTArgs
                       , bbtArgs_verbose        :: Bool   -- ^ Be verbose or not.
                       , bbtArgs_stdoutDiff     :: Diff   -- ^ Diff program for comparing output on stdout with the expected value.
                       , bbtArgs_stderrDiff     :: Diff   -- ^ Diff program for comparing output on stderr with the expected value.
                       }

{- |
Sensible default values for 'BBTArgs':

@
defaultBBTArgs = BBTArgs { bbtArgs_stdinSuffix    = \".in\"
                         , bbtArgs_stdoutSuffix   = \".out\"
                         , bbtArgs_stderrSuffix   = \".err\"
                         , bbtArgs_dynArgsName    = \"BBTArgs\"
                         , bbtArgs_stdoutDiff     = defaultDiff
                         , bbtArgs_stderrDiff     = defaultDiff
                         , bbtArgs_verbose        = False }
@
-}
defaultBBTArgs :: BBTArgs
defaultBBTArgs = BBTArgs { bbtArgs_stdinSuffix    = ".in"
                         , bbtArgs_stdoutSuffix   = ".out"
                         , bbtArgs_stderrSuffix   = ".err"
                         , bbtArgs_dynArgsName    = "BBTArgs"
                         , bbtArgs_stdoutDiff     = defaultDiff
                         , bbtArgs_stderrDiff     = defaultDiff
                         , bbtArgs_verbose        = False }

{- |
A default value for the 'Diff' datatype that simple resorts to the
@diff@ commandline utility.
-}
defaultDiff :: Diff
defaultDiff expectFile real =
    case expectFile of
      Nothing -> return Nothing
      Just expect ->
          do mexe <- findExecutable "diff"
             let exe = case mexe of
                         Just p -> p
                         Nothing -> error ("diff command not in path")
             (out, err, exitCode) <- popen exe ["-u", expect, "-"]
                                        (Just real)
             case exitCode of
               ExitSuccess -> return Nothing       -- no difference
               ExitFailure 1 ->                    -- files differ
                   return $ Just (out ++ (endOfOutput "diff output"))
               ExitFailure i -> error ("diff command failed with exit " ++
                                       "code " ++ show i ++ ": " ++ err)

{- |
Collects all black box tests with the given file extension stored in a specific directory.
For example, the invocation

> blackBoxTests "bbt-dir" "dist/build/sample/sample" ".num" defaultBBTArgs

returns a list of 'Test' values, one 'Test' for each @.num@ file found in
@bbt-dir@ and its subdirectories. (The samples directory of the HTF source tree
contains the example shown here,
see <https://github.com/skogsbaer/HTF/tree/master/sample>.)

Suppose that one of the @.num@ files
is @bbt-dir\/should-pass\/x.num@. Running the corresponding 'Test' invokes
@dist\/build\/sample\/sample@ (the program under test)
with @bbt-dir\/should-pass\/x.num@ as the last commandline argument.
The other commandline arguments are taken from the flags specification given in the
file whose name is stored in the 'bbtArgs_dynArgsName' field of the 'BBTArgs' record
(see below, default is BBTArgs).

If @bbt-dir\/should-pass\/x.in@ existed, its content
would be used as stdin. The tests succeeds
if the exit code of the program is zero and
the output on stdout and stderr matches the contents of
@bbt-dir\/should-pass\/x.out@ and @bbt-dir\/should-pass\/x.err@, respectively.
If @bbt-dir\/should-pass\/x.out@ and @bbt-dir\/should-pass\/x.err@ do
not exist, then output is not checked.

The 'bbtArgs_dynArgsName' field of the 'BBTArgs' record specifies a filename
that contains some more configuration flags for the tests. The following
flags (separated by newlines) are supported:

 [@Skip@] Skips all tests in the same directory as the argument file.

 [@Fail@] Specify that the test should succeed if it exits with a non-zero exit code.

 [@Flags: flags@] Passes the given @flags@ to the program under test.

-}
blackBoxTests :: FilePath  -- ^ root directory of the test hierarchy
              -> String    -- ^ name of program under test
              -> String    -- ^ filename suffix for input file
              -> BBTArgs   -- ^ configuration
              -> IO [Test]
blackBoxTests root exe suf cfg =
    do let prune root _ = do dynCfg <- readDynCfg Map.empty
                                                  (root </>
                                                   bbtArgs_dynArgsName cfg)
                             return $ dyn_skip dynCfg
       inputFiles <- collectFiles root suf prune
       (_, tests) <- mapAccumLM genTest Map.empty inputFiles
       return tests
    where genTest :: DynamicConfigMap -> FilePath -> IO (DynamicConfigMap,
                                                         Test)
          genTest map fname =
            do stdinf <- maybeFile $ replaceSuffix fname
                                       (bbtArgs_stdinSuffix cfg)
               stdoutf <- maybeFile $  replaceSuffix fname
                                         (bbtArgs_stdoutSuffix cfg)
               stderrf <- maybeFile $ replaceSuffix fname
                                        (bbtArgs_stderrSuffix cfg)
               let configFile = dirname fname </> bbtArgs_dynArgsName cfg
               dynCfg <- readDynCfg map configFile
               let cmd = exe ++ " " ++ dropSpace (dyn_flags dynCfg) ++ " " ++
                         fname
                   shouldFail = dyn_shouldFail dynCfg
                   verbose = bbtArgs_verbose cfg || dyn_verbose dynCfg
               let bbt = BlackBoxTestCfg
                         { bbtCfg_shouldFail  = shouldFail
                         , bbtCfg_cmd         = cmd
                         , bbtCfg_stdinFile   = stdinf
                         , bbtCfg_stdoutFile  = stdoutf
                         , bbtCfg_stderrFile  = stderrf
                         , bbtCfg_verbose     = verbose
                         , bbtCfg_stdoutCmp   = bbtArgs_stdoutDiff cfg
                         , bbtCfg_stderrCmp   = bbtArgs_stderrDiff cfg
                         }
               return (Map.insert configFile dynCfg map,
                       makeBlackBoxTest fname (runBlackBoxTest bbt))

data DynamicConfig = DynamicConfig { dyn_skip        :: Bool
                                   , dyn_flags       :: String
                                   , dyn_shouldFail  :: Bool
                                   , dyn_verbose     :: Bool }

type DynamicConfigMap = Map.Map FilePath DynamicConfig

defaultDynCfg = DynamicConfig { dyn_skip       = False
                              , dyn_flags      = ""
                              , dyn_shouldFail = False
                              , dyn_verbose    = False }

readDynCfg :: DynamicConfigMap -> FilePath -> IO DynamicConfig
readDynCfg m f =
    do case Map.lookup f m of
         Just dynCfg -> return dynCfg
         Nothing ->
             do b <- doesFileExist f
                if not b then return $ defaultDynCfg
                   else do s <- readFile f
                           return $ foldl (parse f) defaultDynCfg $
                                 filter (not . isUseless) (map dropSpace
                                                               (lines s))
    where isUseless :: String -> Bool
          isUseless []      = True
          isUseless ('#':_) = True
          isUseless _       = False
          parse :: FilePath -> DynamicConfig -> String -> DynamicConfig
          parse _ cfg "Skip" = cfg { dyn_skip = True }
          parse _ cfg "Fail" = cfg { dyn_shouldFail = True }
          parse _ cfg "Verbose" = cfg { dyn_verbose = True }
          parse _ cfg ('F':'l':'a':'g':'s':':':flags) = cfg { dyn_flags = flags }
          parse f _ l = error ("invalid line in dynamic configuration file `" ++
                               f ++ "': " ++ show l)