git.iko.soy/stackage
on 684bf6d help sign in
stackage/Stackage/Test.hs
147 lines 5.9 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"
120 [ "test"
121 , "--show-details=streaming" -- FIXME temporary workaround for https://github.com/haskell/cabal/issues/1810
122 ] dir
123 when (buildDocs settings) $
124 getHandle AppendMode $ run "cabal" ["haddock"] dir
125 return True
126 let expectedFailure = packageName `Set.member` expectedFailuresBuild settings
127 if passed
128 then do
129 removeFile logfile
130 when expectedFailure $ putStrLn $ package ++ " passed, but I didn't think it would."
131 else unless expectedFailure $ putStrLn $ concat
132 [ "Test suite failed: "
133 , package
134 , "("
135 , unMaintainer spiMaintainer
136 , case spiGithubUser of
137 Nothing -> ""
138 Just x -> " @" ++ x
139 , ")"
140 ]
141 rm_r dir
142 return $! passed || expectedFailure
143 where
144 logfile = testdir </> package <.> "log"
145 dir = testdir </> package
146 getHandle mode = withBinaryFile logfile mode
147 package = packageVersionString (packageName, spiVersion)