{-# LANGUAGE CPP, MultiParamTypeClasses, DeriveDataTypeable, ViewPatterns, OverloadedStrings, ExtendedDefaultRules #-}
{-# OPTIONS_GHC -fno-warn-missing-fields #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}
module Main ( main, run, defaultConfig, Config(..) ) where

import Darcs.Prelude

import qualified Darcs.Test.Misc
import qualified Darcs.Test.Patch
import qualified Darcs.Test.Patch.RepoPatchV1
import qualified Darcs.Test.Email
import qualified Darcs.Test.Repository.Inventory
import qualified Darcs.Test.HashedStorage
import Darcs.Util.Exception ( die )

import Control.Monad ( filterM )
import Control.Exception ( SomeException )
import Data.Text ( Text, pack, unpack )
import qualified Data.Text as T
import Data.List ( isPrefixOf, isSuffixOf, sort )
import GHC.IO.Encoding ( textEncodingName )
import System.Console.CmdArgs hiding ( args )
import System.Console.CmdArgs.Explicit ( process )
import System.Directory ( doesFileExist )
import System.Environment.FindBin ( getProgPath )
import System.FilePath( takeDirectory, takeBaseName, isAbsolute, makeRelative )
import qualified System.FilePath as Native ( searchPathSeparator, splitSearchPath )
import qualified System.FilePath.Posix as Posix ( searchPathSeparator )
import System.IO( hSetBinaryMode, hSetBuffering, BufferMode( NoBuffering ), stdin, stdout, stderr, localeEncoding )
import Test.Framework.Providers.API
  ( TestResultlike(..), Testlike(..), Test, runImprovingIO, yieldImprovement, Test(..), liftIO )
import Test.Framework ( defaultMainWithArgs )
import Shelly hiding ( liftIO, run, FilePath, path )
import qualified Shelly

doUnit :: IO [Test]
doUnit = return unitTests

-- | TODO make runnable in parallel
doHashed :: IO [Test]
doHashed = return Darcs.Test.HashedStorage.tests

-- | This is the big list of tests that will be run using testrunner.
unitTests :: [Test]
unitTests =
  [ Darcs.Test.Email.testSuite
  , Darcs.Test.Misc.testSuite
  , Darcs.Test.Repository.Inventory.testSuite
  ] ++ (Darcs.Test.Patch.RepoPatchV1.testSuite : Darcs.Test.Patch.testSuite)

-- ----------------------------------------------------------------------
-- shell tests
-- ----------------------------------------------------------------------

data Format = Darcs1 | Darcs2 | Darcs3 deriving (Show, Eq, Typeable, Data)
data DiffAlgorithm = MyersDiff | PatienceDiff deriving (Show, Eq, Typeable, Data)
data Running = Running deriving Show
data Result = Success | Skipped | Failed String

instance Show Result where
  show Success = "Success"
  show Skipped = "Skipped"
  show (Failed f) = unlines (map ("| " ++) $ lines f)

instance TestResultlike Running Result where
  testSucceeded Success = True
  testSucceeded Skipped = True
  testSucceeded _ = False

data ShellTest = ShellTest { format :: Format
                           , testfile :: FilePath
                           , testdir  :: Maybe FilePath -- ^ only if you want to set it explicitly
                           , _darcspath :: FilePath
                           , diffalgorithm :: DiffAlgorithm
                           }
                 deriving Typeable

-- |Environment variable values may need translating depending
-- on whether we are setting them directly or writing out a shell script
-- to set them, and depending on the kind of value and the platform.
-- This type captures the different kinds of values.
data EnvItem
  = EnvString String  -- ^ A normal string that won't need conversion
  | EnvFilePath Shelly.FilePath -- ^ A path on disk that may need conversion for the platform
  | EnvSearchPath [Shelly.FilePath] -- ^ A list of paths on disk, for the PATH variable

runtest' :: ShellTest -> Text -> Sh Result
runtest' (ShellTest fmt _ _ dp da) srcdir =
  do wd <- pwd
     p <- unpack <$> get_env_text "PATH"
     let pathToUse = map (fromText . pack) $ takeDirectory dp:Native.splitSearchPath p
     let env =
          [ ("HOME", EnvFilePath wd)
          -- in case someone has XDG_CACHE_HOME set:
          , ("XDG_CACHE_HOME", EnvFilePath (wd </> ".cache"))
          , ("TESTDATA", EnvFilePath (srcdir </> "tests" </> "data"))
          , ("TESTBIN", EnvFilePath (srcdir </> "tests" </> "bin"))
          , ("DARCS_TESTING_PREFS_DIR", EnvFilePath $ wd </> ".darcs")
          , ("EMAIL", EnvString "tester")
          , ("GIT_AUTHOR_NAME", EnvString "tester")
          , ("GIT_AUTHOR_EMAIL", EnvString "tester")
          , ("GIT_COMMITTER_NAME", EnvString "tester")
          , ("GIT_COMMITTER_EMAIL", EnvString "tester")
          , ("DARCS_DONT_COLOR", EnvString "1")
          , ("DARCS_DONT_ESCAPE_ANYTHING", EnvString "1")
          , ("PATH", EnvSearchPath pathToUse)
          -- the DARCS variable is passed to the tests purely so they can
          -- double-check that the darcs on the path is the expected one,
          -- so is passed as a string directly without any translation
          , ("DARCS", EnvString dp)
          , ("GHC_VERSION", EnvString $ show (__GLASGOW_HASKELL__ :: Int))
          ]
     -- we write the variables to a shell script and source them from there in ./lib,
     -- so that it's easy to reproduce a test failure after running the harness with -d.
     writefile "env" $ T.unlines $
        map (\(k,v) -> T.concat ["export ", k, "=", envItemForScript v]) env
     -- just in case the test script doesn't source ./lib:
     mapM_ (\(k,v) -> setenv k (envItemForEnv v)) env

     mkdir ".darcs"
     writefile ".darcs/defaults" defaults
     _ <- onCommandHandles (initOutputHandles (\h -> hSetBinaryMode h True)) $
          Shelly.run "bash" [ "test" ]
     return Success
   `catch_sh` \(_::SomeException)
                 -> do code <- lastExitCode
                       case code of
                        200 -> return Skipped
                        _   -> Failed <$> unpack <$> lastStderr
  where defaults = pack $ unlines
          [ "ALL " ++ fmtstr
          , "send no-edit-description"
          , "ALL ignore-times"
          , "ALL " ++ daf
          ]
        fmtstr = case fmt of
                  Darcs3 -> "darcs-3"
                  Darcs2 -> "darcs-2"
                  Darcs1 -> "darcs-1"
        daf = case da of
                PatienceDiff -> "patience"
                MyersDiff -> "myers"

        -- convert an 'EnvItem' to a string you can put in the environment directly
        envItemForEnv :: EnvItem -> Text
        envItemForEnv (EnvString v) = pack v
        envItemForEnv (EnvFilePath v) = toTextIgnore v
        envItemForEnv (EnvSearchPath vs) =
          T.intercalate (T.singleton Native.searchPathSeparator) $ map toTextIgnore vs

        -- convert an 'EnvItem' to a string that will evaluate to the right value
        -- when embedded in a bash script
        envItemForScript :: EnvItem -> Text
        envItemForScript (EnvString v) = pack (show v)
        envItemForScript (EnvFilePath v) = filePathForScript v
        envItemForScript (EnvSearchPath vs) =
           -- note the use of the Posix search path separator (':') regardless of platform
           T.intercalate (T.singleton Posix.searchPathSeparator) $ map filePathForScript vs

        -- add quotes around a 'Shelly.FilePath'
        quotedFilePath :: Shelly.FilePath -> Text
        quotedFilePath = pack . show . toTextIgnore

        -- convert a 'Shelly.FilePath' into a string that will evaluate to the right
        -- value when put in a bash script
        filePathForScript :: Shelly.FilePath -> Text
#ifdef WIN32
        -- we have a native Windows path, but we are going to put it in an bash script
        -- run in an environment like msys2 which works with an illusion of a Unix style
        -- filesystem. Calling cygpath at runtime does the necessary translation.
        filePathForScript v = T.concat ["$(cygpath ", quotedFilePath v, ")"]
#else
        filePathForScript v = quotedFilePath v
#endif

takeTestName :: FilePath -> Shelly.FilePath
takeTestName n =
  let n' = makeRelative "tests" n in
    takeBaseName (takeDirectory n') </> takeBaseName n'

runtest :: ShellTest -> Sh Result
runtest t =
 withTmp $ \dir -> do
  cp "tests/lib" dir
  cp "tests/network/sshlib" dir
  cp "tests/network/httplib" dir
  cp (fromText $ pack $ testfile t) (dir </> "test")
  srcdir <- pwd
  silently $ sub $ cd dir >> runtest' t (toTextIgnore srcdir)
 where
  withTmp =
   case testdir t of
     Just dir -> \job -> do
       let d = (dir </> show (format t) </> show (diffalgorithm t) </> takeTestName (testfile t))
       mkdir_p d
       job d
     Nothing  -> withTmpDir

instance Testlike Running Result ShellTest where
  testTypeName _ = "Shell"
  runTest _ test = runImprovingIO $ do yieldImprovement Running
                                       liftIO (shelly $ runtest test)

shellTest :: FilePath -> Format -> Maybe FilePath -> String -> DiffAlgorithm -> Test
shellTest dp fmt tdir file da =
  Test (toString (takeTestName file) ++ " (" ++ show fmt ++ ")" ++ " (" ++ show da ++ ")") $
  ShellTest fmt file tdir dp da

toString :: Shelly.FilePath -> String
toString = unpack . toTextIgnore

findShell :: FilePath -> Text -> Maybe FilePath -> Bool -> [DiffAlgorithm] -> [Format] -> Sh [Test]
findShell dp sdir tdir isFailing diffAlgorithms repoFormats =
  do files <- ls (fromText sdir)
     let test_files = sort $ filter relevant $ filter (hasExt "sh") files
     return [ shellTest dp fmt tdir file da
            | file <- map toString test_files
            , fmt <- repoFormats
            , da <- diffAlgorithms ]
  where relevant = (if isFailing then id else not) . ("failing-" `isPrefixOf`) . takeBaseName . toString

-- ----------------------------------------------------------------------
-- harness
-- ----------------------------------------------------------------------

data Config = Config { hashed :: Bool
                     , failing :: Bool
                     , shell :: Bool
                     , network :: Bool
                     , unit :: Bool
                     , myers :: Bool
                     , patience :: Bool
                     , darcs1 :: Bool
                     , darcs2 :: Bool
                     , darcs3 :: Bool
                     , full :: Bool
                     , darcs :: String
                     , tests :: [String]
                     , testDir :: Maybe FilePath
                     , plain :: Bool
                     , hideSuccesses :: Bool
                     , threads :: Int
                     , qcCount :: Int
                     , replay :: Maybe Integer
                     }
            deriving (Data, Typeable, Eq, Show)


defaultConfigAnn :: Annotate Ann
defaultConfigAnn
 = record Config{}
     [ hashed        := False    += help "Run hashed-storage tests [no]"
     , failing       := False    += help "Run the failing (shell) tests [no]"
     , shell         := True     += help "Run the passing, non-network shell tests [yes]"
     , network       := True     += help "Run the network shell tests [yes]"
     , unit          := True     += help "Run the unit tests [yes]"
     , myers         := False    += help "Use myers diff [no]"
     , patience      := True     += help "Use patience diff [yes]" += name "p"
     , darcs1        := True     += help "Use darcs-1 repo format [yes]" += name "1"
     , darcs2        := True     += help "Use darcs-2 repo format [yes]" += name "2"
     , darcs3        := True     += help "Use darcs-3 repo format [yes]" += name "3"
     , full          := False    += help "Run all tests in all variants"
     , darcs         := ""       += help "Darcs binary path" += typ "PATH"
     , tests         := []       += help "Pattern to limit the tests to run" += typ "PATTERN" += name "t"
     , testDir       := Nothing  += help "Directory to run tests in" += typ "PATH" += name "d"
     , plain         := False    += help "Use plain-text output [no]"
     , hideSuccesses := False    += help "Hide successes [no]"
     , threads       := 1        += help "Number of threads [1]" += name "j"
     , qcCount       := 100      += help "Number of QuickCheck iterations per test [100]" += name "q"
     , replay        := Nothing  += help "Replay QC tests with given seed" += typ "SEED"
     ]
   += summary "Darcs test harness"
   += program "darcs-test"

defaultConfig :: Config
Right defaultConfig = fmap cmdArgsValue $ process (cmdArgsMode_ defaultConfigAnn) []

run :: Config -> IO ()
run conf = do
    let args = [ "-j", show $ threads conf ]
             ++ concat [ ["-t", x ] | x <- tests conf ]
             ++ [ "--plain" | True <- [plain conf] ]
             ++ [ "--hide-successes" | True <- [hideSuccesses conf] ]
                -- this multiplier is calibrated against the observed behaviour of the test harness -
                -- increase it if we see lots of "arguments exhausted" errors or similar
             ++ [ "--maximum-unsuitable-generated-tests", show (7 * qcCount conf) ]
             ++ [ "--maximum-generated-tests", show (qcCount conf) ]
             ++ [ "--test-seed="++show seed | Just seed <- [replay conf] ]
    case testDir conf of
       Nothing -> return ()
       Just d  -> do e <- shelly (test_e (fromText $ pack d))
                     when e $ die ("Directory " ++ d ++ " already exists. Cowardly exiting")
    darcsBin <-
        case darcs conf of
            "" -> do
                path <- getProgPath
                let candidates =
                      -- if darcs-test lives in foo/something, look for foo/darcs[.exe]
                      -- for example if we've done cabal install -ftest, there'll be a darcs-test and darcs in the cabal
                      -- installation folder
                      [path </> ("darcs" ++ exeSuffix)] ++
                      -- if darcs-test lives in foo/darcs-test/something, look for foo/darcs/darcs[.exe]
                      -- for example after cabal build we can run dist/build/darcs-test/darcs-test and it'll find
                      -- the darcs in dist/build/darcs/darcs
                      [takeDirectory path </> "darcs" </> ("darcs" ++ exeSuffix) | takeBaseName path == "darcs-test" ] ++
                      -- nowadays cabal v2-build produces more complicated structures:
                      -- t/darcs-test/build/darcs-test/darcs-test and x/darcs/build/darcs/darcs
                      [takeDirectory path </> ".." </> ".." </> ".." </> "x"
                                          </> "darcs" </> "build" </> "darcs" </> ("darcs" ++ exeSuffix)
                            | takeBaseName path == "darcs-test" ] ++
                      [takeDirectory path </> ".." </> ".." </> ".." </> ".." </> "x"
                                          </> "darcs" </> "noopt" </> "build" </> "darcs" </> ("darcs" ++ exeSuffix)
                            | takeBaseName path == "darcs-test" ]
                availableCandidates <- filterM doesFileExist (map toString candidates)
                case availableCandidates of
                     (darcsBin:_) -> do
                         putStrLn $ "Using darcs executable in " ++ darcsBin
                         return darcsBin
                     [] -> die ("No darcs specified or found nearby. Tried:\n" ++ unlines (map toString candidates))
            v -> return v
    when (shell conf || network conf || failing conf) $ do
      unless (isAbsolute $ darcsBin) $
        die ("Argument to --darcs should be an absolute path")
      unless (exeSuffix `isSuffixOf` darcsBin) $
        putStrLn $ "Warning: --darcs flag does not end with " ++ exeSuffix ++ " - some tests may fail (case does matter)"

    putStrLn $ "Locale encoding is " ++ textEncodingName localeEncoding

    let repoFormat    = (if darcs1 conf then (Darcs1:) else id)
                      . (if darcs2 conf then (Darcs2:) else id)
                      . (if darcs3 conf then (Darcs3:) else id)
                      $ []
    let diffAlgorithm = (if myers conf then (MyersDiff:) else id)
                      . (if patience conf then (PatienceDiff:) else id)
                      $ []

    stests <- shelly $
      if shell conf
        then findShell darcsBin "tests" (testDir conf) (failing conf) diffAlgorithm repoFormat
        else return []
    utests <- if unit conf then doUnit else return []
    ntests <- shelly $ if network conf then findShell darcsBin "tests/network" (testDir conf) (failing conf) diffAlgorithm repoFormat else return []
    hstests <- if hashed conf then doHashed else return []
    defaultMainWithArgs (stests ++ utests ++ ntests ++ hstests) args
       where
          exeSuffix :: String
#ifdef WIN32
          exeSuffix = ".exe"
#else
          exeSuffix = ""
#endif

main :: IO ()
main = do hSetBinaryMode stdout True
          hSetBuffering stdout NoBuffering
          hSetBinaryMode stderr True
          hSetBinaryMode stdin True
          clp  <- cmdArgs_ defaultConfigAnn
          run $
            if full clp then clp
              { hashed   = True
              , shell    = True
              , network  = True
              , unit     = True
              , myers    = True
              , patience = True
              , darcs1   = True
              , darcs2   = True
              }
            else clp
