git.iko.soy/stackage
on 0340512 help sign in
stackage/Stackage/Test.hs
165 lines 6.6 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.Version (parseVersion, Version (Version))
13import Data.Typeable (Typeable)
14import Stackage.Types
15import Stackage.Util
16import System.Directory (copyFile, createDirectory,
17 createDirectoryIfMissing, removeFile)
18import System.Exit (ExitCode (ExitSuccess))
19import System.FilePath ((<.>), (</>))
20import System.IO (IOMode (WriteMode, AppendMode),
21 withBinaryFile)
22import System.Process (readProcess, runProcess, waitForProcess)
23import Text.ParserCombinators.ReadP (readP_to_S)
25runTestSuites :: BuildSettings -> BuildPlan -> IO ()
26runTestSuites settings' bp = do
27 settings <- fixBuildSettings settings'
28 let selected = Map.filterWithKey notSkipped $ bpPackages bp
29 putStrLn "Running test suites"
30 let testdir = "runtests"
31 rm_r testdir
32 createDirectory testdir
33 cabalVersion <- getCabalVersion
34 allPass <- parFoldM (testWorkerThreads settings) (runTestSuite cabalVersion settings testdir) (&&) True $ Map.toList selected
35 unless allPass $ error $ "There were failures, please see the logs in " ++ testdir
36 where
37 notSkipped p _ = p `Set.notMember` bpSkippedTests bp
39getCabalVersion :: IO CabalVersion
40getCabalVersion = do
41 output <- readProcess "cabal" ["--numeric-version"] ""
42 case filter (null . snd) $ readP_to_S parseVersion $ filter notCRLF output of
43 (Version (x:y:_) _, _):_ -> return $ CabalVersion x y
44 _ -> error $ "Invalid cabal version: " ++ show output
45 where
46 notCRLF '\n' = False
47 notCRLF '\r' = False
48 notCRLF _ = True
50parFoldM :: Int -- ^ number of threads
51 -> (b -> IO c)
52 -> (a -> c -> a)
53 -> a
54 -> [b]
55 -> IO a
56parFoldM threadCount0 f g a0 bs0 = do
57 ma <- C.newMVar a0
58 mbs <- C.newMVar bs0
59 signal <- C.newEmptyMVar
60 tids <- replicateM threadCount0 $ C.forkIO $ worker ma mbs signal
61 wait threadCount0 signal tids
62 C.takeMVar ma
63 where
64 worker ma mbs signal =
65 handle
66 (C.putMVar signal . Just)
67 (loop >> C.putMVar signal Nothing)
68 where
69 loop = do
70 mb <- C.modifyMVar mbs $ \bs -> return $
71 case bs of
72 [] -> ([], Nothing)
73 b:bs' -> (bs', Just b)
74 case mb of
75 Nothing -> return ()
76 Just b -> do
77 c <- f b
78 C.modifyMVar_ ma $ \a -> return $! g a c
79 loop
80 wait threadCount signal tids
81 | threadCount == 0 = return ()
82 | otherwise = do
83 me <- C.takeMVar signal
84 case me of
85 Nothing -> wait (threadCount - 1) signal tids
86 Just e -> do
87 mapM_ C.killThread tids
88 throwIO (e :: SomeException)
90data TestException = TestException
91 deriving (Show, Typeable)
92instance Exception TestException
94data CabalVersion = CabalVersion Int Int
95 deriving (Eq, Ord, Show)
97runTestSuite :: CabalVersion
98 -> BuildSettings
99 -> FilePath
100 -> (PackageName, SelectedPackageInfo)
101 -> IO Bool
102runTestSuite cabalVersion settings testdir (packageName, SelectedPackageInfo {..}) = do
103 -- Set up a new environment that includes the sandboxed bin folder in PATH.
104 env' <- getModifiedEnv settings
105 let menv addGPP
106 = Just $ (if addGPP then (("GHC_PACKAGE_PATH", packageDir settings ++ ":"):) else id)
107 $ addSandbox env'
108 -- FIXME why do these packages require the workaround?
109 bannedSandboxVar = map PackageName $ words "wai-logger warp"
110 addSandbox
111 | packageName `elem` bannedSandboxVar = id
112 | otherwise = (("HASKELL_PACKAGE_SANDBOX", packageDir settings):)
114 let runGen addGPP cmd args wdir handle' = do
115 ph <- runProcess cmd args (Just wdir) (menv addGPP) Nothing (Just handle') (Just handle')
116 ec <- waitForProcess ph
117 unless (ec == ExitSuccess) $ throwIO TestException
119 let run = runGen False
120 runGhcPackagePath = runGen True
122 passed <- handle (\TestException -> return False) $ do
123 package' <- replaceTarball (tarballDir settings) package
124 getHandle WriteMode $ run "cabal" ["unpack", package'] testdir
125 case cabalFileDir settings of
126 Nothing -> return ()
127 Just cfd -> do
128 let PackageName name = packageName
129 basename = name ++ ".cabal"
130 src = dir </> basename
131 dst = cfd </> basename
132 createDirectoryIfMissing True cfd
133 copyFile src dst
134 getHandle AppendMode $ run "cabal" (addCabalArgs settings BSTest ["configure", "--enable-tests"]) dir
135 when spiHasTests $ do
136 getHandle AppendMode $ run "cabal" ["build"] dir
137 getHandle AppendMode $ runGhcPackagePath "cabal" (concat
138 [ ["test"]
139 , if cabalVersion >= CabalVersion 1 20
140 then ["--show-details=streaming"] -- FIXME temporary workaround for https://github.com/haskell/cabal/issues/1810
141 else []
142 ]) dir
143 when (buildDocs settings) $
144 getHandle AppendMode $ run "cabal" ["haddock"] dir
145 return True
146 let expectedFailure = packageName `Set.member` expectedFailuresBuild settings
147 if passed
148 then do
149 removeFile logfile
150 when expectedFailure $ putStrLn $ package ++ " passed, but I didn't think it would."
151 else unless expectedFailure $ putStrLn $ concat
152 [ "Test suite failed: "
153 , package
154 , "("
155 , unMaintainer spiMaintainer
156 , githubMentions spiGithubUser
157 , ")"
158 ]
159 rm_r dir
160 return $! passed || expectedFailure
161 where
162 logfile = testdir </> package <.> "log"
163 dir = testdir </> package
164 getHandle mode = withBinaryFile logfile mode
165 package = packageVersionString (packageName, spiVersion)