git.iko.soy/stackage
on 19b7bbd help sign in
stackage/Stackage/Test.hs
193 lines 7.6 kB history raw
1{-# LANGUAGE DeriveDataTypeable #-}
2{-# LANGUAGE RecordWildCards #-}
3{-# LANGUAGE ScopedTypeVariables #-}
4module Stackage.Test
5 ( runTestSuites
6 ) where
8import qualified Control.Concurrent as C
9import Control.Exception (Exception, SomeException, handle, throwIO, IOException)
10import Control.Monad (replicateM, unless, when, forM_)
11import qualified Data.Map as Map
12import qualified Data.Set as Set
13import Data.Version (parseVersion, Version (Version))
14import Data.Typeable (Typeable)
15import Stackage.Types
16import Stackage.Util
17import System.Directory (copyFile, createDirectory,
18 createDirectoryIfMissing, doesFileExist, findExecutable,
19 getDirectoryContents, removeFile,
20 renameDirectory)
21import System.Exit (ExitCode (ExitSuccess))
22import System.FilePath ((<.>), (</>), takeDirectory)
23import System.IO (IOMode (WriteMode, AppendMode),
24 withBinaryFile)
25import System.Process (readProcess, runProcess, waitForProcess)
26import Text.ParserCombinators.ReadP (readP_to_S)
28runTestSuites :: BuildSettings -> BuildPlan -> IO ()
29runTestSuites settings' bp = do
30 settings <- fixBuildSettings settings'
31 let selected = Map.filterWithKey notSkipped $ bpPackages bp
32 putStrLn "Running test suites"
33 let testdir = "runtests"
34 docdir = "haddock"
35 rm_r testdir
36 rm_r docdir
37 createDirectory testdir
38 createDirectory docdir
40 copyBuiltInHaddocks docdir
42 cabalVersion <- getCabalVersion
43 allPass <- parFoldM (testWorkerThreads settings) (runTestSuite cabalVersion settings testdir docdir) (&&) True $ Map.toList selected
44 unless allPass $ error $ "There were failures, please see the logs in " ++ testdir
45 where
46 notSkipped p _ = p `Set.notMember` bpSkippedTests bp
48getCabalVersion :: IO CabalVersion
49getCabalVersion = do
50 output <- readProcess "cabal" ["--numeric-version"] ""
51 case filter (null . snd) $ readP_to_S parseVersion $ filter notCRLF output of
52 (Version (x:y:_) _, _):_ -> return $ CabalVersion x y
53 _ -> error $ "Invalid cabal version: " ++ show output
54 where
55 notCRLF '\n' = False
56 notCRLF '\r' = False
57 notCRLF _ = True
59parFoldM :: Int -- ^ number of threads
60 -> (b -> IO c)
61 -> (a -> c -> a)
62 -> a
63 -> [b]
64 -> IO a
65parFoldM threadCount0 f g a0 bs0 = do
66 ma <- C.newMVar a0
67 mbs <- C.newMVar bs0
68 signal <- C.newEmptyMVar
69 tids <- replicateM threadCount0 $ C.forkIO $ worker ma mbs signal
70 wait threadCount0 signal tids
71 C.takeMVar ma
72 where
73 worker ma mbs signal =
74 handle
75 (C.putMVar signal . Just)
76 (loop >> C.putMVar signal Nothing)
77 where
78 loop = do
79 mb <- C.modifyMVar mbs $ \bs -> return $
80 case bs of
81 [] -> ([], Nothing)
82 b:bs' -> (bs', Just b)
83 case mb of
84 Nothing -> return ()
85 Just b -> do
86 c <- f b
87 C.modifyMVar_ ma $ \a -> return $! g a c
88 loop
89 wait threadCount signal tids
90 | threadCount == 0 = return ()
91 | otherwise = do
92 me <- C.takeMVar signal
93 case me of
94 Nothing -> wait (threadCount - 1) signal tids
95 Just e -> do
96 mapM_ C.killThread tids
97 throwIO (e :: SomeException)
99data TestException = TestException
100 deriving (Show, Typeable)
101instance Exception TestException
103data CabalVersion = CabalVersion Int Int
104 deriving (Eq, Ord, Show)
106runTestSuite :: CabalVersion
107 -> BuildSettings
108 -> FilePath -- ^ testdir
109 -> FilePath -- ^ docdir
110 -> (PackageName, SelectedPackageInfo)
111 -> IO Bool
112runTestSuite cabalVersion settings testdir docdir (packageName, SelectedPackageInfo {..}) = do
113 -- Set up a new environment that includes the sandboxed bin folder in PATH.
114 env' <- getModifiedEnv settings
115 let menv = Just $ addSandbox env'
116 addSandbox = (("HASKELL_PACKAGE_SANDBOX", packageDir settings):)
118 let run cmd args wdir handle' = do
119 ph <- runProcess cmd args (Just wdir) menv Nothing (Just handle') (Just handle')
120 ec <- waitForProcess ph
121 unless (ec == ExitSuccess) $ throwIO TestException
123 passed <- handle (\TestException -> return False) $ do
124 package' <- replaceTarball (tarballDir settings) package
125 getHandle WriteMode $ run "cabal" ["unpack", package'] testdir
126 case cabalFileDir settings of
127 Nothing -> return ()
128 Just cfd -> do
129 let PackageName name = packageName
130 basename = name ++ ".cabal"
131 src = dir </> basename
132 dst = cfd </> basename
133 createDirectoryIfMissing True cfd
134 copyFile src dst
135 getHandle AppendMode $ run "cabal" (addCabalArgs settings BSTest ["configure", "--enable-tests"]) dir
136 when spiHasTests $ do
137 getHandle AppendMode $ run "cabal" ["build"] dir
138 getHandle AppendMode $ run "cabal" (concat
139 [ ["test"]
140 , if cabalVersion >= CabalVersion 1 20
141 then ["--show-details=streaming"] -- FIXME temporary workaround for https://github.com/haskell/cabal/issues/1810
142 else []
143 ]) dir
144 when (buildDocs settings) $ do
145 getHandle AppendMode $ run "cabal"
146 [ "haddock"
147 , "--hyperlink-source"
148 , "--html"
149 , "--hoogle"
150 , "--html-location=../$pkg-$version/"
151 ] dir
152 let PackageName packageName' = packageName
153 handle (\(_ :: IOException) -> return ()) $ renameDirectory
154 (dir </> "dist" </> "doc" </> "html" </> packageName')
155 (docdir </> package)
156 return True
157 let expectedFailure = packageName `Set.member` expectedFailuresBuild settings
158 if passed
159 then do
160 removeFile logfile
161 when expectedFailure $ putStrLn $ " " ++ package ++ " passed, but I didn't think it would."
162 else unless expectedFailure $ putStrLn $ concat
163 [ "Test suite failed: "
164 , package
165 , "("
166 , unMaintainer spiMaintainer
167 , githubMentions spiGithubUser
168 , ")"
169 ]
170 rm_r dir
171 return $! passed || expectedFailure
172 where
173 logfile = testdir </> package <.> "log"
174 dir = testdir </> package
175 getHandle mode = withBinaryFile logfile mode
176 package = packageVersionString (packageName, spiVersion)
178copyBuiltInHaddocks docdir = do
179 Just ghc <- findExecutable "ghc"
180 copyTree (takeDirectory ghc </> "../share/doc/ghc/html/libraries") docdir
181 where
182 copyTree src dest = do
183 entries <- fmap (filter (\s -> s /= "." && s /= ".."))
184 $ getDirectoryContents src
185 forM_ entries $ \entry -> do
186 let src' = src </> entry
187 dest' = dest </> entry
188 isFile <- doesFileExist src'
189 if isFile
190 then copyFile src' dest'
191 else do
192 createDirectory dest'
193 copyTree src' dest'