git.iko.soy/stackage
on 4761d55 help sign in
stackage/Stackage/PerformBuild.hs
452 lines 16 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)
23import Filesystem.Path (parent)
24import qualified Filesystem.Path as F
25import Stackage.BuildConstraints
26import Stackage.BuildPlan
27import Stackage.PackageDescription
28import Stackage.Prelude hiding (pi)
29import System.Directory (findExecutable)
30import System.Environment (getEnvironment)
31import System.IO (IOMode (WriteMode),
32 withBinaryFile)
33import System.IO.Temp (withSystemTempDirectory)
35data BuildException = BuildException (Map PackageName BuildFailure) [Text]
36 deriving Typeable
37instance Exception BuildException
38instance Show BuildException where
39 show (BuildException m warnings) =
40 unlines $ map go (mapToList m) ++ map unpack warnings
41 where
42 go (PackageName name, bf) = concat
43 [ name
44 , ": "
45 , show bf
46 ]
48data BuildFailure = DependencyFailed PackageName
49 | DependencyMissing PackageName
50 | ToolMissing ExeName
51 | NotImplemented
52 | BuildFailureException SomeException
53 deriving (Show, Typeable)
54instance Exception BuildFailure
56data PerformBuild = PerformBuild
57 { pbPlan :: BuildPlan
58 , pbInstallDest :: FilePath
59 , pbLog :: ByteString -> IO ()
60 , pbLogDir :: FilePath
61 , pbJobs :: Int
62 , pbGlobalInstall :: Bool
63 -- ^ Register packages in the global database
64 , pbEnableTests :: Bool
65 , pbEnableLibProfiling :: Bool
66 , pbVerbose :: Bool
67 , pbAllowNewer :: Bool
68 -- ^ Pass --allow-newer to cabal configure
69 }
71data PackageInfo = PackageInfo
72 { piPlan :: PackagePlan
73 , piName :: PackageName
74 , piResult :: TMVar Bool
75 }
77waitForDeps :: Map ExeName (Set PackageName)
78 -> Map PackageName PackageInfo
79 -> Set Component
80 -> BuildPlan
81 -> PackageInfo
82 -> IO a
83 -> IO a
84waitForDeps toolMap packageMap activeComps bp pi action = do
85 atomically $ do
86 mapM_ checkPackage $ Map.keys $ filterUnused $ sdPackages $ ppDesc $ piPlan pi
87 forM_ (Map.keys $ filterUnused $ sdTools $ ppDesc $ piPlan pi) $ \exe -> do
88 case lookup exe toolMap >>= fromNullable . map checkPackage . setToList of
89 Nothing
90 | isCoreExe exe -> return ()
91 -- https://github.com/jgm/zip-archive/issues/23
92 -- | otherwise -> throwSTM $ ToolMissing exe
93 | otherwise -> return ()
94 Just packages -> ofoldl1' (<|>) packages
95 action
96 where
97 filterUnused :: Ord key => Map key DepInfo -> Map key DepInfo
98 filterUnused =
99 mapFromList . filter (go . snd) . mapToList
100 where
101 go = not . null . intersection activeComps . diComponents
103 checkPackage package | package == piName pi = return ()
104 checkPackage package =
105 case lookup package packageMap of
106 Nothing
107 | isCore package -> return ()
108 | otherwise -> throwSTM $ DependencyMissing package
109 Just dep -> do
110 res <- readTMVar $ piResult dep
111 unless res $ throwSTM $ DependencyFailed package
113 isCore = (`member` siCorePackages (bpSystemInfo bp))
114 isCoreExe = (`member` siCoreExecutables (bpSystemInfo bp))
116withCounter :: TVar Int -> IO a -> IO a
117withCounter counter = bracket_
118 (atomically $ modifyTVar counter (+ 1))
119 (atomically $ modifyTVar counter (subtract 1))
121withTSem :: TSem -> IO a -> IO a
122withTSem sem = bracket_ (atomically $ waitTSem sem) (atomically $ signalTSem sem)
124-- | Returns @Nothing@ if installing to a global database
125pbDatabase :: PerformBuild -> Maybe FilePath
126pbDatabase pb
127 | pbGlobalInstall pb = Nothing
128 | otherwise = Just $ pbInstallDest pb </> "pkgdb"
130pbBinDir, pbLibDir, pbDataDir, pbDocDir :: PerformBuild -> FilePath
131pbBinDir pb = pbInstallDest pb </> "bin"
132pbLibDir pb = pbInstallDest pb </> "lib"
133pbDataDir pb = pbInstallDest pb </> "share"
134pbDocDir pb = pbInstallDest pb </> "doc"
136performBuild :: PerformBuild -> IO [Text]
137performBuild pb = do
138 cwd <- getWorkingDirectory
139 performBuild' pb
140 { pbInstallDest = cwd </> pbInstallDest pb
141 , pbLogDir = cwd </> pbLogDir pb
142 }
144performBuild' :: PerformBuild -> IO [Text]
145performBuild' pb@PerformBuild {..} = withBuildDir $ \builddir -> do
146 -- First make sure to fetch all of the dependencies... just in case Hackage
147 -- has an outage. Don't feel like wasting hours of CPU time.
148 pbLog $ encodeUtf8 "Pre-fetching all packages\n"
149 let toDownload = flip map (mapToList $ bpPackages pbPlan)
150 $ \(name, plan) -> unpack $ concat
151 [ display name
152 , "-"
153 , display $ ppVersion plan
154 ]
155 withCheckedProcess
156 (proc "cabal"
157 $ "fetch"
158 : "--no-dependencies"
159 : toDownload)
160 $ \ClosedStream Inherited Inherited -> return ()
162 let removeTree' fp = whenM (isDirectory fp) (removeTree fp)
163 mapM_ removeTree' [pbInstallDest, pbLogDir]
165 forM_ (pbDatabase pb) $ \db -> do
166 createTree $ parent db
167 withCheckedProcess (proc "ghc-pkg" ["init", fpToString db])
168 $ \ClosedStream Inherited Inherited -> return ()
169 pbLog $ encodeUtf8 "Copying built-in Haddocks\n"
170 copyBuiltInHaddocks (pbDocDir pb)
172 sem <- atomically $ newTSem pbJobs
173 active <- newTVarIO (0 :: Int)
174 let toolMap = makeToolMap $ bpPackages pbPlan
175 packageMap <- fmap fold $ forM (mapToList $ bpPackages pbPlan)
176 $ \(name, plan) -> do
177 let piPlan = plan
178 piName = name
179 piResult <- newEmptyTMVarIO
180 return $ singletonMap name PackageInfo {..}
182 errsVar <- newTVarIO mempty
183 warningsVar <- newTVarIO id
184 mutex <- newMVar ()
185 env <- getEnvironment
186 haddockFiles <- newTVarIO mempty
188 forM_ packageMap $ \pi -> void $ async $ singleBuild pb SingleBuild
189 { sbSem = sem
190 , sbErrsVar = errsVar
191 , sbWarningsVar = warningsVar
192 , sbActive = active
193 , sbToolMap = toolMap
194 , sbPackageMap = packageMap
195 , sbBuildDir = builddir
196 , sbPackageInfo = pi
197 , sbRegisterMutex = mutex
198 , sbModifiedEnv = maybe
199 id
200 (\db -> (("HASKELL_PACKAGE_SANDBOX", fpToString db):))
201 (pbDatabase pb)
202 (filter allowedEnv $ map fixEnv env)
203 , sbHaddockFiles = haddockFiles
204 }
206 void $ tryAny $ atomically $ readTVar active >>= checkSTM . (== 0)
208 warnings <- ($ []) <$> readTVarIO warningsVar
209 errs <- readTVarIO errsVar
210 when (not $ null errs) $ throwM $ BuildException errs warnings
211 return warnings
212 where
213 withBuildDir f = withSystemTempDirectory "stackage-build" (f . fpFromString)
215 fixEnv (p, x)
216 -- Thank you Windows having case-insensitive environment variables...
217 | toUpper p == "PATH" = (p, fpToString (pbBinDir pb) ++ pathSep : x)
218 | otherwise = (p, x)
220 allowedEnv (k, _) = k `notMember` bannedEnvs
222 -- | Separate for the PATH environment variable
223 pathSep :: Char
224#ifdef mingw32_HOST_OS
225 pathSep = ';'
226#else
227 pathSep = ':'
228#endif
230-- | Environment variables we don't allow to be passed on to child processes.
231bannedEnvs :: Set String
232bannedEnvs = setFromList
233 [ "STACKAGE_AUTH_TOKEN"
234 ]
236data SingleBuild = SingleBuild
237 { sbSem :: TSem
238 , sbErrsVar :: TVar (Map PackageName BuildFailure)
239 , sbWarningsVar :: TVar ([Text] -> [Text])
240 , sbActive :: TVar Int
241 , sbToolMap :: Map ExeName (Set PackageName)
242 , sbPackageMap :: Map PackageName PackageInfo
243 , sbBuildDir :: FilePath
244 , sbPackageInfo :: PackageInfo
245 , sbRegisterMutex :: MVar ()
246 , sbModifiedEnv :: [(String, String)]
247 , sbHaddockFiles :: TVar (Map Text FilePath) -- ^ package-version, .haddock file
248 }
250singleBuild :: PerformBuild -> SingleBuild -> IO ()
251singleBuild pb@PerformBuild {..} SingleBuild {..} =
252 withCounter sbActive
253 $ handle updateErrs
254 $ (`finally` void (atomically $ tryPutTMVar (piResult sbPackageInfo) False))
255 $ inner
256 where
257 libComps = setFromList [CompLibrary, CompExecutable]
258 testComps = insertSet CompTestSuite libComps
259 inner = do
260 let wfd comps =
261 waitForDeps sbToolMap sbPackageMap comps pbPlan sbPackageInfo
262 . withTSem sbSem
263 wfd libComps buildLibrary
265 wfd testComps runTests
267 name = display $ piName sbPackageInfo
268 namever = concat
269 [ name
270 , "-"
271 , display $ ppVersion $ piPlan sbPackageInfo
272 ]
274 runIn wdir outH cmd args =
275 withCheckedProcess cp $ \ClosedStream UseProvidedHandle UseProvidedHandle ->
276 (return () :: IO ())
277 where
278 cp = (proc (unpack $ asText cmd) (map (unpack . asText) args))
279 { cwd = Just $ fpToString wdir
280 , std_out = UseHandle outH
281 , std_err = UseHandle outH
282 , env = Just sbModifiedEnv
283 }
284 runParent = runIn sbBuildDir
285 runChild = runIn childDir
286 childDir = sbBuildDir </> fpFromText namever
288 log' t = do
289 i <- readTVarIO sbActive
290 errs <- readTVarIO sbErrsVar
291 pbLog $ encodeUtf8 $ concat
292 [ t
293 , " (pending: "
294 , tshow i
295 , ", failures: "
296 , tshow $ length errs
297 , ")\n"
298 ]
299 libOut = pbLogDir </> fpFromText namever </> "build.out"
300 testOut = pbLogDir </> fpFromText namever </> "test.out"
301 testRunOut = pbLogDir </> fpFromText namever </> "test-run.out"
303 wf fp inner' = do
304 createTree $ parent fp
305 withBinaryFile (fpToString fp) WriteMode inner'
307 configArgs = ($ []) $ execWriter $ do
308 when pbAllowNewer $ tell' "--allow-newer"
309 tell' "--package-db=clear"
310 tell' "--package-db=global"
311 forM_ (pbDatabase pb) $ \db -> tell' $ "--package-db=" ++ fpToText db
312 tell' $ "--libdir=" ++ fpToText (pbLibDir pb)
313 tell' $ "--bindir=" ++ fpToText (pbBinDir pb)
314 tell' $ "--datadir=" ++ fpToText (pbDataDir pb)
315 tell' $ "--docdir=" ++ fpToText (pbDocDir pb)
316 tell' $ "--flags=" ++ flags
317 when (pbEnableLibProfiling && pcEnableLibProfile) $
318 tell' "--enable-library-profiling"
319 where
320 tell' x = tell (x:)
322 flags :: Text
323 flags = unwords $ map go $ mapToList pcFlagOverrides
324 where
325 go (name', isOn) = concat
326 [ if isOn then "" else "-"
327 , unFlagName name'
328 ]
330 PackageConstraints {..} = ppConstraints $ piPlan sbPackageInfo
332 buildLibrary = wf libOut $ \outH -> do
333 let run a b = do when pbVerbose $ log' (unwords (a : b))
334 runChild outH a b
335 log' $ "Unpacking " ++ namever
336 runParent outH "cabal" ["unpack", namever]
338 log' $ "Configuring " ++ namever
339 run "cabal" $ "configure" : configArgs
341 log' $ "Building " ++ namever
342 run "cabal" ["build"]
344 log' $ "Copying/registering " ++ namever
345 run "cabal" ["copy"]
346 withMVar sbRegisterMutex $ const $
347 run "cabal" ["register"]
349 -- Even if the tests later fail, we can allow other libraries to build
350 -- on top of our successful results
351 --
352 -- FIXME do we need to wait to do this until after Haddocks build?
353 -- otherwise, we could have a race condition and try to build a
354 -- dependency's haddocks before this finishes
355 atomically $ putTMVar (piResult sbPackageInfo) True
357 when (pcHaddocks /= Don'tBuild && not (null $ sdModules $ ppDesc $ piPlan sbPackageInfo)) $ do
358 log' $ "Haddocks " ++ namever
359 hfs <- readTVarIO sbHaddockFiles
360 let hfsOpts = flip map (mapToList hfs) $ \(pkgVer, hf) -> concat
361 [ "--haddock-options=--read-interface="
362 , "../"
363 , pkgVer
364 , "/,"
365 , fpToText hf
366 ]
367 args = "haddock"
368 : "--hyperlink-source"
369 : "--html"
370 : "--hoogle"
371 : "--html-location=../$pkg-$version/"
372 : hfsOpts
374 eres <- tryAny $ run "cabal" args
376 forM_ eres $ \() -> do
377 renameOrCopy
378 (childDir </> "dist" </> "doc" </> "html" </> fpFromText name)
379 (pbDocDir pb </> fpFromText namever)
381 enewPath <- tryIO
382 $ canonicalizePath
383 $ pbDocDir pb
384 </> fpFromText namever
385 </> fpFromText name <.> "haddock"
386 case enewPath of
387 Left e -> warn $ tshow e
388 Right newPath -> atomically
389 $ modifyTVar sbHaddockFiles
390 $ insertMap namever newPath
392 case (eres, pcHaddocks) of
393 (Left e, ExpectSuccess) -> throwM e
394 (Right (), ExpectFailure) -> warn $ namever ++ ": unexpected Haddock success"
395 _ -> return ()
397 runTests = wf testOut $ \outH -> do
398 let run = runChild outH
400 when (pbEnableTests && pcTests /= Don'tBuild) $ do
401 log' $ "Test configure " ++ namever
402 run "cabal" $ "configure" : "--enable-tests" : configArgs
404 eres <- tryAny $ do
405 log' $ "Test build " ++ namever
406 run "cabal" ["build"]
408 log' $ "Test run " ++ namever
409 run "cabal" ["test", "--log=" ++ fpToText testRunOut]
411 case (eres, pcTests) of
412 (Left e, ExpectSuccess) -> throwM e
413 (Right (), ExpectFailure) -> warn $ namever ++ ": unexpected test success"
414 _ -> return ()
416 warn t = atomically $ modifyTVar sbWarningsVar (. (t:))
418 updateErrs exc = do
419 log' $ concat
420 [ display (piName sbPackageInfo)
421 , ": "
422 , tshow exc
423 ]
424 atomically $ modifyTVar sbErrsVar $ insertMap (piName sbPackageInfo) exc'
425 where
426 exc' =
427 case fromException exc of
428 Just bf -> bf
429 Nothing -> BuildFailureException exc
431renameOrCopy :: FilePath -> FilePath -> IO ()
432renameOrCopy src dest = rename src dest `catchIO` \_ -> copyDir src dest
434copyDir :: FilePath -> FilePath -> IO ()
435copyDir src dest =
436 runResourceT $ sourceDirectoryDeep False src $$ mapM_C go
437 where
438 src' = src </> ""
439 go fp = forM_ (F.stripPrefix src' fp) $ \suffix -> do
440 let dest' = dest </> suffix
441 liftIO $ createTree $ parent dest'
442 sourceFile fp $$ (sinkFile dest' :: Sink ByteString (ResourceT IO) ())
444copyBuiltInHaddocks :: FilePath -> IO ()
445copyBuiltInHaddocks docdir = do
446 mghc <- findExecutable "ghc"
447 case mghc of
448 Nothing -> error "GHC not found on PATH"
449 Just ghc -> do
450 src <- canonicalizePath
451 (parent (fpFromString ghc) </> "../share/doc/ghc/html/libraries")
452 copyDir src docdir