git.iko.soy/stackage
on aa5a30e help sign in
stackage/Stackage/Test.hs
126 lines 4.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, handle, throwIO, SomeException)
9import Control.Monad (unless, when, replicateM)
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 (createDirectory, removeFile)
16import System.Exit (ExitCode (ExitSuccess))
17import System.FilePath ((<.>), (</>))
18import System.IO (IOMode (WriteMode, AppendMode),
19 withBinaryFile)
20import System.Process (runProcess, waitForProcess)
22runTestSuites :: BuildSettings -> BuildPlan -> IO ()
23runTestSuites settings' bp = do
24 settings <- fixBuildSettings settings'
25 let selected = bpPackages bp
26 putStrLn "Running test suites"
27 let testdir = "runtests"
28 rm_r testdir
29 createDirectory testdir
30 allPass <- parFoldM (testWorkerThreads settings) (runTestSuite settings testdir) (&&) True $ Map.toList selected
31 unless allPass $ error $ "There were failures, please see the logs in " ++ testdir
33parFoldM :: Int -- ^ number of threads
34 -> (b -> IO c)
35 -> (a -> c -> a)
36 -> a
37 -> [b]
38 -> IO a
39parFoldM threadCount0 f g a0 bs0 = do
40 ma <- C.newMVar a0
41 mbs <- C.newMVar bs0
42 signal <- C.newEmptyMVar
43 tids <- replicateM threadCount0 $ C.forkIO $ worker ma mbs signal
44 wait threadCount0 signal tids
45 C.takeMVar ma
46 where
47 worker ma mbs signal =
48 handle
49 (C.putMVar signal . Just)
50 (loop >> C.putMVar signal Nothing)
51 where
52 loop = do
53 mb <- C.modifyMVar mbs $ \bs -> return $
54 case bs of
55 [] -> ([], Nothing)
56 b:bs' -> (bs', Just b)
57 case mb of
58 Nothing -> return ()
59 Just b -> do
60 c <- f b
61 C.modifyMVar_ ma $ \a -> return $! g a c
62 loop
63 wait threadCount signal tids
64 | threadCount == 0 = return ()
65 | otherwise = do
66 me <- C.takeMVar signal
67 case me of
68 Nothing -> wait (threadCount - 1) signal tids
69 Just e -> do
70 mapM_ C.killThread tids
71 throwIO (e :: SomeException)
73data TestException = TestException
74 deriving (Show, Typeable)
75instance Exception TestException
77runTestSuite :: BuildSettings
78 -> FilePath
79 -> (PackageName, SelectedPackageInfo)
80 -> IO Bool
81runTestSuite settings testdir (packageName, SelectedPackageInfo {..}) = do
82 -- Set up a new environment that includes the sandboxed bin folder in PATH.
83 env' <- getModifiedEnv settings
84 let menv addGPP
85 = Just $ (if addGPP then (("GHC_PACKAGE_PATH", packageDir settings ++ ":"):) else id)
86 $ ("HASKELL_PACKAGE_SANDBOX", packageDir settings)
87 : env'
89 let runGen addGPP cmd args wdir handle' = do
90 ph <- runProcess cmd args (Just wdir) (menv addGPP) Nothing (Just handle') (Just handle')
91 ec <- waitForProcess ph
92 unless (ec == ExitSuccess) $ throwIO TestException
94 let run = runGen False
95 runGhcPackagePath = runGen True
97 passed <- handle (\TestException -> return False) $ do
98 getHandle WriteMode $ run "cabal" ["unpack", package] testdir
99 getHandle AppendMode $ run "cabal" (addCabalArgs settings ["configure", "--enable-tests"]) dir
100 when spiHasTests $ do
101 getHandle AppendMode $ run "cabal" ["build"] dir
102 getHandle AppendMode $ runGhcPackagePath "cabal" ["test"] dir
103 getHandle AppendMode $ run "cabal" ["haddock"] dir
104 return True
105 let expectedFailure = packageName `Set.member` expectedFailuresBuild settings
106 if passed
107 then do
108 removeFile logfile
109 when expectedFailure $ putStrLn $ package ++ " passed, but I didn't think it would."
110 else unless expectedFailure $ putStrLn $ concat
111 [ "Test suite failed: "
112 , package
113 , "("
114 , unMaintainer spiMaintainer
115 , case spiGithubUser of
116 Nothing -> ""
117 Just x -> " @" ++ x
118 , ")"
119 ]
120 rm_r dir
121 return $! passed || expectedFailure
122 where
123 logfile = testdir </> package <.> "log"
124 dir = testdir </> package
125 getHandle mode = withBinaryFile logfile mode
126 package = packageVersionString (packageName, spiVersion)