git.iko.soy/stackage
on eddc392 help sign in
stackage/Stackage/PerformBuild.hs
450 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 | otherwise -> throwSTM $ ToolMissing exe
92 Just packages -> ofoldl1' (<|>) packages
93 action
94 where
95 filterUnused :: Ord key => Map key DepInfo -> Map key DepInfo
96 filterUnused =
97 mapFromList . filter (go . snd) . mapToList
98 where
99 go = not . null . intersection activeComps . diComponents
101 checkPackage package | package == piName pi = return ()
102 checkPackage package =
103 case lookup package packageMap of
104 Nothing
105 | isCore package -> return ()
106 | otherwise -> throwSTM $ DependencyMissing package
107 Just dep -> do
108 res <- readTMVar $ piResult dep
109 unless res $ throwSTM $ DependencyFailed package
111 isCore = (`member` siCorePackages (bpSystemInfo bp))
112 isCoreExe = (`member` siCoreExecutables (bpSystemInfo bp))
114withCounter :: TVar Int -> IO a -> IO a
115withCounter counter = bracket_
116 (atomically $ modifyTVar counter (+ 1))
117 (atomically $ modifyTVar counter (subtract 1))
119withTSem :: TSem -> IO a -> IO a
120withTSem sem = bracket_ (atomically $ waitTSem sem) (atomically $ signalTSem sem)
122-- | Returns @Nothing@ if installing to a global database
123pbDatabase :: PerformBuild -> Maybe FilePath
124pbDatabase pb
125 | pbGlobalInstall pb = Nothing
126 | otherwise = Just $ pbInstallDest pb </> "pkgdb"
128pbBinDir, pbLibDir, pbDataDir, pbDocDir :: PerformBuild -> FilePath
129pbBinDir pb = pbInstallDest pb </> "bin"
130pbLibDir pb = pbInstallDest pb </> "lib"
131pbDataDir pb = pbInstallDest pb </> "share"
132pbDocDir pb = pbInstallDest pb </> "doc"
134performBuild :: PerformBuild -> IO [Text]
135performBuild pb = do
136 cwd <- getWorkingDirectory
137 performBuild' pb
138 { pbInstallDest = cwd </> pbInstallDest pb
139 , pbLogDir = cwd </> pbLogDir pb
140 }
142performBuild' :: PerformBuild -> IO [Text]
143performBuild' pb@PerformBuild {..} = withBuildDir $ \builddir -> do
144 -- First make sure to fetch all of the dependencies... just in case Hackage
145 -- has an outage. Don't feel like wasting hours of CPU time.
146 pbLog $ encodeUtf8 "Pre-fetching all packages\n"
147 let toDownload = flip map (mapToList $ bpPackages pbPlan)
148 $ \(name, plan) -> unpack $ concat
149 [ display name
150 , "-"
151 , display $ ppVersion plan
152 ]
153 withCheckedProcess
154 (proc "cabal"
155 $ "fetch"
156 : "--no-dependencies"
157 : toDownload)
158 $ \ClosedStream Inherited Inherited -> return ()
160 let removeTree' fp = whenM (isDirectory fp) (removeTree fp)
161 mapM_ removeTree' [pbInstallDest, pbLogDir]
163 forM_ (pbDatabase pb) $ \db -> do
164 createTree $ parent db
165 withCheckedProcess (proc "ghc-pkg" ["init", fpToString db])
166 $ \ClosedStream Inherited Inherited -> return ()
167 pbLog $ encodeUtf8 "Copying built-in Haddocks\n"
168 copyBuiltInHaddocks (pbDocDir pb)
170 sem <- atomically $ newTSem pbJobs
171 active <- newTVarIO (0 :: Int)
172 let toolMap = makeToolMap $ bpPackages pbPlan
173 packageMap <- fmap fold $ forM (mapToList $ bpPackages pbPlan)
174 $ \(name, plan) -> do
175 let piPlan = plan
176 piName = name
177 piResult <- newEmptyTMVarIO
178 return $ singletonMap name PackageInfo {..}
180 errsVar <- newTVarIO mempty
181 warningsVar <- newTVarIO id
182 mutex <- newMVar ()
183 env <- getEnvironment
184 haddockFiles <- newTVarIO mempty
186 forM_ packageMap $ \pi -> void $ async $ singleBuild pb SingleBuild
187 { sbSem = sem
188 , sbErrsVar = errsVar
189 , sbWarningsVar = warningsVar
190 , sbActive = active
191 , sbToolMap = toolMap
192 , sbPackageMap = packageMap
193 , sbBuildDir = builddir
194 , sbPackageInfo = pi
195 , sbRegisterMutex = mutex
196 , sbModifiedEnv = maybe
197 id
198 (\db -> (("HASKELL_PACKAGE_SANDBOX", fpToString db):))
199 (pbDatabase pb)
200 (filter allowedEnv $ map fixEnv env)
201 , sbHaddockFiles = haddockFiles
202 }
204 void $ tryAny $ atomically $ readTVar active >>= checkSTM . (== 0)
206 warnings <- ($ []) <$> readTVarIO warningsVar
207 errs <- readTVarIO errsVar
208 when (not $ null errs) $ throwM $ BuildException errs warnings
209 return warnings
210 where
211 withBuildDir f = withSystemTempDirectory "stackage-build" (f . fpFromString)
213 fixEnv (p, x)
214 -- Thank you Windows having case-insensitive environment variables...
215 | toUpper p == "PATH" = (p, fpToString (pbBinDir pb) ++ pathSep : x)
216 | otherwise = (p, x)
218 allowedEnv (k, _) = k `notMember` bannedEnvs
220 -- | Separate for the PATH environment variable
221 pathSep :: Char
222#ifdef mingw32_HOST_OS
223 pathSep = ';'
224#else
225 pathSep = ':'
226#endif
228-- | Environment variables we don't allow to be passed on to child processes.
229bannedEnvs :: Set String
230bannedEnvs = setFromList
231 [ "STACKAGE_AUTH_TOKEN"
232 ]
234data SingleBuild = SingleBuild
235 { sbSem :: TSem
236 , sbErrsVar :: TVar (Map PackageName BuildFailure)
237 , sbWarningsVar :: TVar ([Text] -> [Text])
238 , sbActive :: TVar Int
239 , sbToolMap :: Map ExeName (Set PackageName)
240 , sbPackageMap :: Map PackageName PackageInfo
241 , sbBuildDir :: FilePath
242 , sbPackageInfo :: PackageInfo
243 , sbRegisterMutex :: MVar ()
244 , sbModifiedEnv :: [(String, String)]
245 , sbHaddockFiles :: TVar (Map Text FilePath) -- ^ package-version, .haddock file
246 }
248singleBuild :: PerformBuild -> SingleBuild -> IO ()
249singleBuild pb@PerformBuild {..} SingleBuild {..} =
250 withCounter sbActive
251 $ handle updateErrs
252 $ (`finally` void (atomically $ tryPutTMVar (piResult sbPackageInfo) False))
253 $ inner
254 where
255 libComps = setFromList [CompLibrary, CompExecutable]
256 testComps = insertSet CompTestSuite libComps
257 inner = do
258 let wfd comps =
259 waitForDeps sbToolMap sbPackageMap comps pbPlan sbPackageInfo
260 . withTSem sbSem
261 wfd libComps buildLibrary
263 wfd testComps runTests
265 name = display $ piName sbPackageInfo
266 namever = concat
267 [ name
268 , "-"
269 , display $ ppVersion $ piPlan sbPackageInfo
270 ]
272 runIn wdir outH cmd args =
273 withCheckedProcess cp $ \ClosedStream UseProvidedHandle UseProvidedHandle ->
274 (return () :: IO ())
275 where
276 cp = (proc (unpack $ asText cmd) (map (unpack . asText) args))
277 { cwd = Just $ fpToString wdir
278 , std_out = UseHandle outH
279 , std_err = UseHandle outH
280 , env = Just sbModifiedEnv
281 }
282 runParent = runIn sbBuildDir
283 runChild = runIn childDir
284 childDir = sbBuildDir </> fpFromText namever
286 log' t = do
287 i <- readTVarIO sbActive
288 errs <- readTVarIO sbErrsVar
289 pbLog $ encodeUtf8 $ concat
290 [ t
291 , " (pending: "
292 , tshow i
293 , ", failures: "
294 , tshow $ length errs
295 , ")\n"
296 ]
297 libOut = pbLogDir </> fpFromText namever </> "build.out"
298 testOut = pbLogDir </> fpFromText namever </> "test.out"
299 testRunOut = pbLogDir </> fpFromText namever </> "test-run.out"
301 wf fp inner' = do
302 createTree $ parent fp
303 withBinaryFile (fpToString fp) WriteMode inner'
305 configArgs = ($ []) $ execWriter $ do
306 when pbAllowNewer $ tell' "--allow-newer"
307 tell' "--package-db=clear"
308 tell' "--package-db=global"
309 forM_ (pbDatabase pb) $ \db -> tell' $ "--package-db=" ++ fpToText db
310 tell' $ "--libdir=" ++ fpToText (pbLibDir pb)
311 tell' $ "--bindir=" ++ fpToText (pbBinDir pb)
312 tell' $ "--datadir=" ++ fpToText (pbDataDir pb)
313 tell' $ "--docdir=" ++ fpToText (pbDocDir pb)
314 tell' $ "--flags=" ++ flags
315 when (pbEnableLibProfiling && pcEnableLibProfile) $
316 tell' "--enable-library-profiling"
317 where
318 tell' x = tell (x:)
320 flags :: Text
321 flags = unwords $ map go $ mapToList pcFlagOverrides
322 where
323 go (name', isOn) = concat
324 [ if isOn then "" else "-"
325 , unFlagName name'
326 ]
328 PackageConstraints {..} = ppConstraints $ piPlan sbPackageInfo
330 buildLibrary = wf libOut $ \outH -> do
331 let run a b = do when pbVerbose $ log' (unwords (a : b))
332 runChild outH a b
333 log' $ "Unpacking " ++ namever
334 runParent outH "cabal" ["unpack", namever]
336 log' $ "Configuring " ++ namever
337 run "cabal" $ "configure" : configArgs
339 log' $ "Building " ++ namever
340 run "cabal" ["build"]
342 log' $ "Copying/registering " ++ namever
343 run "cabal" ["copy"]
344 withMVar sbRegisterMutex $ const $
345 run "cabal" ["register"]
347 -- Even if the tests later fail, we can allow other libraries to build
348 -- on top of our successful results
349 --
350 -- FIXME do we need to wait to do this until after Haddocks build?
351 -- otherwise, we could have a race condition and try to build a
352 -- dependency's haddocks before this finishes
353 atomically $ putTMVar (piResult sbPackageInfo) True
355 when (pcHaddocks /= Don'tBuild && not (null $ sdModules $ ppDesc $ piPlan sbPackageInfo)) $ do
356 log' $ "Haddocks " ++ namever
357 hfs <- readTVarIO sbHaddockFiles
358 let hfsOpts = flip map (mapToList hfs) $ \(pkgVer, hf) -> concat
359 [ "--haddock-options=--read-interface="
360 , "../"
361 , pkgVer
362 , "/,"
363 , fpToText hf
364 ]
365 args = "haddock"
366 : "--hyperlink-source"
367 : "--html"
368 : "--hoogle"
369 : "--html-location=../$pkg-$version/"
370 : hfsOpts
372 eres <- tryAny $ run "cabal" args
374 forM_ eres $ \() -> do
375 renameOrCopy
376 (childDir </> "dist" </> "doc" </> "html" </> fpFromText name)
377 (pbDocDir pb </> fpFromText namever)
379 enewPath <- tryIO
380 $ canonicalizePath
381 $ pbDocDir pb
382 </> fpFromText namever
383 </> fpFromText name <.> "haddock"
384 case enewPath of
385 Left e -> warn $ tshow e
386 Right newPath -> atomically
387 $ modifyTVar sbHaddockFiles
388 $ insertMap namever newPath
390 case (eres, pcHaddocks) of
391 (Left e, ExpectSuccess) -> throwM e
392 (Right (), ExpectFailure) -> warn $ namever ++ ": unexpected Haddock success"
393 _ -> return ()
395 runTests = wf testOut $ \outH -> do
396 let run = runChild outH
398 when (pbEnableTests && pcTests /= Don'tBuild) $ do
399 log' $ "Test configure " ++ namever
400 run "cabal" $ "configure" : "--enable-tests" : configArgs
402 eres <- tryAny $ do
403 log' $ "Test build " ++ namever
404 run "cabal" ["build"]
406 log' $ "Test run " ++ namever
407 run "cabal" ["test", "--log=" ++ fpToText testRunOut]
409 case (eres, pcTests) of
410 (Left e, ExpectSuccess) -> throwM e
411 (Right (), ExpectFailure) -> warn $ namever ++ ": unexpected test success"
412 _ -> return ()
414 warn t = atomically $ modifyTVar sbWarningsVar (. (t:))
416 updateErrs exc = do
417 log' $ concat
418 [ display (piName sbPackageInfo)
419 , ": "
420 , tshow exc
421 ]
422 atomically $ modifyTVar sbErrsVar $ insertMap (piName sbPackageInfo) exc'
423 where
424 exc' =
425 case fromException exc of
426 Just bf -> bf
427 Nothing -> BuildFailureException exc
429renameOrCopy :: FilePath -> FilePath -> IO ()
430renameOrCopy src dest = rename src dest `catchIO` \_ -> copyDir src dest
432copyDir :: FilePath -> FilePath -> IO ()
433copyDir src dest =
434 runResourceT $ sourceDirectoryDeep False src $$ mapM_C go
435 where
436 src' = src </> ""
437 go fp = forM_ (F.stripPrefix src' fp) $ \suffix -> do
438 let dest' = dest </> suffix
439 liftIO $ createTree $ parent dest'
440 sourceFile fp $$ (sinkFile dest' :: Sink ByteString (ResourceT IO) ())
442copyBuiltInHaddocks :: FilePath -> IO ()
443copyBuiltInHaddocks docdir = do
444 mghc <- findExecutable "ghc"
445 case mghc of
446 Nothing -> error "GHC not found on PATH"
447 Just ghc -> do
448 src <- canonicalizePath
449 (parent (fpFromString ghc) </> "../share/doc/ghc/html/libraries")
450 copyDir src docdir