git.iko.soy/stackage
on 360b181 help sign in
stackage/Stackage/Test.hs
127 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, 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 (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 BSTest ["configure", "--enable-tests"]) dir
100 when spiHasTests $ do
101 getHandle AppendMode $ run "cabal" ["build"] dir
102 getHandle AppendMode $ runGhcPackagePath "cabal" ["test"] dir
103 when (buildDocs settings) $
104 getHandle AppendMode $ run "cabal" ["haddock"] dir
105 return True
106 let expectedFailure = packageName `Set.member` expectedFailuresBuild settings
107 if passed
108 then do
109 removeFile logfile
110 when expectedFailure $ putStrLn $ package ++ " passed, but I didn't think it would."
111 else unless expectedFailure $ putStrLn $ concat
112 [ "Test suite failed: "
113 , package
114 , "("
115 , unMaintainer spiMaintainer
116 , case spiGithubUser of
117 Nothing -> ""
118 Just x -> " @" ++ x
119 , ")"
120 ]
121 rm_r dir
122 return $! passed || expectedFailure
123 where
124 logfile = testdir </> package <.> "log"
125 dir = testdir </> package
126 getHandle mode = withBinaryFile logfile mode
127 package = packageVersionString (packageName, spiVersion)