git.iko.soy/stackage
on e005ca2 help sign in
stackage/Stackage/Test.hs
118 lines 4.7 kB history raw
1{-# LANGUAGE DeriveDataTypeable #-}
2module Stackage.Test
3 ( runTestSuites
4 ) where
6import qualified Control.Concurrent as C
7import Control.Exception (Exception, handle, throwIO, SomeException)
8import Control.Monad (unless, when, replicateM)
9import qualified Data.Map as Map
10import qualified Data.Set as Set
11import Data.Typeable (Typeable)
12import Stackage.Types
13import Stackage.Util
14import System.Directory (createDirectory, removeFile)
15import System.Exit (ExitCode (ExitSuccess))
16import System.FilePath ((<.>), (</>))
17import System.IO (IOMode (WriteMode, AppendMode),
18 withBinaryFile)
19import System.Process (runProcess, waitForProcess)
21runTestSuites :: BuildSettings -> InstallInfo -> IO ()
22runTestSuites settings ii = do
23 let testdir = "runtests"
24 rm_r testdir
25 createDirectory testdir
26 allPass <- parFoldM (testWorkerThreads settings) (runTestSuite settings testdir hasTestSuites) (&&) True $ Map.toList $ iiPackages ii
27 unless allPass $ error $ "There were failures, please see the logs in " ++ testdir
28 where
29 PackageDB pdb = iiPackageDB ii
31 hasTestSuites name = maybe defaultHasTestSuites piHasTests $ Map.lookup name pdb
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 -> Bool) -- ^ do we have any test suites?
80 -> (PackageName, (Version, Maintainer))
81 -> IO Bool
82runTestSuite settings testdir hasTestSuites (packageName, (version, Maintainer maintainer)) = do
83 -- Set up a new environment that includes the sandboxed bin folder in PATH.
84 env' <- getModifiedEnv settings
85 let menv addGPP
86 = Just $ (if addGPP then (("GHC_PACKAGE_PATH", packageDir settings ++ ":"):) else id)
87 $ ("HASKELL_PACKAGE_SANDBOX", packageDir settings)
88 : env'
90 let runGen addGPP cmd args wdir handle' = do
91 ph <- runProcess cmd args (Just wdir) (menv addGPP) Nothing (Just handle') (Just handle')
92 ec <- waitForProcess ph
93 unless (ec == ExitSuccess) $ throwIO TestException
95 let run = runGen False
96 runGhcPackagePath = runGen True
98 passed <- handle (\TestException -> return False) $ do
99 getHandle WriteMode $ run "cabal" ["unpack", package] testdir
100 getHandle AppendMode $ run "cabal" (addCabalArgs settings ["configure", "--enable-tests"]) dir
101 when (hasTestSuites packageName) $ do
102 getHandle AppendMode $ run "cabal" ["build"] dir
103 getHandle AppendMode $ runGhcPackagePath "cabal" ["test"] dir
104 getHandle AppendMode $ run "cabal" ["haddock"] dir
105 return True
106 let expectedFailure = packageName `Set.member` expectedFailures 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 $ "Test suite failed: " ++ package ++ "(" ++ maintainer ++ ")"
112 rm_r dir
113 return $! passed || expectedFailure
114 where
115 logfile = testdir </> package <.> "log"
116 dir = testdir </> package
117 getHandle mode = withBinaryFile logfile mode
118 package = packageVersionString (packageName, version)