git.iko.soy/stackage
on 3e1e9ab help sign in
stackage/Stackage/Test.hs
156 lines 6.2 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 = Just $ addSandbox env'
106 addSandbox = (("HASKELL_PACKAGE_SANDBOX", packageDir settings):)
108 let run cmd args wdir handle' = do
109 ph <- runProcess cmd args (Just wdir) menv Nothing (Just handle') (Just handle')
110 ec <- waitForProcess ph
111 unless (ec == ExitSuccess) $ throwIO TestException
113 passed <- handle (\TestException -> return False) $ do
114 package' <- replaceTarball (tarballDir settings) package
115 getHandle WriteMode $ run "cabal" ["unpack", package'] testdir
116 case cabalFileDir settings of
117 Nothing -> return ()
118 Just cfd -> do
119 let PackageName name = packageName
120 basename = name ++ ".cabal"
121 src = dir </> basename
122 dst = cfd </> basename
123 createDirectoryIfMissing True cfd
124 copyFile src dst
125 getHandle AppendMode $ run "cabal" (addCabalArgs settings BSTest ["configure", "--enable-tests"]) dir
126 when spiHasTests $ do
127 getHandle AppendMode $ run "cabal" ["build"] dir
128 getHandle AppendMode $ run "cabal" (concat
129 [ ["test"]
130 , if cabalVersion >= CabalVersion 1 20
131 then ["--show-details=streaming"] -- FIXME temporary workaround for https://github.com/haskell/cabal/issues/1810
132 else []
133 ]) dir
134 when (buildDocs settings) $
135 getHandle AppendMode $ run "cabal" ["haddock"] dir
136 return True
137 let expectedFailure = packageName `Set.member` expectedFailuresBuild settings
138 if passed
139 then do
140 removeFile logfile
141 when expectedFailure $ putStrLn $ " " ++ package ++ " passed, but I didn't think it would."
142 else unless expectedFailure $ putStrLn $ concat
143 [ "Test suite failed: "
144 , package
145 , "("
146 , unMaintainer spiMaintainer
147 , githubMentions spiGithubUser
148 , ")"
149 ]
150 rm_r dir
151 return $! passed || expectedFailure
152 where
153 logfile = testdir </> package <.> "log"
154 dir = testdir </> package
155 getHandle mode = withBinaryFile logfile mode
156 package = packageVersionString (packageName, spiVersion)