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