git.iko.soy/stackage
on 1ecbd80 help sign in
stackage/Stackage/Test.hs
129 lines 5.0 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 = Map.filterWithKey notSkipped $ 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
32 where
33 notSkipped p _ = p `Set.notMember` bpSkippedTests bp
35parFoldM :: Int -- ^ number of threads
36 -> (b -> IO c)
37 -> (a -> c -> a)
38 -> a
39 -> [b]
40 -> IO a
41parFoldM threadCount0 f g a0 bs0 = do
42 ma <- C.newMVar a0
43 mbs <- C.newMVar bs0
44 signal <- C.newEmptyMVar
45 tids <- replicateM threadCount0 $ C.forkIO $ worker ma mbs signal
46 wait threadCount0 signal tids
47 C.takeMVar ma
48 where
49 worker ma mbs signal =
50 handle
51 (C.putMVar signal . Just)
52 (loop >> C.putMVar signal Nothing)
53 where
54 loop = do
55 mb <- C.modifyMVar mbs $ \bs -> return $
56 case bs of
57 [] -> ([], Nothing)
58 b:bs' -> (bs', Just b)
59 case mb of
60 Nothing -> return ()
61 Just b -> do
62 c <- f b
63 C.modifyMVar_ ma $ \a -> return $! g a c
64 loop
65 wait threadCount signal tids
66 | threadCount == 0 = return ()
67 | otherwise = do
68 me <- C.takeMVar signal
69 case me of
70 Nothing -> wait (threadCount - 1) signal tids
71 Just e -> do
72 mapM_ C.killThread tids
73 throwIO (e :: SomeException)
75data TestException = TestException
76 deriving (Show, Typeable)
77instance Exception TestException
79runTestSuite :: BuildSettings
80 -> FilePath
81 -> (PackageName, SelectedPackageInfo)
82 -> IO Bool
83runTestSuite settings testdir (packageName, SelectedPackageInfo {..}) = do
84 -- Set up a new environment that includes the sandboxed bin folder in PATH.
85 env' <- getModifiedEnv settings
86 let menv addGPP
87 = Just $ (if addGPP then (("GHC_PACKAGE_PATH", packageDir settings ++ ":"):) else id)
88 $ ("HASKELL_PACKAGE_SANDBOX", packageDir settings)
89 : env'
91 let runGen addGPP cmd args wdir handle' = do
92 ph <- runProcess cmd args (Just wdir) (menv addGPP) Nothing (Just handle') (Just handle')
93 ec <- waitForProcess ph
94 unless (ec == ExitSuccess) $ throwIO TestException
96 let run = runGen False
97 runGhcPackagePath = runGen True
99 passed <- handle (\TestException -> return False) $ do
100 getHandle WriteMode $ run "cabal" ["unpack", package] testdir
101 getHandle AppendMode $ run "cabal" (addCabalArgs settings BSTest ["configure", "--enable-tests"]) dir
102 when spiHasTests $ do
103 getHandle AppendMode $ run "cabal" ["build"] dir
104 getHandle AppendMode $ runGhcPackagePath "cabal" ["test"] dir
105 when (buildDocs settings) $
106 getHandle AppendMode $ run "cabal" ["haddock"] dir
107 return True
108 let expectedFailure = packageName `Set.member` expectedFailuresBuild settings
109 if passed
110 then do
111 removeFile logfile
112 when expectedFailure $ putStrLn $ package ++ " passed, but I didn't think it would."
113 else unless expectedFailure $ putStrLn $ concat
114 [ "Test suite failed: "
115 , package
116 , "("
117 , unMaintainer spiMaintainer
118 , case spiGithubUser of
119 Nothing -> ""
120 Just x -> " @" ++ x
121 , ")"
122 ]
123 rm_r dir
124 return $! passed || expectedFailure
125 where
126 logfile = testdir </> package <.> "log"
127 dir = testdir </> package
128 getHandle mode = withBinaryFile logfile mode
129 package = packageVersionString (packageName, spiVersion)