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