git.iko.soy/stackage
on a549ecb help sign in
stackage/Stackage/Test.hs
88 lines 3.6 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 :: BuildSettings -> InstallInfo -> IO ()
24runTestSuites settings ii = do
25 let testdir = "runtests"
26 rm_r testdir
27 createDirectory testdir
28 allPass <- foldM (runTestSuite settings 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 :: BuildSettings
52 -> FilePath
53 -> (PackageName -> Bool) -- ^ do we have any test suites?
54 -> Bool
55 -> (PackageName, (Version, Maintainer))
56 -> IO Bool
57runTestSuite settings 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 $ ("HASKELL_PACKAGE_SANDBOX", packageDir settings)
61 : map (fixEnv $ binDir settings) env'
63 let run cmd args wdir handle = do
64 ph <- runProcess cmd args (Just wdir) menv Nothing (Just handle) (Just handle)
65 ec <- waitForProcess ph
66 unless (ec == ExitSuccess) $ throwIO TestException
68 passed <- handle (\TestException -> return False) $ do
69 getHandle WriteMode $ run "cabal" ["unpack", package] testdir
70 getHandle AppendMode $ run "cabal" (addCabalArgs settings ["configure", "--enable-tests"]) dir
71 when (hasTestSuites packageName) $ do
72 getHandle AppendMode $ run "cabal" ["build"] dir
73 getHandle AppendMode $ run "cabal" ["test"] dir
74 getHandle AppendMode $ run "cabal" ["haddock"] dir
75 return True
76 let expectedFailure = packageName `Set.member` expectedFailures settings
77 if passed
78 then do
79 removeFile logfile
80 when expectedFailure $ putStrLn $ package ++ " passed, but I didn't think it would."
81 else unless expectedFailure $ putStrLn $ "Test suite failed: " ++ package ++ "(" ++ maintainer ++ ")"
82 rm_r dir
83 return $! prevPassed && (passed || expectedFailure)
84 where
85 logfile = testdir </> package <.> "log"
86 dir = testdir </> package
87 getHandle mode = withBinaryFile logfile mode
88 package = packageVersionString (packageName, version)