git.iko.soy/stackage
on 4e156eb help sign in
stackage/Stackage/PerformBuild.hs
442 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 (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 -- | Separate for the PATH environment variable
219 pathSep :: Char
220#ifdef mingw32_HOST_OS
221 pathSep = ';'
222#else
223 pathSep = ':'
224#endif
226data SingleBuild = SingleBuild
227 { sbSem :: TSem
228 , sbErrsVar :: TVar (Map PackageName BuildFailure)
229 , sbWarningsVar :: TVar ([Text] -> [Text])
230 , sbActive :: TVar Int
231 , sbToolMap :: Map ExeName (Set PackageName)
232 , sbPackageMap :: Map PackageName PackageInfo
233 , sbBuildDir :: FilePath
234 , sbPackageInfo :: PackageInfo
235 , sbRegisterMutex :: MVar ()
236 , sbModifiedEnv :: [(String, String)]
237 , sbHaddockFiles :: TVar (Map Text FilePath) -- ^ package-version, .haddock file
238 }
240singleBuild :: PerformBuild -> SingleBuild -> IO ()
241singleBuild pb@PerformBuild {..} SingleBuild {..} =
242 withCounter sbActive
243 $ handle updateErrs
244 $ (`finally` void (atomically $ tryPutTMVar (piResult sbPackageInfo) False))
245 $ inner
246 where
247 libComps = setFromList [CompLibrary, CompExecutable]
248 testComps = insertSet CompTestSuite libComps
249 inner = do
250 let wfd comps =
251 waitForDeps sbToolMap sbPackageMap comps pbPlan sbPackageInfo
252 . withTSem sbSem
253 wfd libComps buildLibrary
255 wfd testComps runTests
257 name = display $ piName sbPackageInfo
258 namever = concat
259 [ name
260 , "-"
261 , display $ ppVersion $ piPlan sbPackageInfo
262 ]
264 runIn wdir outH cmd args =
265 withCheckedProcess cp $ \ClosedStream UseProvidedHandle UseProvidedHandle ->
266 (return () :: IO ())
267 where
268 cp = (proc (unpack $ asText cmd) (map (unpack . asText) args))
269 { cwd = Just $ fpToString wdir
270 , std_out = UseHandle outH
271 , std_err = UseHandle outH
272 , env = Just sbModifiedEnv
273 }
274 runParent = runIn sbBuildDir
275 runChild = runIn childDir
276 childDir = sbBuildDir </> fpFromText namever
278 log' t = do
279 i <- readTVarIO sbActive
280 errs <- readTVarIO sbErrsVar
281 pbLog $ encodeUtf8 $ concat
282 [ t
283 , " (pending: "
284 , tshow i
285 , ", failures: "
286 , tshow $ length errs
287 , ")\n"
288 ]
289 libOut = pbLogDir </> fpFromText namever </> "build.out"
290 testOut = pbLogDir </> fpFromText namever </> "test.out"
291 testRunOut = pbLogDir </> fpFromText namever </> "test-run.out"
293 wf fp inner' = do
294 createTree $ parent fp
295 withBinaryFile (fpToString fp) WriteMode inner'
297 configArgs = ($ []) $ execWriter $ do
298 when pbAllowNewer $ tell' "--allow-newer"
299 tell' "--package-db=clear"
300 tell' "--package-db=global"
301 forM_ (pbDatabase pb) $ \db -> tell' $ "--package-db=" ++ fpToText db
302 tell' $ "--libdir=" ++ fpToText (pbLibDir pb)
303 tell' $ "--bindir=" ++ fpToText (pbBinDir pb)
304 tell' $ "--datadir=" ++ fpToText (pbDataDir pb)
305 tell' $ "--docdir=" ++ fpToText (pbDocDir pb)
306 tell' $ "--flags=" ++ flags
307 when (pbEnableLibProfiling && pcEnableLibProfile) $
308 tell' "--enable-library-profiling"
309 where
310 tell' x = tell (x:)
312 flags :: Text
313 flags = unwords $ map go $ mapToList pcFlagOverrides
314 where
315 go (name', isOn) = concat
316 [ if isOn then "" else "-"
317 , unFlagName name'
318 ]
320 PackageConstraints {..} = ppConstraints $ piPlan sbPackageInfo
322 buildLibrary = wf libOut $ \outH -> do
323 let run a b = do when pbVerbose $ log' (unwords (a : b))
324 runChild outH a b
325 log' $ "Unpacking " ++ namever
326 runParent outH "cabal" ["unpack", namever]
328 log' $ "Configuring " ++ namever
329 run "cabal" $ "configure" : configArgs
331 log' $ "Building " ++ namever
332 run "cabal" ["build"]
334 log' $ "Copying/registering " ++ namever
335 run "cabal" ["copy"]
336 withMVar sbRegisterMutex $ const $
337 run "cabal" ["register"]
339 -- Even if the tests later fail, we can allow other libraries to build
340 -- on top of our successful results
341 --
342 -- FIXME do we need to wait to do this until after Haddocks build?
343 -- otherwise, we could have a race condition and try to build a
344 -- dependency's haddocks before this finishes
345 atomically $ putTMVar (piResult sbPackageInfo) True
347 when (pcHaddocks /= Don'tBuild && not (null $ sdModules $ ppDesc $ piPlan sbPackageInfo)) $ do
348 log' $ "Haddocks " ++ namever
349 hfs <- readTVarIO sbHaddockFiles
350 let hfsOpts = flip map (mapToList hfs) $ \(pkgVer, hf) -> concat
351 [ "--haddock-options=--read-interface="
352 , "../"
353 , pkgVer
354 , "/,"
355 , fpToText hf
356 ]
357 args = "haddock"
358 : "--hyperlink-source"
359 : "--html"
360 : "--hoogle"
361 : "--html-location=../$pkg-$version/"
362 : hfsOpts
364 eres <- tryAny $ run "cabal" args
366 forM_ eres $ \() -> do
367 renameOrCopy
368 (childDir </> "dist" </> "doc" </> "html" </> fpFromText name)
369 (pbDocDir pb </> fpFromText namever)
371 enewPath <- tryIO
372 $ canonicalizePath
373 $ pbDocDir pb
374 </> fpFromText namever
375 </> fpFromText name <.> "haddock"
376 case enewPath of
377 Left e -> warn $ tshow e
378 Right newPath -> atomically
379 $ modifyTVar sbHaddockFiles
380 $ insertMap namever newPath
382 case (eres, pcHaddocks) of
383 (Left e, ExpectSuccess) -> throwM e
384 (Right (), ExpectFailure) -> warn $ namever ++ ": unexpected Haddock success"
385 _ -> return ()
387 runTests = wf testOut $ \outH -> do
388 let run = runChild outH
390 when (pbEnableTests && pcTests /= Don'tBuild) $ do
391 log' $ "Test configure " ++ namever
392 run "cabal" $ "configure" : "--enable-tests" : configArgs
394 eres <- tryAny $ do
395 log' $ "Test build " ++ namever
396 run "cabal" ["build"]
398 log' $ "Test run " ++ namever
399 run "cabal" ["test", "--log=" ++ fpToText testRunOut]
401 case (eres, pcTests) of
402 (Left e, ExpectSuccess) -> throwM e
403 (Right (), ExpectFailure) -> warn $ namever ++ ": unexpected test success"
404 _ -> return ()
406 warn t = atomically $ modifyTVar sbWarningsVar (. (t:))
408 updateErrs exc = do
409 log' $ concat
410 [ display (piName sbPackageInfo)
411 , ": "
412 , tshow exc
413 ]
414 atomically $ modifyTVar sbErrsVar $ insertMap (piName sbPackageInfo) exc'
415 where
416 exc' =
417 case fromException exc of
418 Just bf -> bf
419 Nothing -> BuildFailureException exc
421renameOrCopy :: FilePath -> FilePath -> IO ()
422renameOrCopy src dest = rename src dest `catchIO` \_ -> copyDir src dest
424copyDir :: FilePath -> FilePath -> IO ()
425copyDir src dest =
426 runResourceT $ sourceDirectoryDeep False src $$ mapM_C go
427 where
428 src' = src </> ""
429 go fp = forM_ (F.stripPrefix src' fp) $ \suffix -> do
430 let dest' = dest </> suffix
431 liftIO $ createTree $ parent dest'
432 sourceFile fp $$ (sinkFile dest' :: Sink ByteString (ResourceT IO) ())
434copyBuiltInHaddocks :: FilePath -> IO ()
435copyBuiltInHaddocks docdir = do
436 mghc <- findExecutable "ghc"
437 case mghc of
438 Nothing -> error "GHC not found on PATH"
439 Just ghc -> do
440 src <- canonicalizePath
441 (parent (fpFromString ghc) </> "../share/doc/ghc/html/libraries")
442 copyDir src docdir