git.iko.soy/stackage
on 4de7dfd help sign in
stackage/Stackage/Test.hs
93 lines 3.8 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 addGPP
61 = Just $ (if addGPP then (("GHC_PACKAGE_PATH", packageDir settings ++ ":"):) else id)
62 $ ("HASKELL_PACKAGE_SANDBOX", packageDir settings)
63 : map (fixEnv $ binDir settings) env'
65 let runGen addGPP cmd args wdir handle = do
66 ph <- runProcess cmd args (Just wdir) (menv addGPP) Nothing (Just handle) (Just handle)
67 ec <- waitForProcess ph
68 unless (ec == ExitSuccess) $ throwIO TestException
70 let run = runGen False
71 runGhcPackagePath = runGen True
73 passed <- handle (\TestException -> return False) $ do
74 getHandle WriteMode $ run "cabal" ["unpack", package] testdir
75 getHandle AppendMode $ run "cabal" (addCabalArgs settings ["configure", "--enable-tests"]) dir
76 when (hasTestSuites packageName) $ do
77 getHandle AppendMode $ run "cabal" ["build"] dir
78 getHandle AppendMode $ runGhcPackagePath "cabal" ["test"] dir
79 getHandle AppendMode $ run "cabal" ["haddock"] dir
80 return True
81 let expectedFailure = packageName `Set.member` expectedFailures settings
82 if passed
83 then do
84 removeFile logfile
85 when expectedFailure $ putStrLn $ package ++ " passed, but I didn't think it would."
86 else unless expectedFailure $ putStrLn $ "Test suite failed: " ++ package ++ "(" ++ maintainer ++ ")"
87 rm_r dir
88 return $! prevPassed && (passed || expectedFailure)
89 where
90 logfile = testdir </> package <.> "log"
91 dir = testdir </> package
92 getHandle mode = withBinaryFile logfile mode
93 package = packageVersionString (packageName, version)