darcs-2.4: Distribution/ShellHarness.hs
{-# 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)