git.iko.soy/stackage
on ecc9ceb help sign in
stackage/Stackage/Test.hs
87 lines 3.5 kB history raw
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE DeriveDataTypeable #-}
3module Stackage.Test
4 ( runTestSuites
5 ) where
7import Control.Monad (foldM, unless, when)
8import qualified Data.Map as Map
9import qualified Data.Set as Set
10import Stackage.Config
11import Stackage.Types
12import Stackage.Util
13import System.Directory (createDirectory, removeFile, canonicalizePath)
14import System.Environment (getEnvironment)
15import System.Exit (ExitCode (ExitSuccess))
16import System.FilePath ((<.>), (</>))
17import System.IO (IOMode (WriteMode, AppendMode),
18 withBinaryFile)
19import System.Process (runProcess, waitForProcess)
20import Control.Exception (handle, Exception, throwIO)
21import Data.Typeable (Typeable)
23runTestSuites :: FilePath -> InstallInfo -> IO ()
24runTestSuites root ii = do
25 let testdir = "runtests"
26 rm_r testdir
27 createDirectory testdir
28 allPass <- foldM (runTestSuite root testdir hasTestSuites) True $ Map.toList $ iiPackages ii
29 unless allPass $ error $ "There were failures, please see the logs in " ++ testdir
30 where
31 PackageDB pdb = iiPackageDB ii
33 hasTestSuites name = maybe defaultHasTestSuites piHasTests $ Map.lookup name pdb
35-- | Separate for the PATH environment variable
36pathSep :: Char
37#ifdef mingw32_HOST_OS
38pathSep = ';'
39#else
40pathSep = ':'
41#endif
43fixEnv :: FilePath -> (String, String) -> (String, String)
44fixEnv bin (p@"PATH", x) = (p, bin ++ pathSep : x)
45fixEnv _ x = x
47data TestException = TestException
48 deriving (Show, Typeable)
49instance Exception TestException
51runTestSuite :: FilePath
52 -> FilePath
53 -> (PackageName -> Bool) -- ^ do we have any test suites?
54 -> Bool
55 -> (PackageName, (Version, Maintainer))
56 -> IO Bool
57runTestSuite root testdir hasTestSuites prevPassed (packageName, (version, Maintainer maintainer)) = do
58 -- Set up a new environment that includes the sandboxed bin folder in PATH.
59 env' <- getEnvironment
60 let menv = Just $ map (fixEnv $ binDir root) env'
62 let run cmd args wdir handle = do
63 ph <- runProcess cmd args (Just wdir) menv Nothing (Just handle) (Just handle)
64 ec <- waitForProcess ph
65 unless (ec == ExitSuccess) $ throwIO TestException
67 passed <- handle (\TestException -> return False) $ do
68 getHandle WriteMode $ run "cabal" ["unpack", package] testdir
69 getHandle AppendMode $ run "cabal" (addCabalArgs root ["configure", "--enable-tests"]) dir
70 when (hasTestSuites packageName) $ do
71 getHandle AppendMode $ run "cabal" ["build"] dir
72 getHandle AppendMode $ run "cabal" ["test"] dir
73 getHandle AppendMode $ run "cabal" ["haddock"] dir
74 return True
75 let expectedFailure = packageName `Set.member` expectedFailures
76 if passed
77 then do
78 removeFile logfile
79 when expectedFailure $ putStrLn $ package ++ " passed, but I didn't think it would."
80 else unless expectedFailure $ putStrLn $ "Test suite failed: " ++ package ++ "(" ++ maintainer ++ ")"
81 rm_r dir
82 return $! prevPassed && (passed || expectedFailure)
83 where
84 logfile = testdir </> package <.> "log"
85 dir = testdir </> package
86 getHandle mode = withBinaryFile logfile mode
87 package = packageVersionString (packageName, version)