{- Test runner for Telepathy components' Twisted-based tests -}
module Main where

import System.Console.GetOpt
import System.Directory ( doesFileExist
                        , doesDirectoryExist
                        , getDirectoryContents
                        )
import Data.List (intercalate, stripPrefix, isSuffixOf, sort)
import Data.Maybe (fromMaybe, listToMaybe, isNothing, fromJust)
import Control.Applicative ((<$>), (<*>))
import Control.Monad (when, filterM, forever, replicateM_)
import System.Environment (getArgs, getEnvironment)
import System.FilePath ((</>))
import System.IO (hPutStr, hPutStrLn, stderr)
import System.Process
import System.Exit

import Data.Version (showVersion)
import Paths_tt (version)

type Flag = String
data Repetitions = Forever
                 | Times Int
  deriving Show

{- Command line argument definitions and parsing -}
data Command = RunTests
             | PrintTestDirectory
             | ShowHelp
  deriving (Show, Eq, Ord)

data Options = Options { command :: Command
                       , makeFlags :: [Flag]
                       , repetitions :: Repetitions
                       }
  deriving Show
type OptionTransformer = Options -> Options

defaultOptions :: Options
defaultOptions = Options { command = RunTests
                         , makeFlags = []
                         , repetitions = Times 1
                         }

setCommand :: Command -> OptionTransformer
setCommand c opts = opts { command = max (command opts) c }

addFlag :: Flag -> OptionTransformer
addFlag f opts = opts { makeFlags = makeFlags opts ++ [f] }

setRepetitions :: Maybe String -> OptionTransformer
setRepetitions r opts = opts { repetitions = maybe Forever (Times . read) r }

dialects :: String -> OptionTransformer
dialects = addFlag . ("JINGLE_DIALECTS=" ++)

simpleOption :: Char -> String -> Flag -> OptDescr OptionTransformer
simpleOption c s f = Option [c] [s] (NoArg (addFlag f)) ("set " ++ f)

optionDefinitions :: [OptDescr OptionTransformer]
optionDefinitions =
    [ simpleOption 'v' "verbose" "CHECK_TWISTED_VERBOSE=1"
    , simpleOption 'V' "valgrind" "GABBLE_TEST_VALGRIND=1"
    , simpleOption 'm' "monitor" "WITH_SESSION_BUS_FORK_DBUS_MONITOR=1"
    , Option ['d'] ["dialects"] (ReqArg dialects "DIALECTS")
             "set JINGLE_DIALECTS to DIALECTS"
    , Option ['p'] ["print-test-directory"]
             (NoArg (setCommand PrintTestDirectory))
             "Print the path to the directory containing tests"
    , Option ['r'] ["repetitions"]
             (OptArg setRepetitions "N")
             "Run specified tests N times, or forever"
    , Option ['h'] ["help"]
             (NoArg (setCommand ShowHelp))
             "Print this usage information"
    ]

parseOptions :: [String] -> (Options, [String], [String])
parseOptions args = (options, tests , errors)
  where
    (transformers, tests, errors) = getOpt RequireOrder optionDefinitions args
    options = foldr (.) id transformers defaultOptions

usage :: String
usage = usageInfo header optionDefinitions
  where
    header = "Usage: tt [-v] [-V] [-d DIALECTS] [-r[N]] [tests...]"

{- Building and execution of a `make check-twisted` invocation -}
invokeMake :: [String] -> IO ()
invokeMake args = do
    -- Speed up Gabble's tests.
    environment <- getEnvironment
    let env' = ("GABBLE_NODELAY", "1"):environment

    let processSpec = (proc "make" args) { env = Just env' }
    (_, _, _, h) <- createProcess processSpec
    exitCode <- waitForProcess h
    case exitCode of
        ExitSuccess   -> return ()
        ExitFailure _ -> exitWith exitCode

rep :: Repetitions -> IO () -> IO ()
rep Forever   = forever
rep (Times n) = replicateM_ n

makeArgs :: [String] -> [Flag] -> FilePath -> String -> Bool -> IO [String]
makeArgs []    []    _       _       _      = return ["check", "-s", "V=0"]
makeArgs tests flags testDir testVar inTree = do
    let buildPaths = expand testDir inTree . unprefix testDir
    tests' <- concat <$> mapM buildPaths tests
    let t = [ testVar ++ "=" ++ (intercalate " " tests')
            -- This is because Mission Control is crap and has
            -- two different sets of tests.
            , "TWISTED_SEPARATE_TESTS="
            ]
    return $ [ "check-twisted", "-s", "-C", testDir, "V=0" ] ++ t ++ flags

runTests :: FilePath -> String -> Bool -> [String] -> [Flag] -> Repetitions
         -> IO ()
runTests testDir testVar inTree tests flags reps = do
    args <- makeArgs tests flags testDir testVar inTree
    rep reps $ invokeMake args

unprefix :: FilePath -> String -> String
unprefix testDir = fromMaybe <*> stripPrefix testDir

isPython :: String -> Bool
isPython s = isSuffixOf ".py" s && head s /= '.'

expand :: FilePath -> Bool -> String -> IO [String]
expand testDir inTree s
    | isPython           s = return [s]
    | otherwise = do
        let srcdir = if inTree then "." else ".."
            dir = srcdir </> testDir </> s

        isDirectory <- doesDirectoryExist dir

        if isDirectory
            then (map (s </>) . sort . filter isPython) <$> getDirectoryContents dir
            else return [s ++ ".py"]

{- Stupid project-specific crap detection -}
iHateMissionControl :: IO (Maybe String)
iHateMissionControl = do
    let dirs = [ ("mission-control", "TWISTED_BASIC_TESTS")
               , ("mission-control-plugins", "TWISTED_BASIC_TESTS")
               , ("tests/twisted", "TWISTED_TESTS")
               ]

    fmap snd . listToMaybe <$> filterM (doesDirectoryExist . fst) dirs

main :: IO ()
main = do
    args <- getArgs
    let (options, tests, errors) = parseOptions args

    inTree <- doesFileExist "configure"
    testVar <- iHateMissionControl

    case command options of
        _ | not (null errors) -> do
                mapM_ (hPutStr stderr) $ errors ++ [usage]
                exitFailure
        ShowHelp -> do
                mapM_ putStrLn
                    [ "‘tt’ version " ++ showVersion version ++
                          " runs Telepathy components’ Twisted tests."
                    , "Famed around the globe for its succinct ease-of-use."
                    , "Get your free copy today!"
                    , ""
                    , usage
                    , "Examples:"
                    , "  # Run all tests, as a shorthand for `make check`:"
                    , "    tt"
                    , "  # Run a single test:"
                    , "    tt muc/banned.py"
                    , "    tt muc/banned"
                    , "  # Run all tests in a directory:"
                    , "    tt muc/"
                    , "  # Run a bunch of tests:"
                    , "    tt muc/ text/"
                    , "  # Run Jingle tests for specific dialects:"
                    , "    tt -d jingle015,jingle031 jingle/"
                    , "    tt -d gtalk03,gtalk04 jingle/google-relay.py"
                    ]
        _ | isNothing testVar -> do
                hPutStrLn stderr "no tests here :'("
                exitFailure
        PrintTestDirectory ->
            putStrLn $ (if inTree then "." else "..") </> "tests/twisted"
        RunTests ->
            runTests "tests/twisted/" (fromJust testVar) inTree tests
                     (makeFlags options) (repetitions options)