{-# OPTIONS_GHC -cpp #-} module Distribution.ShellHarness ( runTests ) where import Prelude hiding( catch ) import System.Directory ( getCurrentDirectory, setPermissions, Permissions(..), 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 #if __GLASGOW_HASKELL__ >= 610 import Control.OldException #else import Control.Exception #endif import Control.Monad 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++"'" catch (appendFile (".darcs/defaults") "\nALL --ignore-times\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-> setPermissions x (Permissions {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 `catch` \_ -> 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)