git.iko.soy/stackage
on 77fa7fa help sign in
stackage/Stackage/Test.hs
289 lines 12 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, try)
10import Control.Monad (replicateM, unless, when, forM_)
11import qualified Data.Map as Map
12import qualified Data.Set as Set
13import qualified Control.Monad.Trans.Writer as W
14import Distribution.Package (Dependency (Dependency))
15import Data.Version (parseVersion, Version (Version))
16import Data.Typeable (Typeable)
17import Stackage.Types
18import Stackage.Util
19import System.Directory (copyFile, createDirectory,
20 createDirectoryIfMissing, doesFileExist, findExecutable,
21 getDirectoryContents, removeFile,
22 renameDirectory, canonicalizePath)
23import System.Exit (ExitCode (ExitSuccess))
24import System.FilePath ((<.>), (</>), takeDirectory)
25import System.IO (IOMode (WriteMode, AppendMode),
26 withBinaryFile)
27import System.Process (readProcess, runProcess, waitForProcess, createProcess, proc, cwd)
28import Text.ParserCombinators.ReadP (readP_to_S)
29import Data.IORef (IORef, readIORef, atomicModifyIORef, newIORef)
30import qualified Data.ByteString.Lazy as L
31import qualified Data.ByteString.Lazy.Char8 as L8
32import qualified Distribution.PackageDescription as PD
33import Distribution.PackageDescription.Parse (ParseResult (ParseOk),
34 parsePackageDescription)
36runTestSuites :: BuildSettings -> BuildPlan -> IO ()
37runTestSuites settings' bp = do
38 settings <- fixBuildSettings settings'
39 let selected' = Map.filterWithKey notSkipped $ bpPackages bp
40 let testdir = "runtests"
41 docdir = "haddock"
42 rm_r testdir
43 rm_r docdir
44 createDirectory testdir
45 createDirectory docdir
47 putStrLn "Determining package dependencies"
48 selected <- mapM (addDependencies settings (Map.keysSet selected') testdir)
49 $ Map.toList selected'
50 putStrLn "Running test suites"
52 copyBuiltInHaddocks docdir
54 cabalVersion <- getCabalVersion
55 haddockFilesRef <- newIORef []
56 allPass <- parFoldM
57 (testWorkerThreads settings)
58 (runTestSuite cabalVersion settings testdir docdir bp haddockFilesRef)
59 (&&)
60 True
61 selected
62 unless allPass $ error $ "There were failures, please see the logs in " ++ testdir
63 where
64 notSkipped p _ = p `Set.notMember` bpSkippedTests bp
66addDependencies :: BuildSettings
67 -> Set PackageName -- ^ all packages to be installed
68 -> FilePath -- ^ testdir
69 -> (PackageName, SelectedPackageInfo)
70 -> IO (PackageName, Set PackageName, SelectedPackageInfo)
71addDependencies settings allPackages testdir (packageName, spi) = do
72 package' <- replaceTarball (tarballDir settings) package
73 deps <- handle (\e -> print (e :: IOException) >> return Set.empty)
74 $ getDeps allPackages testdir packageName package package'
75 return (packageName, deps, spi)
76 where
77 package = packageVersionString (packageName, spiVersion spi)
79getDeps :: Set PackageName -- ^ all packages to be installed
80 -> FilePath -> PackageName -> String -> String -> IO (Set PackageName)
81getDeps allPackages testdir (PackageName name) nameVer loc = do
82 (Nothing, Nothing, Nothing, ph) <- createProcess
83 (proc "cabal" ["unpack", loc, "--verbose=0"]) { cwd = Just testdir }
84 ec <- waitForProcess ph
85 unless (ec == ExitSuccess) $ error $ "Unable to unpack: " ++ loc
86 lbs <- L.readFile $ testdir </> nameVer </> name <.> "cabal"
87 case parsePackageDescription $ L8.unpack lbs of
88 ParseOk _ gpd -> return $ Set.intersection allPackages $ allLibraryDeps gpd
89 _ -> return Set.empty
91allLibraryDeps :: PD.GenericPackageDescription -> Set PackageName
92allLibraryDeps =
93 maybe Set.empty (W.execWriter . goTree) . PD.condLibrary
94 where
95 goTree tree = do
96 mapM_ goDep $ PD.condTreeConstraints tree
97 forM_ (PD.condTreeComponents tree) $ \(_, y, z) -> do
98 goTree y
99 maybe (return ()) goTree z
101 goDep (Dependency pn _) = W.tell $ Set.singleton pn
103getCabalVersion :: IO CabalVersion
104getCabalVersion = do
105 output <- readProcess "cabal" ["--numeric-version"] ""
106 case filter (null . snd) $ readP_to_S parseVersion $ filter notCRLF output of
107 (Version (x:y:_) _, _):_ -> return $ CabalVersion x y
108 _ -> error $ "Invalid cabal version: " ++ show output
109 where
110 notCRLF '\n' = False
111 notCRLF '\r' = False
112 notCRLF _ = True
114parFoldM :: Int -- ^ number of threads
115 -> ((PackageName, payload) -> IO c)
116 -> (a -> c -> a)
117 -> a
118 -> [(PackageName, Set PackageName, payload)]
119 -> IO a
120parFoldM threadCount0 f g a0 bs0 = do
121 ma <- C.newMVar a0
122 mbs <- C.newMVar bs0
123 signal <- C.newEmptyMVar
124 completed <- newIORef Set.empty
125 tids <- replicateM threadCount0 $ C.forkIO $ worker completed ma mbs signal
126 wait threadCount0 signal tids
128 unrun <- C.takeMVar mbs
129 when (not $ null unrun) $
130 error $ "The following tests were not run: " ++ unwords
131 [x | (PackageName x, _, _) <- unrun]
132 C.takeMVar ma
133 where
134 worker completedRef ma mbs signal =
135 handle
136 (C.putMVar signal . Just)
137 (loop >> C.putMVar signal Nothing)
138 where
139 loop = do
140 mb <- C.modifyMVar mbs $ \bs -> do
141 completed <- readIORef completedRef
142 return $ case findReady completed bs of
143 -- There's a workload ready with no deps
144 Just (b, bs') -> (bs', Just b)
145 -- No workload with no deps
146 Nothing -> (bs, Nothing)
147 case mb of
148 Nothing -> return ()
149 Just (name, _, payload) -> do
150 c <- f (name, payload)
151 C.modifyMVar_ ma $ \a -> return $! g a c
152 atomicModifyIORef completedRef $ \s -> (Set.insert name s, ())
153 loop
154 wait threadCount signal tids
155 | threadCount == 0 = return ()
156 | otherwise = do
157 me <- C.takeMVar signal
158 case me of
159 Nothing -> wait (threadCount - 1) signal tids
160 Just e -> do
161 mapM_ C.killThread tids
162 throwIO (e :: SomeException)
164-- | Find a workload whose dependencies have been met.
165findReady :: Ord key
166 => Set key -- ^ workloads already complete
167 -> [(key, Set key, value)]
168 -> Maybe ((key, Set key, value), [(key, Set key, value)])
169findReady completed =
170 loop id
171 where
172 loop _ [] = Nothing
173 loop front (x@(_, deps, _):xs)
174 | Set.null $ Set.difference deps completed = Just (x, front xs)
175 | otherwise = loop (front . (x:)) xs
177data TestException = TestException
178 deriving (Show, Typeable)
179instance Exception TestException
181data CabalVersion = CabalVersion Int Int
182 deriving (Eq, Ord, Show)
184runTestSuite :: CabalVersion
185 -> BuildSettings
186 -> FilePath -- ^ testdir
187 -> FilePath -- ^ docdir
188 -> BuildPlan
189 -> IORef [(String, FilePath)] -- ^ .haddock files
190 -> (PackageName, SelectedPackageInfo)
191 -> IO Bool
192runTestSuite cabalVersion settings testdir docdir
193 bp haddockFilesRef (packageName, SelectedPackageInfo {..}) = do
194 -- Set up a new environment that includes the sandboxed bin folder in PATH.
195 env' <- getModifiedEnv settings
196 let menv = Just $ addSandbox env'
197 addSandbox = (("HASKELL_PACKAGE_SANDBOX", packageDir settings):)
199 let run cmd args wdir handle' = do
200 ph <- runProcess cmd args (Just wdir) menv Nothing (Just handle') (Just handle')
201 ec <- waitForProcess ph
202 unless (ec == ExitSuccess) $ throwIO TestException
204 passed <- handle (\TestException -> return False) $ do
205 case cabalFileDir settings of
206 Nothing -> return ()
207 Just cfd -> do
208 let PackageName name = packageName
209 basename = name ++ ".cabal"
210 src = dir </> basename
211 dst = cfd </> basename
212 createDirectoryIfMissing True cfd
213 copyFile src dst
214 getHandle WriteMode $ run "cabal" (addCabalArgs settings BSTest ["configure", "--enable-tests"]) dir
216 -- Try building docs first in case tests have an expected failure.
217 when (buildDocs settings) $ do
218 hfs <- readIORef haddockFilesRef
219 let hfsOpts = flip map hfs $ \(pkgVer, hf) -> concat
220 [ "--haddock-options=--read-interface="
221 , "../"
222 , pkgVer
223 , "/,"
224 , hf
225 ]
226 getHandle AppendMode $ run "cabal"
227 ( "haddock"
228 : "--hyperlink-source"
229 : "--html"
230 : "--hoogle"
231 : "--html-location=../$pkg-$version/"
232 : hfsOpts) dir
233 let PackageName packageName' = packageName
234 handle (\(_ :: IOException) -> return ()) $ renameDirectory
235 (dir </> "dist" </> "doc" </> "html" </> packageName')
236 (docdir </> package)
238 enewPath <- try $ canonicalizePath $ docdir </> package </> packageName' <.> "haddock"
239 case enewPath :: Either IOException FilePath of
240 Left _ -> return () -- print e
241 Right newPath -> atomicModifyIORef haddockFilesRef $ \hfs'
242 -> ((package, newPath) : hfs', ())
244 when spiHasTests $ do
245 getHandle AppendMode $ run "cabal" ["build"] dir
246 getHandle AppendMode $ run "cabal" (concat
247 [ ["test"]
248 , if cabalVersion >= CabalVersion 1 20
249 then ["--show-details=streaming"] -- FIXME temporary workaround for https://github.com/haskell/cabal/issues/1810
250 else []
251 ]) dir
252 return True
253 let expectedFailure = packageName `Set.member` bpExpectedFailures bp
254 if passed
255 then do
256 removeFile logfile
257 when expectedFailure $ putStrLn $ " " ++ package ++ " passed, but I didn't think it would."
258 else unless expectedFailure $ putStrLn $ concat
259 [ "Test suite failed: "
260 , package
261 , "("
262 , unMaintainer spiMaintainer
263 , githubMentions spiGithubUser
264 , ")"
265 ]
266 rm_r dir
267 return $! passed || expectedFailure
268 where
269 logfile = testdir </> package <.> "log"
270 dir = testdir </> package
271 getHandle mode = withBinaryFile logfile mode
272 package = packageVersionString (packageName, spiVersion)
274copyBuiltInHaddocks docdir = do
275 Just ghc <- findExecutable "ghc"
276 copyTree (takeDirectory ghc </> "../share/doc/ghc/html/libraries") docdir
277 where
278 copyTree src dest = do
279 entries <- fmap (filter (\s -> s /= "." && s /= ".."))
280 $ getDirectoryContents src
281 forM_ entries $ \entry -> do
282 let src' = src </> entry
283 dest' = dest </> entry
284 isFile <- doesFileExist src'
285 if isFile
286 then copyFile src' dest'
287 else do
288 createDirectory dest'
289 copyTree src' dest'