git.iko.soy/stackage
on 0239898 help sign in
stackage/Stackage/PerformBuild.hs
565 lines 21 kB history raw
1-- | Perform an actual build, generate a binary package database and a
2-- documentation directory in the process.
3{-# LANGUAGE CPP #-}
4{-# LANGUAGE DeriveDataTypeable #-}
5{-# LANGUAGE NoImplicitPrelude #-}
6{-# LANGUAGE OverloadedStrings #-}
7{-# LANGUAGE RecordWildCards #-}
8module Stackage.PerformBuild
9 ( performBuild
10 , PerformBuild (..)
11 , BuildException (..)
12 , pbDocDir
13 ) where
15import Control.Concurrent.Async (async)
16import Control.Concurrent.STM.TSem
17import Control.Monad.Writer.Strict (execWriter, tell)
18import qualified Data.Map as Map
19import Data.NonNull (fromNullable)
20import Filesystem (canonicalizePath, createTree,
21 getWorkingDirectory, isDirectory,
22 removeTree, rename, isFile, removeFile)
23import Filesystem.Path (parent)
24import qualified Filesystem.Path as F
25import Stackage.BuildConstraints
26import Stackage.BuildPlan
27import Stackage.GhcPkg
28import Stackage.PackageDescription
29import Stackage.Prelude hiding (pi)
30import System.Directory (findExecutable)
31import System.Environment (getEnvironment)
32import System.IO (IOMode (WriteMode),
33 openBinaryFile)
34import System.IO.Temp (withSystemTempDirectory)
36data BuildException = BuildException (Map PackageName BuildFailure) [Text]
37 deriving Typeable
38instance Exception BuildException
39instance Show BuildException where
40 show (BuildException m warnings) =
41 unlines $ map go (mapToList m) ++ map unpack warnings
42 where
43 go (PackageName name, bf) = concat
44 [ name
45 , ": "
46 , show bf
47 ]
49data BuildFailure = DependencyFailed PackageName
50 | DependencyMissing PackageName
51 | ToolMissing ExeName
52 | NotImplemented
53 | BuildFailureException SomeException
54 deriving (Show, Typeable)
55instance Exception BuildFailure
57data PerformBuild = PerformBuild
58 { pbPlan :: BuildPlan
59 , pbInstallDest :: FilePath
60 , pbLog :: ByteString -> IO ()
61 , pbLogDir :: FilePath
62 , pbJobs :: Int
63 , pbGlobalInstall :: Bool
64 -- ^ Register packages in the global database
65 , pbEnableTests :: Bool
66 , pbEnableHaddock :: Bool
67 , pbEnableLibProfiling :: Bool
68 , pbEnableExecDyn :: Bool
69 , pbVerbose :: Bool
70 , pbAllowNewer :: Bool
71 -- ^ Pass --allow-newer to cabal configure
72 }
74data PackageInfo = PackageInfo
75 { piPlan :: PackagePlan
76 , piName :: PackageName
77 , piResult :: TMVar Bool
78 }
80waitForDeps :: Map ExeName (Set PackageName)
81 -> Map PackageName PackageInfo
82 -> Set Component
83 -> BuildPlan
84 -> PackageInfo
85 -> IO a
86 -> IO a
87waitForDeps toolMap packageMap activeComps bp pi action = do
88 atomically $ do
89 mapM_ checkPackage $ Map.keys $ filterUnused $ sdPackages $ ppDesc $ piPlan pi
90 forM_ (Map.keys $ filterUnused $ sdTools $ ppDesc $ piPlan pi) $ \exe -> do
91 case lookup exe toolMap >>= fromNullable . map checkPackage . setToList of
92 Nothing
93 | isCoreExe exe -> return ()
94 -- https://github.com/jgm/zip-archive/issues/23
95 -- | otherwise -> throwSTM $ ToolMissing exe
96 | otherwise -> return ()
97 Just packages -> ofoldl1' (<|>) packages
98 action
99 where
100 filterUnused :: Ord key => Map key DepInfo -> Map key DepInfo
101 filterUnused =
102 mapFromList . filter (go . snd) . mapToList
103 where
104 go = not . null . intersection activeComps . diComponents
106 checkPackage package | package == piName pi = return ()
107 checkPackage package =
108 case lookup package packageMap of
109 Nothing
110 | isCore package -> return ()
111 | otherwise -> throwSTM $ DependencyMissing package
112 Just dep -> do
113 res <- readTMVar $ piResult dep
114 unless res $ throwSTM $ DependencyFailed package
116 isCore = (`member` siCorePackages (bpSystemInfo bp))
117 isCoreExe = (`member` siCoreExecutables (bpSystemInfo bp))
119withCounter :: TVar Int -> IO a -> IO a
120withCounter counter = bracket_
121 (atomically $ modifyTVar counter (+ 1))
122 (atomically $ modifyTVar counter (subtract 1))
124withTSem :: TSem -> IO a -> IO a
125withTSem sem = bracket_ (atomically $ waitTSem sem) (atomically $ signalTSem sem)
127-- | Returns @Nothing@ if installing to a global database
128pbDatabase :: PerformBuild -> Maybe FilePath
129pbDatabase pb
130 | pbGlobalInstall pb = Nothing
131 | otherwise = Just $ pbInstallDest pb </> "pkgdb"
133pbBinDir, pbLibDir, pbDataDir, pbDocDir :: PerformBuild -> FilePath
134pbBinDir pb = pbInstallDest pb </> "bin"
135pbLibDir pb = pbInstallDest pb </> "lib"
136pbDataDir pb = pbInstallDest pb </> "share"
137pbDocDir pb = pbInstallDest pb </> "doc"
139-- | Directory keeping previous result info
140pbPrevResDir :: PerformBuild -> FilePath
141pbPrevResDir pb = pbInstallDest pb </> "prevres"
143performBuild :: PerformBuild -> IO [Text]
144performBuild pb = do
145 cwd <- getWorkingDirectory
146 performBuild' pb
147 { pbInstallDest = cwd </> pbInstallDest pb
148 , pbLogDir = cwd </> pbLogDir pb
149 }
151performBuild' :: PerformBuild -> IO [Text]
152performBuild' pb@PerformBuild {..} = withBuildDir $ \builddir -> do
153 -- First make sure to fetch all of the dependencies... just in case Hackage
154 -- has an outage. Don't feel like wasting hours of CPU time.
155 pbLog $ encodeUtf8 "Pre-fetching all packages\n"
156 let toDownload = flip map (mapToList $ bpPackages pbPlan)
157 $ \(name, plan) -> unpack $ concat
158 [ display name
159 , "-"
160 , display $ ppVersion plan
161 ]
162 withCheckedProcess
163 (proc "cabal"
164 $ "fetch"
165 : "--no-dependencies"
166 : toDownload)
167 $ \ClosedStream Inherited Inherited -> return ()
169 let removeTree' fp = whenM (isDirectory fp) (removeTree fp)
170 removeTree' pbLogDir
172 forM_ (pbDatabase pb) $ \db ->
173 unlessM (isFile $ db </> "package.cache") $ do
174 createTree $ parent db
175 withCheckedProcess (proc "ghc-pkg" ["init", fpToString db])
176 $ \ClosedStream Inherited Inherited -> return ()
177 pbLog $ encodeUtf8 "Copying built-in Haddocks\n"
178 copyBuiltInHaddocks (pbDocDir pb)
180 sem <- atomically $ newTSem pbJobs
181 active <- newTVarIO (0 :: Int)
182 let toolMap = makeToolMap $ bpPackages pbPlan
183 packageMap <- fmap fold $ forM (mapToList $ bpPackages pbPlan)
184 $ \(name, plan) -> do
185 let piPlan = plan
186 piName = name
187 piResult <- newEmptyTMVarIO
188 return $ singletonMap name PackageInfo {..}
190 errsVar <- newTVarIO mempty
191 warningsVar <- newTVarIO id
192 mutex <- newMVar ()
193 env <- getEnvironment
194 haddockFiles <- newTVarIO mempty
196 registeredPackages <- setupPackageDatabase
197 (pbDatabase pb)
198 (pbDocDir pb)
199 pbLog
200 (ppVersion <$> bpPackages pbPlan)
201 (deletePreviousResults pb)
203 forM_ packageMap $ \pi -> void $ async $ singleBuild pb registeredPackages
204 SingleBuild
205 { sbSem = sem
206 , sbErrsVar = errsVar
207 , sbWarningsVar = warningsVar
208 , sbActive = active
209 , sbToolMap = toolMap
210 , sbPackageMap = packageMap
211 , sbBuildDir = builddir
212 , sbPackageInfo = pi
213 , sbRegisterMutex = mutex
214 , sbModifiedEnv = maybe
215 id
216 (\db -> (("HASKELL_PACKAGE_SANDBOX", fpToString db):))
217 (pbDatabase pb)
218 (filter allowedEnv $ map fixEnv env)
219 , sbHaddockFiles = haddockFiles
220 }
222 void $ tryAny $ atomically $ readTVar active >>= checkSTM . (== 0)
224 warnings <- ($ []) <$> readTVarIO warningsVar
225 errs <- readTVarIO errsVar
226 when (not $ null errs) $ throwM $ BuildException errs warnings
227 return warnings
228 where
229 withBuildDir f = withSystemTempDirectory "stackage-build" (f . fpFromString)
231 fixEnv (p, x)
232 -- Thank you Windows having case-insensitive environment variables...
233 | toUpper p == "PATH" = (p, fpToString (pbBinDir pb) ++ pathSep : x)
234 | otherwise = (p, x)
236 allowedEnv (k, _) = k `notMember` bannedEnvs
238 -- | Separate for the PATH environment variable
239 pathSep :: Char
240#ifdef mingw32_HOST_OS
241 pathSep = ';'
242#else
243 pathSep = ':'
244#endif
246-- | Environment variables we don't allow to be passed on to child processes.
247bannedEnvs :: Set String
248bannedEnvs = setFromList
249 [ "STACKAGE_AUTH_TOKEN"
250 ]
252data SingleBuild = SingleBuild
253 { sbSem :: TSem
254 , sbErrsVar :: TVar (Map PackageName BuildFailure)
255 , sbWarningsVar :: TVar ([Text] -> [Text])
256 , sbActive :: TVar Int
257 , sbToolMap :: Map ExeName (Set PackageName)
258 , sbPackageMap :: Map PackageName PackageInfo
259 , sbBuildDir :: FilePath
260 , sbPackageInfo :: PackageInfo
261 , sbRegisterMutex :: MVar ()
262 , sbModifiedEnv :: [(String, String)]
263 , sbHaddockFiles :: TVar (Map Text FilePath) -- ^ package-version, .haddock file
264 }
266singleBuild :: PerformBuild
267 -> Set PackageName -- ^ registered packages
268 -> SingleBuild -> IO ()
269singleBuild pb@PerformBuild {..} registeredPackages SingleBuild {..} =
270 withCounter sbActive
271 $ handle updateErrs
272 $ (`finally` void (atomically $ tryPutTMVar (piResult sbPackageInfo) False))
273 $ inner
274 where
275 libComps = setFromList [CompLibrary, CompExecutable]
276 testComps = insertSet CompTestSuite libComps
277 inner = do
278 let wfd comps =
279 waitForDeps sbToolMap sbPackageMap comps pbPlan sbPackageInfo
280 . withTSem sbSem
281 withUnpacked <- wfd libComps buildLibrary
283 wfd testComps (runTests withUnpacked)
285 pname = piName sbPackageInfo
286 pident = PackageIdentifier pname (ppVersion $ piPlan sbPackageInfo)
287 name = display pname
288 namever = concat
289 [ name
290 , "-"
291 , display $ ppVersion $ piPlan sbPackageInfo
292 ]
294 runIn wdir getOutH cmd args = do
295 outH <- getOutH
296 withCheckedProcess (cp outH) $ \ClosedStream UseProvidedHandle UseProvidedHandle ->
297 (return () :: IO ())
298 where
299 cp outH = (proc (unpack $ asText cmd) (map (unpack . asText) args))
300 { cwd = Just $ fpToString wdir
301 , std_out = UseHandle outH
302 , std_err = UseHandle outH
303 , env = Just sbModifiedEnv
304 }
305 runParent = runIn sbBuildDir
306 runChild = runIn childDir
307 childDir = sbBuildDir </> fpFromText namever
309 log' t = do
310 i <- readTVarIO sbActive
311 errs <- readTVarIO sbErrsVar
312 pbLog $ encodeUtf8 $ concat
313 [ t
314 , " (pending: "
315 , tshow i
316 , ", failures: "
317 , tshow $ length errs
318 , ")\n"
319 ]
320 libOut = pbLogDir </> fpFromText namever </> "build.out"
321 testOut = pbLogDir </> fpFromText namever </> "test.out"
322 testRunOut = pbLogDir </> fpFromText namever </> "test-run.out"
324 wf fp inner' = do
325 ref <- newIORef Nothing
326 let cleanup = do
327 mh <- readIORef ref
328 forM_ mh hClose
329 getH = do
330 mh <- readIORef ref
331 case mh of
332 Just h -> return h
333 Nothing -> mask_ $ do
334 createTree $ parent fp
335 h <- openBinaryFile (fpToString fp) WriteMode
336 writeIORef ref $ Just h
337 return h
339 inner' getH `finally` cleanup
341 configArgs = ($ []) $ execWriter $ do
342 when pbAllowNewer $ tell' "--allow-newer"
343 tell' "--package-db=clear"
344 tell' "--package-db=global"
345 forM_ (pbDatabase pb) $ \db -> tell' $ "--package-db=" ++ fpToText db
346 tell' $ "--libdir=" ++ fpToText (pbLibDir pb)
347 tell' $ "--bindir=" ++ fpToText (pbBinDir pb)
348 tell' $ "--datadir=" ++ fpToText (pbDataDir pb)
349 tell' $ "--docdir=" ++ fpToText (pbDocDir pb)
350 tell' $ "--flags=" ++ flags
351 when (pbEnableLibProfiling && pcEnableLibProfile) $
352 tell' "--enable-library-profiling"
353 when pbEnableExecDyn $ tell' "--enable-executable-dynamic"
354 where
355 tell' x = tell (x:)
357 flags :: Text
358 flags = unwords $ map go $ mapToList pcFlagOverrides
359 where
360 go (name', isOn) = concat
361 [ if isOn then "" else "-"
362 , unFlagName name'
363 ]
365 PackageConstraints {..} = ppConstraints $ piPlan sbPackageInfo
367 buildLibrary = wf libOut $ \getOutH -> do
368 let run a b = do when pbVerbose $ log' (unwords (a : b))
369 runChild getOutH a b
371 isUnpacked <- newIORef False
372 let withUnpacked inner = do
373 unlessM (readIORef isUnpacked) $ do
374 log' $ "Unpacking " ++ namever
375 runParent getOutH "cabal" ["unpack", namever]
376 writeIORef isUnpacked True
377 inner
379 isConfiged <- newIORef False
380 let withConfiged inner = withUnpacked $ do
381 unlessM (readIORef isConfiged) $ do
382 log' $ "Configuring " ++ namever
383 run "cabal" $ "configure" : configArgs
384 writeIORef isConfiged True
385 inner
387 prevBuildResult <- getPreviousResult pb Build pident
388 unless (prevBuildResult == PRSuccess) $ withConfiged $ do
389 assert (pname `notMember` registeredPackages) $ do
390 deletePreviousResults pb pident
392 log' $ "Building " ++ namever
393 run "cabal" ["build"]
395 log' $ "Copying/registering " ++ namever
396 run "cabal" ["copy"]
397 withMVar sbRegisterMutex $ const $
398 run "cabal" ["register"]
400 savePreviousResult pb Build pident True
402 -- Even if the tests later fail, we can allow other libraries to build
403 -- on top of our successful results
404 --
405 -- FIXME do we need to wait to do this until after Haddocks build?
406 -- otherwise, we could have a race condition and try to build a
407 -- dependency's haddocks before this finishes
408 atomically $ putTMVar (piResult sbPackageInfo) True
410 prevHaddockResult <- getPreviousResult pb Haddock pident
411 let needHaddock = pbEnableHaddock
412 && checkPrevResult prevHaddockResult pcHaddocks
413 && not (null $ sdModules $ ppDesc $ piPlan sbPackageInfo)
414 when needHaddock $ withConfiged $ do
415 log' $ "Haddocks " ++ namever
416 hfs <- readTVarIO sbHaddockFiles
417 let hfsOpts = flip map (mapToList hfs) $ \(pkgVer, hf) -> concat
418 [ "--haddock-options=--read-interface="
419 , "../"
420 , pkgVer
421 , "/,"
422 , fpToText hf
423 ]
424 args = "haddock"
425 : "--hyperlink-source"
426 : "--html"
427 : "--hoogle"
428 : "--html-location=../$pkg-$version/"
429 : hfsOpts
431 eres <- tryAny $ run "cabal" args
433 forM_ eres $ \() -> do
434 renameOrCopy
435 (childDir </> "dist" </> "doc" </> "html" </> fpFromText name)
436 (pbDocDir pb </> fpFromText namever)
438 enewPath <- tryIO
439 $ canonicalizePath
440 $ pbDocDir pb
441 </> fpFromText namever
442 </> fpFromText name <.> "haddock"
443 case enewPath of
444 Left e -> warn $ tshow e
445 Right newPath -> atomically
446 $ modifyTVar sbHaddockFiles
447 $ insertMap namever newPath
449 savePreviousResult pb Haddock pident $ either (const False) (const True) eres
450 case (eres, pcHaddocks) of
451 (Left e, ExpectSuccess) -> throwM e
452 (Right (), ExpectFailure) -> warn $ namever ++ ": unexpected Haddock success"
453 _ -> return ()
455 return withUnpacked
457 runTests withUnpacked = wf testOut $ \getOutH -> do
458 let run = runChild getOutH
460 prevTestResult <- getPreviousResult pb Test pident
461 let needTest = pbEnableTests
462 && checkPrevResult prevTestResult pcTests
463 when needTest $ withUnpacked $ do
464 log' $ "Test configure " ++ namever
465 run "cabal" $ "configure" : "--enable-tests" : configArgs
467 eres <- tryAny $ do
468 log' $ "Test build " ++ namever
469 run "cabal" ["build"]
471 log' $ "Test run " ++ namever
472 run "cabal" ["test", "--log=" ++ fpToText testRunOut]
474 savePreviousResult pb Test pident $ either (const False) (const True) eres
475 case (eres, pcTests) of
476 (Left e, ExpectSuccess) -> throwM e
477 (Right (), ExpectFailure) -> warn $ namever ++ ": unexpected test success"
478 _ -> return ()
480 warn t = atomically $ modifyTVar sbWarningsVar (. (t:))
482 updateErrs exc = do
483 log' $ concat
484 [ display (piName sbPackageInfo)
485 , ": "
486 , tshow exc
487 ]
488 atomically $ modifyTVar sbErrsVar $ insertMap (piName sbPackageInfo) exc'
489 where
490 exc' =
491 case fromException exc of
492 Just bf -> bf
493 Nothing -> BuildFailureException exc
495renameOrCopy :: FilePath -> FilePath -> IO ()
496renameOrCopy src dest = rename src dest `catchIO` \_ -> copyDir src dest
498copyDir :: FilePath -> FilePath -> IO ()
499copyDir src dest =
500 runResourceT $ sourceDirectoryDeep False src $$ mapM_C go
501 where
502 src' = src </> ""
503 go fp = forM_ (F.stripPrefix src' fp) $ \suffix -> do
504 let dest' = dest </> suffix
505 liftIO $ createTree $ parent dest'
506 sourceFile fp $$ (sinkFile dest' :: Sink ByteString (ResourceT IO) ())
508copyBuiltInHaddocks :: FilePath -> IO ()
509copyBuiltInHaddocks docdir = do
510 mghc <- findExecutable "ghc"
511 case mghc of
512 Nothing -> error "GHC not found on PATH"
513 Just ghc -> do
514 src <- canonicalizePath
515 (parent (fpFromString ghc) </> "../share/doc/ghc/html/libraries")
516 copyDir src docdir
518------------- Previous results
520-- | The previous actions that can be run
521data ResultType = Build | Haddock | Test
522 deriving (Show, Enum, Eq, Ord, Bounded, Read)
524-- | The result generated on a previous run
525data PrevResult = PRNoResult | PRSuccess | PRFailure
526 deriving (Show, Enum, Eq, Ord, Bounded, Read)
528-- | Check if we should rerun based on a PrevResult and the expected status
529checkPrevResult :: PrevResult -> TestState -> Bool
530checkPrevResult _ Don'tBuild = False
531checkPrevResult PRNoResult _ = True
532checkPrevResult PRSuccess _ = False
533checkPrevResult PRFailure ExpectSuccess = True
534checkPrevResult PRFailure _ = False
536withPRPath :: PerformBuild -> ResultType -> PackageIdentifier -> (FilePath -> IO a) -> IO a
537withPRPath pb rt ident inner = do
538 createTree $ parent fp
539 inner fp
540 where
541 fp = pbPrevResDir pb </> fpFromString (show rt) </> fpFromText (display ident)
543successBS, failureBS :: ByteString
544successBS = "success"
545failureBS = "failure"
547getPreviousResult :: PerformBuild -> ResultType -> PackageIdentifier -> IO PrevResult
548getPreviousResult w x y = withPRPath w x y $ \fp -> do
549 eres <- tryIO $ readFile fp
550 return $ case eres of
551 Right bs
552 | bs == successBS -> PRSuccess
553 | bs == failureBS -> PRFailure
554 _ -> PRNoResult
556savePreviousResult :: PerformBuild -> ResultType -> PackageIdentifier -> Bool -> IO ()
557savePreviousResult pb rt ident res =
558 withPRPath pb rt ident $ \fp -> writeFile fp $
559 if res then successBS else failureBS
561deletePreviousResults :: PerformBuild -> PackageIdentifier -> IO ()
562deletePreviousResults pb name =
563 forM_ [minBound..maxBound] $ \rt ->
564 withPRPath pb rt name $ \fp ->
565 void $ tryIO $ removeFile fp