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