darcs-2.1.98.2: Distribution/ShellHarness.hs

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

import Prelude hiding( catch )
import System.Directory ( getCurrentDirectory, setPermissions,
                          Permissions(..), getDirectoryContents,
                          findExecutable, createDirectoryIfMissing )
import System.Environment ( getEnv, getEnvironment )
import System.Exit ( ExitCode (..), exitWith )
import System.FilePath
import System.IO
import System.Process ( ProcessHandle, runInteractiveCommand,
                        runInteractiveProcess, waitForProcess,
                        getProcessExitCode )
import Data.Maybe
import Data.List ( isInfixOf, isPrefixOf, (\\), nubBy )
import Control.Concurrent
#if __GLASGOW_HASKELL__ >= 610
import Control.OldException
#else
import Control.Exception
#endif
import Control.Monad

runTests :: String -> [String] -> IO Bool
runTests cwd tests = do
     fails <- run 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 :: [String] -> IO [String]
run tests= do
    cwd <-  getCurrentDirectory
    path <- getEnv "PATH"
    env <- getEnvironment
    darcs_path <- get_darcs_path
    let myenv = [("HOME",cwd)
                ,("DARCS_TESTING_HOME",cwd)
                ,("PWD",cwd)
                ,("EMAIL","tester")
                ,("DARCSEMAIL","tester")
                ,("PATH",(darcs_path++":"++path))
                ,("DARCS_DONT_COLOR","1")
                ,("DARCS_DONT_ESCAPE_ANYTHING","1")]
    bash <- find_bash
    let shell = takeWhile (/= '\n') bash
    putStrLn $ "Using bash shell in '"++shell++"'"
    set_prefs
    run_helper shell tests []  (set_env myenv env)
  where get_darcs_path = do
           env <- getEnvironment
           cwd <-  getCurrentDirectory
           case lookup "DARCS" env of
                Nothing -> return (cwd ++ "/..")
                Just d  -> return $ takeDirectory d
        set_prefs = do
            finally (catch (appendFile ".darcs/defaults" "\nALL --ignore-times\n")
                           (\e -> fail $ "Unable to set preferences: "
                                         ++ show e))
                    (createDirectoryIfMissing  False ".darcs")
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,success) <- backtick shell test env
    if success then do putStrLn " passed."
                       cleanup_dirs
                       run_helper shell ts fails env
               else do putStrLn " failed."
                       putStrLn $ "Probable reason :" ++ output
                       cleanup_dirs
                       run_helper shell ts (fails++[test]) env
  where cleanup_dirs :: IO ()
        cleanup_dirs =
          do dirfiles <- getDirectoryContents (fromJust $ lookup "PWD" env)
             let tempfiles = (filter ("temp" `isPrefixOf`) dirfiles) ++
                             (filter ("tmp" `isPrefixOf`) dirfiles)
             mapM_ (\x-> 
                  setPermissions x (Permissions 
                                   {readable = True
                                   ,writable = True
                                   ,executable = False
                                   ,searchable = True}
                                   )
                 ) tempfiles

backtick :: String -> String -> [(String, String)]-> IO (String,Bool)
backtick cmd args env = do
   (exitcode,res) <- backtick_helper cmd args env
   case exitcode of
        ExitSuccess -> return (res, True)
        ExitFailure code -> return (res, False)

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

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)