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