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