{-# OPTIONS_GHC -cpp #-}
module Distribution.ShellHarness ( runTests ) where

import Prelude hiding( catch )
import System.Directory ( getCurrentDirectory,
                          getPermissions, setPermissions,
                          readable, writable, executable, searchable,
                          getDirectoryContents,
                          findExecutable, createDirectoryIfMissing,
                          renameFile, removeFile )
import System.Environment ( getEnv, getEnvironment )
import System.Exit ( ExitCode (..) )
import System.FilePath
import System.IO
import System( system )
import System.Process ( ProcessHandle,
                        runInteractiveProcess, waitForProcess,
                        getProcessExitCode )
import Data.Maybe
import Data.List ( isInfixOf, isPrefixOf, (\\), nubBy, isSuffixOf )
import Control.Concurrent
import qualified Control.Exception as Exception
import Control.Monad

-- Handle exceptions migration. We could use extensible-exceptions
-- but Cabal can't handle package dependencies of Setup.lhs
-- automatically so it'd be disruptive for users.
-- Once we drop older GHCs we can clean up the use sites properly
-- and perhaps think about being more restrictive in which exceptions
-- are caught at each site.
#if __GLASGOW_HASKELL__ >= 610
catchAny f h = Exception.catch f (\e -> h (e :: Exception.SomeException))
#else
catchAny = Exception.catch
#endif

runTests :: Maybe FilePath -> String -> [String] -> IO Bool
runTests darcs_path cwd tests = do
     fails <- run darcs_path tests
     if  "bugs" `isInfixOf` cwd
         then if (length tests /= length fails)
                 then do putStrLn $ "Some bug tests passed:"
                         mapM_ putStrLn (tests \\ fails)
                         return False
                 else do putStrLn "All bug tests OK"
                         return True
         else if fails /= []
                 then do putStrLn "Some tests failed:"
                         mapM_ putStrLn fails
                         return False
                 else do putStrLn "All tests OK"
                         return True

run :: Maybe FilePath -> [String] -> IO [String]
run set_darcs_path tests = do
    cwd <-  getCurrentDirectory
    path <- getEnv "PATH"
    env <- getEnvironment
    bash <- find_bash
    darcs_path <- case set_darcs_path of
                    Nothing -> case lookup "DARCS" env of
                                 Nothing -> return (cwd ++ "/..")
                                 Just d  -> return $ takeDirectory d
                    Just x -> return x
    let myenv = [("HOME",cwd)
                ,("TESTS_WD",cwd)
                ,("DARCS_TESTING_PREFS_DIR",cwd </> ".darcs")
                ,("EMAIL","tester")
                ,("DARCSEMAIL","tester")
                ,("PATH",(darcs_path++":"++path))
                ,("DARCS_DONT_COLOR","1")
                ,("DARCS_DONT_ESCAPE_ANYTHING","1")]
        shell = takeWhile (/= '\n') bash
    putStrLn $ "Using bash shell in '"++shell++"'"
    catchAny (appendFile (".darcs/defaults") "\nALL ignore-times\nsend no-edit-description\n")
          (\e -> fail $ "Unable to set preferences: " ++ show e)
    run_helper shell tests []  (set_env myenv env)

data Status = Success | Failed | Skipped

run_helper :: String -> [String] -> [String] ->
                  [(String,String)] -> IO [String]
run_helper _ [] fails _ = return fails
run_helper shell (test:ts) fails env = do
    putStr $ "Running " ++ test ++ " ..." ++ (replicate (36 - (length test)) ' ')
    (output,result) <- backtick shell test env
    cleanup
    case result of
      Skipped -> do putStrLn " skipped."
                    run_helper shell ts fails env
      Success -> do putStrLn " passed."
                    run_helper shell ts fails env
      Failed -> do putStrLn " failed."
                   putStrLn $ "Probable reason :" ++ output
                   run_helper shell ts (fails++[test]) env
  where cleanup :: IO ()
        cleanup =
          do dirfiles <- getDirectoryContents (fromJust $ lookup "TESTS_WD" env)
             let tempfiles = (filter ("temp" `isPrefixOf`) dirfiles) ++
                             (filter ("tmp" `isPrefixOf`) dirfiles)
             when (isJust $ lookup "HPCTIXDIR" env) $ do
                 let tixdir = fromJust $ lookup "HPCTIXDIR" env
                 tixlist <- getDirectoryContents tixdir
                 oldsum <- if ("sum.tix" `elem` tixlist)
                              then do renameFile (tixdir </> "sum.tix")
                                                 (tixdir </> "oldsum.tix")
                                      return [tixdir </> "oldsum.tix"]
                              else return []
                 let tixfiles = oldsum ++ [ tixdir </> f | f <- tixlist
                                                         , "darcs-" `isPrefixOf` f
                                                         , ".tix" `isSuffixOf` f ]
                 system $ "hpc sum --union --output=" ++ tixdir </> "sum.tix" ++ " " ++ unwords tixfiles
                 forM tixfiles $ \f -> removeFile f
                 return ()
             mapM_ (\x-> do
                  p <- getPermissions x
                  setPermissions x (p
                                   {readable = True
                                   ,writable = True
                                   ,executable = False
                                   ,searchable = True}
                                   )
                 ) tempfiles

backtick :: String -> String -> [(String, String)]-> IO (String,Status)
backtick cmd args env = do
   (exitcode,res) <- backtick_helper cmd args env
   case exitcode of
        ExitSuccess -> return (res, Success)
        ExitFailure 200 -> return (res, Skipped)
        ExitFailure _ -> return (res, Failed)

backtick_helper :: String -> String -> [(String,String)] ->
                                      IO (ExitCode, String)
backtick_helper cmd args env = process_wrapper (runInteractiveProcess
                                                   cmd [args] Nothing
                                                   (Just env)
                                               ) ""

find_bash :: IO FilePath
find_bash =
   do sh <- findExecutable "bash"
      case sh of
          Just p -> return p
          Nothing -> error "Could not find bash in PATH"

-- | Run a process with a list of arguments and return anything from
-- /stderr/ or /stdout/
process_wrapper :: IO (Handle, Handle, Handle, ProcessHandle) ->
                   String -> IO (ExitCode, String)
process_wrapper f _ = do
       (_,o,e,pid) <- f
       hSetBuffering o LineBuffering
       hSetBuffering e LineBuffering
       ch <- newChan
       -- WARNING: beware of hokeyness ahead!
       let readWrite i = do x <- hGetLine i
                            writeChan ch $ Just x
                            readWrite i
                         `catchAny` \_ -> writeChan ch Nothing
           readEO = do x <- readChan ch
                       case x of
                         Just l -> do y <- readEO
                                      return $ l:y
                         Nothing -> readEO'
           readEO' = do x <- readChan ch
                        case x of
                          Just l -> do y <- readEO'
                                       return $ l:y
                          Nothing -> return []
       forkIO $ readWrite o
       forkIO $ readWrite e
       outerr <- readEO
       ec <- waitForProcessNonBlocking pid
       threadDelay 1000
       case ec of
         ExitFailure 127 -> fail $ "timeout running command\n\n"
                                   ++unlines outerr
         _ -> return (ec, unlines outerr)

--
-- waitForProcess uses a very hokey heuristic to try to avoid burning too
-- much CPU time in a busy wait, while also not adding too much extra
-- latency.

waitForProcessNonBlocking :: ProcessHandle -> IO ExitCode
waitForProcessNonBlocking = if rtsSupportsBoundThreads
                            then waitForProcess
                            else wfp 0
    where wfp n pid = do mec <- getProcessExitCode pid
                         case mec of
                           Just ec -> return ec
                           Nothing -> do threadDelay n
                                         wfp (min 100000 (n+1+n`div`4)) pid



set_env :: [(String,String)] -> [(String,String)] -> [(String, String)]
set_env es env = nubBy (\(x,_) (y,_) -> x == y) (es ++ env)
