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