git.iko.soy/stackage
on bb7e35e help sign in
stackage/Stackage/Test.hs
121 lines 4.9 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, finally, SomeException)
8import Control.Monad (foldM, unless, when, replicateM)
9import qualified Data.Map as Map
10import qualified Data.Set as Set
11import Data.Typeable (Typeable)
12import Stackage.Config
13import Stackage.Types
14import Stackage.Util
15import System.Directory (canonicalizePath, createDirectory,
16 removeFile)
17import System.Environment (getEnvironment)
18import System.Exit (ExitCode (ExitSuccess))
19import System.FilePath ((<.>), (</>))
20import System.IO (IOMode (WriteMode, AppendMode),
21 withBinaryFile)
22import System.Process (runProcess, waitForProcess)
24runTestSuites :: BuildSettings -> InstallInfo -> IO ()
25runTestSuites settings ii = do
26 let testdir = "runtests"
27 rm_r testdir
28 createDirectory testdir
29 allPass <- parFoldM (testWorkerThreads settings) (runTestSuite settings testdir hasTestSuites) (&&) True $ Map.toList $ iiPackages ii
30 unless allPass $ error $ "There were failures, please see the logs in " ++ testdir
31 where
32 PackageDB pdb = iiPackageDB ii
34 hasTestSuites name = maybe defaultHasTestSuites piHasTests $ Map.lookup name pdb
36parFoldM :: Int -- ^ number of threads
37 -> (b -> IO c)
38 -> (a -> c -> a)
39 -> a
40 -> [b]
41 -> IO a
42parFoldM threadCount f g a0 bs0 = do
43 ma <- C.newMVar a0
44 mbs <- C.newMVar bs0
45 signal <- C.newEmptyMVar
46 tids <- replicateM threadCount $ C.forkIO $ worker ma mbs signal
47 wait threadCount 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 -> Bool) -- ^ do we have any test suites?
83 -> (PackageName, (Version, Maintainer))
84 -> IO Bool
85runTestSuite settings testdir hasTestSuites (packageName, (version, Maintainer maintainer)) = do
86 -- Set up a new environment that includes the sandboxed bin folder in PATH.
87 env' <- getModifiedEnv settings
88 let menv addGPP
89 = Just $ (if addGPP then (("GHC_PACKAGE_PATH", packageDir settings ++ ":"):) else id)
90 $ ("HASKELL_PACKAGE_SANDBOX", packageDir settings)
91 : env'
93 let runGen addGPP cmd args wdir handle = do
94 ph <- runProcess cmd args (Just wdir) (menv addGPP) Nothing (Just handle) (Just handle)
95 ec <- waitForProcess ph
96 unless (ec == ExitSuccess) $ throwIO TestException
98 let run = runGen False
99 runGhcPackagePath = runGen True
101 passed <- handle (\TestException -> return False) $ do
102 getHandle WriteMode $ run "cabal" ["unpack", package] testdir
103 getHandle AppendMode $ run "cabal" (addCabalArgs settings ["configure", "--enable-tests"]) dir
104 when (hasTestSuites packageName) $ do
105 getHandle AppendMode $ run "cabal" ["build"] dir
106 getHandle AppendMode $ runGhcPackagePath "cabal" ["test"] dir
107 getHandle AppendMode $ run "cabal" ["haddock"] dir
108 return True
109 let expectedFailure = packageName `Set.member` expectedFailures 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 $ "Test suite failed: " ++ package ++ "(" ++ maintainer ++ ")"
115 rm_r dir
116 return $! passed || expectedFailure
117 where
118 logfile = testdir </> package <.> "log"
119 dir = testdir </> package
120 getHandle mode = withBinaryFile logfile mode
121 package = packageVersionString (packageName, version)