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