git.iko.soy/stackage
on aa19c72 help sign in
stackage/Stackage/Test.hs
144 lines 5.7 kB history raw
1{-# LANGUAGE DeriveDataTypeable #-}
2{-# LANGUAGE RecordWildCards #-}
3module Stackage.Test
4 ( runTestSuites
5 ) where
7import qualified Control.Concurrent as C
8import Control.Exception (Exception, SomeException, handle, throwIO)
9import Control.Monad (replicateM, unless, when)
10import qualified Data.Map as Map
11import qualified Data.Set as Set
12import Data.Typeable (Typeable)
13import Stackage.Types
14import Stackage.Util
15import System.Directory (copyFile, createDirectory,
16 createDirectoryIfMissing, removeFile)
17import System.Exit (ExitCode (ExitSuccess))
18import System.FilePath ((<.>), (</>))
19import System.IO (IOMode (WriteMode, AppendMode),
20 withBinaryFile)
21import System.Process (runProcess, waitForProcess)
23runTestSuites :: BuildSettings -> BuildPlan -> IO ()
24runTestSuites settings' bp = do
25 settings <- fixBuildSettings settings'
26 let selected = Map.filterWithKey notSkipped $ bpPackages bp
27 putStrLn "Running test suites"
28 let testdir = "runtests"
29 rm_r testdir
30 createDirectory testdir
31 allPass <- parFoldM (testWorkerThreads settings) (runTestSuite settings testdir) (&&) True $ Map.toList selected
32 unless allPass $ error $ "There were failures, please see the logs in " ++ testdir
33 where
34 notSkipped p _ = p `Set.notMember` bpSkippedTests bp
36parFoldM :: Int -- ^ number of threads
37 -> (b -> IO c)
38 -> (a -> c -> a)
39 -> a
40 -> [b]
41 -> IO a
42parFoldM threadCount0 f g a0 bs0 = do
43 ma <- C.newMVar a0
44 mbs <- C.newMVar bs0
45 signal <- C.newEmptyMVar
46 tids <- replicateM threadCount0 $ C.forkIO $ worker ma mbs signal
47 wait threadCount0 signal tids
48 C.takeMVar ma
49 where
50 worker ma mbs signal =
51 handle
52 (C.putMVar signal . Just)
53 (loop >> C.putMVar signal Nothing)
54 where
55 loop = do
56 mb <- C.modifyMVar mbs $ \bs -> return $
57 case bs of
58 [] -> ([], Nothing)
59 b:bs' -> (bs', Just b)
60 case mb of
61 Nothing -> return ()
62 Just b -> do
63 c <- f b
64 C.modifyMVar_ ma $ \a -> return $! g a c
65 loop
66 wait threadCount signal tids
67 | threadCount == 0 = return ()
68 | otherwise = do
69 me <- C.takeMVar signal
70 case me of
71 Nothing -> wait (threadCount - 1) signal tids
72 Just e -> do
73 mapM_ C.killThread tids
74 throwIO (e :: SomeException)
76data TestException = TestException
77 deriving (Show, Typeable)
78instance Exception TestException
80runTestSuite :: BuildSettings
81 -> FilePath
82 -> (PackageName, SelectedPackageInfo)
83 -> IO Bool
84runTestSuite settings testdir (packageName, SelectedPackageInfo {..}) = do
85 -- Set up a new environment that includes the sandboxed bin folder in PATH.
86 env' <- getModifiedEnv settings
87 let menv addGPP
88 = Just $ (if addGPP then (("GHC_PACKAGE_PATH", packageDir settings ++ ":"):) else id)
89 $ addSandbox env'
90 -- FIXME why do these packages require the workaround?
91 bannedSandboxVar = map PackageName $ words "wai-logger warp"
92 addSandbox
93 | packageName `elem` bannedSandboxVar = id
94 | otherwise = (("HASKELL_PACKAGE_SANDBOX", packageDir settings):)
96 let runGen addGPP cmd args wdir handle' = do
97 ph <- runProcess cmd args (Just wdir) (menv addGPP) Nothing (Just handle') (Just handle')
98 ec <- waitForProcess ph
99 unless (ec == ExitSuccess) $ throwIO TestException
101 let run = runGen False
102 runGhcPackagePath = runGen True
104 passed <- handle (\TestException -> return False) $ do
105 package' <- replaceTarball (tarballDir settings) package
106 getHandle WriteMode $ run "cabal" ["unpack", package'] testdir
107 case cabalFileDir settings of
108 Nothing -> return ()
109 Just cfd -> do
110 let PackageName name = packageName
111 basename = name ++ ".cabal"
112 src = dir </> basename
113 dst = cfd </> basename
114 createDirectoryIfMissing True cfd
115 copyFile src dst
116 getHandle AppendMode $ run "cabal" (addCabalArgs settings BSTest ["configure", "--enable-tests"]) dir
117 when spiHasTests $ do
118 getHandle AppendMode $ run "cabal" ["build"] dir
119 getHandle AppendMode $ runGhcPackagePath "cabal" ["test"] dir
120 when (buildDocs settings) $
121 getHandle AppendMode $ run "cabal" ["haddock"] dir
122 return True
123 let expectedFailure = packageName `Set.member` expectedFailuresBuild settings
124 if passed
125 then do
126 removeFile logfile
127 when expectedFailure $ putStrLn $ package ++ " passed, but I didn't think it would."
128 else unless expectedFailure $ putStrLn $ concat
129 [ "Test suite failed: "
130 , package
131 , "("
132 , unMaintainer spiMaintainer
133 , case spiGithubUser of
134 Nothing -> ""
135 Just x -> " @" ++ x
136 , ")"
137 ]
138 rm_r dir
139 return $! passed || expectedFailure
140 where
141 logfile = testdir </> package <.> "log"
142 dir = testdir </> package
143 getHandle mode = withBinaryFile logfile mode
144 package = packageVersionString (packageName, spiVersion)