git.iko.soy/stackage
on 2aa6ecc help sign in
stackage/Stackage/PerformBuild.hs
551 lines 20 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 withBinaryFile)
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 outH cmd args =
295 withCheckedProcess cp $ \ClosedStream UseProvidedHandle UseProvidedHandle ->
296 (return () :: IO ())
297 where
298 cp = (proc (unpack $ asText cmd) (map (unpack . asText) args))
299 { cwd = Just $ fpToString wdir
300 , std_out = UseHandle outH
301 , std_err = UseHandle outH
302 , env = Just sbModifiedEnv
303 }
304 runParent = runIn sbBuildDir
305 runChild = runIn childDir
306 childDir = sbBuildDir </> fpFromText namever
308 log' t = do
309 i <- readTVarIO sbActive
310 errs <- readTVarIO sbErrsVar
311 pbLog $ encodeUtf8 $ concat
312 [ t
313 , " (pending: "
314 , tshow i
315 , ", failures: "
316 , tshow $ length errs
317 , ")\n"
318 ]
319 libOut = pbLogDir </> fpFromText namever </> "build.out"
320 testOut = pbLogDir </> fpFromText namever </> "test.out"
321 testRunOut = pbLogDir </> fpFromText namever </> "test-run.out"
323 wf fp inner' = do
324 createTree $ parent fp
325 withBinaryFile (fpToString fp) WriteMode inner'
327 configArgs = ($ []) $ execWriter $ do
328 when pbAllowNewer $ tell' "--allow-newer"
329 tell' "--package-db=clear"
330 tell' "--package-db=global"
331 forM_ (pbDatabase pb) $ \db -> tell' $ "--package-db=" ++ fpToText db
332 tell' $ "--libdir=" ++ fpToText (pbLibDir pb)
333 tell' $ "--bindir=" ++ fpToText (pbBinDir pb)
334 tell' $ "--datadir=" ++ fpToText (pbDataDir pb)
335 tell' $ "--docdir=" ++ fpToText (pbDocDir pb)
336 tell' $ "--flags=" ++ flags
337 when (pbEnableLibProfiling && pcEnableLibProfile) $
338 tell' "--enable-library-profiling"
339 when pbEnableExecDyn $ tell' "--enable-executable-dynamic"
340 where
341 tell' x = tell (x:)
343 flags :: Text
344 flags = unwords $ map go $ mapToList pcFlagOverrides
345 where
346 go (name', isOn) = concat
347 [ if isOn then "" else "-"
348 , unFlagName name'
349 ]
351 PackageConstraints {..} = ppConstraints $ piPlan sbPackageInfo
353 buildLibrary = wf libOut $ \outH -> do
354 let run a b = do when pbVerbose $ log' (unwords (a : b))
355 runChild outH a b
357 isUnpacked <- newIORef False
358 let withUnpacked inner = do
359 unlessM (readIORef isUnpacked) $ do
360 log' $ "Unpacking " ++ namever
361 runParent outH "cabal" ["unpack", namever]
362 writeIORef isUnpacked True
363 inner
365 isConfiged <- newIORef False
366 let withConfiged inner = withUnpacked $ do
367 unlessM (readIORef isConfiged) $ do
368 log' $ "Configuring " ++ namever
369 run "cabal" $ "configure" : configArgs
370 writeIORef isConfiged True
371 inner
373 prevBuildResult <- getPreviousResult pb Build pident
374 unless (prevBuildResult == PRSuccess) $ withConfiged $ do
375 assert (pname `notMember` registeredPackages) $ do
376 deletePreviousResults pb pident
378 log' $ "Building " ++ namever
379 run "cabal" ["build"]
381 log' $ "Copying/registering " ++ namever
382 run "cabal" ["copy"]
383 withMVar sbRegisterMutex $ const $
384 run "cabal" ["register"]
386 savePreviousResult pb Build pident True
388 -- Even if the tests later fail, we can allow other libraries to build
389 -- on top of our successful results
390 --
391 -- FIXME do we need to wait to do this until after Haddocks build?
392 -- otherwise, we could have a race condition and try to build a
393 -- dependency's haddocks before this finishes
394 atomically $ putTMVar (piResult sbPackageInfo) True
396 prevHaddockResult <- getPreviousResult pb Haddock pident
397 let needHaddock = pbEnableHaddock
398 && checkPrevResult prevHaddockResult pcHaddocks
399 && not (null $ sdModules $ ppDesc $ piPlan sbPackageInfo)
400 when needHaddock $ withConfiged $ do
401 log' $ "Haddocks " ++ namever
402 hfs <- readTVarIO sbHaddockFiles
403 let hfsOpts = flip map (mapToList hfs) $ \(pkgVer, hf) -> concat
404 [ "--haddock-options=--read-interface="
405 , "../"
406 , pkgVer
407 , "/,"
408 , fpToText hf
409 ]
410 args = "haddock"
411 : "--hyperlink-source"
412 : "--html"
413 : "--hoogle"
414 : "--html-location=../$pkg-$version/"
415 : hfsOpts
417 eres <- tryAny $ run "cabal" args
419 forM_ eres $ \() -> do
420 renameOrCopy
421 (childDir </> "dist" </> "doc" </> "html" </> fpFromText name)
422 (pbDocDir pb </> fpFromText namever)
424 enewPath <- tryIO
425 $ canonicalizePath
426 $ pbDocDir pb
427 </> fpFromText namever
428 </> fpFromText name <.> "haddock"
429 case enewPath of
430 Left e -> warn $ tshow e
431 Right newPath -> atomically
432 $ modifyTVar sbHaddockFiles
433 $ insertMap namever newPath
435 savePreviousResult pb Haddock pident $ either (const False) (const True) eres
436 case (eres, pcHaddocks) of
437 (Left e, ExpectSuccess) -> throwM e
438 (Right (), ExpectFailure) -> warn $ namever ++ ": unexpected Haddock success"
439 _ -> return ()
441 return withUnpacked
443 runTests withUnpacked = wf testOut $ \outH -> do
444 let run = runChild outH
446 prevTestResult <- getPreviousResult pb Test pident
447 let needTest = pbEnableTests
448 && checkPrevResult prevTestResult pcTests
449 when needTest $ withUnpacked $ do
450 log' $ "Test configure " ++ namever
451 run "cabal" $ "configure" : "--enable-tests" : configArgs
453 eres <- tryAny $ do
454 log' $ "Test build " ++ namever
455 run "cabal" ["build"]
457 log' $ "Test run " ++ namever
458 run "cabal" ["test", "--log=" ++ fpToText testRunOut]
460 savePreviousResult pb Test pident $ either (const False) (const True) eres
461 case (eres, pcTests) of
462 (Left e, ExpectSuccess) -> throwM e
463 (Right (), ExpectFailure) -> warn $ namever ++ ": unexpected test success"
464 _ -> return ()
466 warn t = atomically $ modifyTVar sbWarningsVar (. (t:))
468 updateErrs exc = do
469 log' $ concat
470 [ display (piName sbPackageInfo)
471 , ": "
472 , tshow exc
473 ]
474 atomically $ modifyTVar sbErrsVar $ insertMap (piName sbPackageInfo) exc'
475 where
476 exc' =
477 case fromException exc of
478 Just bf -> bf
479 Nothing -> BuildFailureException exc
481renameOrCopy :: FilePath -> FilePath -> IO ()
482renameOrCopy src dest = rename src dest `catchIO` \_ -> copyDir src dest
484copyDir :: FilePath -> FilePath -> IO ()
485copyDir src dest =
486 runResourceT $ sourceDirectoryDeep False src $$ mapM_C go
487 where
488 src' = src </> ""
489 go fp = forM_ (F.stripPrefix src' fp) $ \suffix -> do
490 let dest' = dest </> suffix
491 liftIO $ createTree $ parent dest'
492 sourceFile fp $$ (sinkFile dest' :: Sink ByteString (ResourceT IO) ())
494copyBuiltInHaddocks :: FilePath -> IO ()
495copyBuiltInHaddocks docdir = do
496 mghc <- findExecutable "ghc"
497 case mghc of
498 Nothing -> error "GHC not found on PATH"
499 Just ghc -> do
500 src <- canonicalizePath
501 (parent (fpFromString ghc) </> "../share/doc/ghc/html/libraries")
502 copyDir src docdir
504------------- Previous results
506-- | The previous actions that can be run
507data ResultType = Build | Haddock | Test
508 deriving (Show, Enum, Eq, Ord, Bounded, Read)
510-- | The result generated on a previous run
511data PrevResult = PRNoResult | PRSuccess | PRFailure
512 deriving (Show, Enum, Eq, Ord, Bounded, Read)
514-- | Check if we should rerun based on a PrevResult and the expected status
515checkPrevResult :: PrevResult -> TestState -> Bool
516checkPrevResult _ Don'tBuild = False
517checkPrevResult PRNoResult _ = True
518checkPrevResult PRSuccess _ = False
519checkPrevResult PRFailure ExpectSuccess = True
520checkPrevResult PRFailure _ = False
522withPRPath :: PerformBuild -> ResultType -> PackageIdentifier -> (FilePath -> IO a) -> IO a
523withPRPath pb rt ident inner = do
524 createTree $ parent fp
525 inner fp
526 where
527 fp = pbPrevResDir pb </> fpFromString (show rt) </> fpFromText (display ident)
529successBS, failureBS :: ByteString
530successBS = "success"
531failureBS = "failure"
533getPreviousResult :: PerformBuild -> ResultType -> PackageIdentifier -> IO PrevResult
534getPreviousResult w x y = withPRPath w x y $ \fp -> do
535 eres <- tryIO $ readFile fp
536 return $ case eres of
537 Right bs
538 | bs == successBS -> PRSuccess
539 | bs == failureBS -> PRFailure
540 _ -> PRNoResult
542savePreviousResult :: PerformBuild -> ResultType -> PackageIdentifier -> Bool -> IO ()
543savePreviousResult pb rt ident res =
544 withPRPath pb rt ident $ \fp -> writeFile fp $
545 if res then successBS else failureBS
547deletePreviousResults :: PerformBuild -> PackageIdentifier -> IO ()
548deletePreviousResults pb name =
549 forM_ [minBound..maxBound] $ \rt ->
550 withPRPath pb rt name $ \fp ->
551 void $ tryIO $ removeFile fp