git.iko.soy/stackage
on 1623304 help sign in
stackage/Stackage/PerformBuild.hs
417 lines 15 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 let removeTree' fp = whenM (isDirectory fp) (removeTree fp)
140 mapM_ removeTree' [pbInstallDest, pbLogDir]
142 forM_ (pbDatabase pb) $ \db -> do
143 createTree $ parent db
144 withCheckedProcess (proc "ghc-pkg" ["init", fpToString db])
145 $ \ClosedStream Inherited Inherited -> return ()
146 pbLog $ encodeUtf8 "Copying built-in Haddocks\n"
147 copyBuiltInHaddocks (pbDocDir pb)
149 sem <- atomically $ newTSem pbJobs
150 active <- newTVarIO (0 :: Int)
151 let toolMap = makeToolMap $ bpPackages pbPlan
152 packageMap <- fmap fold $ forM (mapToList $ bpPackages pbPlan)
153 $ \(name, plan) -> do
154 let piPlan = plan
155 piName = name
156 piResult <- newEmptyTMVarIO
157 return $ singletonMap name PackageInfo {..}
159 errsVar <- newTVarIO mempty
160 warningsVar <- newTVarIO id
161 mutex <- newMVar ()
162 env <- getEnvironment
163 haddockFiles <- newTVarIO mempty
165 forM_ packageMap $ \pi -> void $ async $ singleBuild pb SingleBuild
166 { sbSem = sem
167 , sbErrsVar = errsVar
168 , sbWarningsVar = warningsVar
169 , sbActive = active
170 , sbToolMap = toolMap
171 , sbPackageMap = packageMap
172 , sbBuildDir = builddir
173 , sbPackageInfo = pi
174 , sbRegisterMutex = mutex
175 , sbModifiedEnv = maybe
176 id
177 (\db -> (("HASKELL_PACKAGE_SANDBOX", fpToString db):))
178 (pbDatabase pb)
179 (map fixEnv env)
180 , sbHaddockFiles = haddockFiles
181 }
183 void $ tryAny $ atomically $ readTVar active >>= checkSTM . (== 0)
185 warnings <- ($ []) <$> readTVarIO warningsVar
186 errs <- readTVarIO errsVar
187 when (not $ null errs) $ throwM $ BuildException errs warnings
188 return warnings
189 where
190 withBuildDir f = withSystemTempDirectory "stackage-build" (f . fpFromString)
192 fixEnv (p, x)
193 -- Thank you Windows having case-insensitive environment variables...
194 | toUpper p == "PATH" = (p, fpToString (pbBinDir pb) ++ pathSep : x)
195 | otherwise = (p, x)
197 -- | Separate for the PATH environment variable
198 pathSep :: Char
199#ifdef mingw32_HOST_OS
200 pathSep = ';'
201#else
202 pathSep = ':'
203#endif
205data SingleBuild = SingleBuild
206 { sbSem :: TSem
207 , sbErrsVar :: TVar (Map PackageName BuildFailure)
208 , sbWarningsVar :: TVar ([Text] -> [Text])
209 , sbActive :: TVar Int
210 , sbToolMap :: Map ExeName (Set PackageName)
211 , sbPackageMap :: Map PackageName PackageInfo
212 , sbBuildDir :: FilePath
213 , sbPackageInfo :: PackageInfo
214 , sbRegisterMutex :: MVar ()
215 , sbModifiedEnv :: [(String, String)]
216 , sbHaddockFiles :: TVar (Map Text FilePath) -- ^ package-version, .haddock file
217 }
219singleBuild :: PerformBuild -> SingleBuild -> IO ()
220singleBuild pb@PerformBuild {..} SingleBuild {..} =
221 withCounter sbActive
222 $ handle updateErrs
223 $ (`finally` void (atomically $ tryPutTMVar (piResult sbPackageInfo) False))
224 $ inner
225 where
226 libComps = setFromList [CompLibrary, CompExecutable]
227 testComps = insertSet CompTestSuite libComps
228 inner = do
229 let wfd comps =
230 waitForDeps sbToolMap sbPackageMap comps pbPlan sbPackageInfo
231 . withTSem sbSem
232 wfd libComps buildLibrary
234 wfd testComps runTests
236 name = display $ piName sbPackageInfo
237 namever = concat
238 [ name
239 , "-"
240 , display $ ppVersion $ piPlan sbPackageInfo
241 ]
243 runIn wdir outH cmd args =
244 withCheckedProcess cp $ \ClosedStream UseProvidedHandle UseProvidedHandle ->
245 (return () :: IO ())
246 where
247 cp = (proc (unpack $ asText cmd) (map (unpack . asText) args))
248 { cwd = Just $ fpToString wdir
249 , std_out = UseHandle outH
250 , std_err = UseHandle outH
251 , env = Just sbModifiedEnv
252 }
253 runParent = runIn sbBuildDir
254 runChild = runIn childDir
255 childDir = sbBuildDir </> fpFromText namever
257 log' t = do
258 i <- readTVarIO sbActive
259 errs <- readTVarIO sbErrsVar
260 pbLog $ encodeUtf8 $ concat
261 [ t
262 , " (pending: "
263 , tshow i
264 , ", failures: "
265 , tshow $ length errs
266 , ")\n"
267 ]
268 libOut = pbLogDir </> fpFromText namever </> "build.out"
269 testOut = pbLogDir </> fpFromText namever </> "test.out"
270 testRunOut = pbLogDir </> fpFromText namever </> "test-run.out"
272 wf fp inner' = do
273 createTree $ parent fp
274 withBinaryFile (fpToString fp) WriteMode inner'
276 configArgs = ($ []) $ execWriter $ do
277 tell' "--package-db=clear"
278 tell' "--package-db=global"
279 forM_ (pbDatabase pb) $ \db -> tell' $ "--package-db=" ++ fpToText db
280 tell' $ "--libdir=" ++ fpToText (pbLibDir pb)
281 tell' $ "--bindir=" ++ fpToText (pbBinDir pb)
282 tell' $ "--datadir=" ++ fpToText (pbDataDir pb)
283 tell' $ "--docdir=" ++ fpToText (pbDocDir pb)
284 tell' $ "--flags=" ++ flags
285 where
286 tell' x = tell (x:)
288 flags :: Text
289 flags = unwords $ map go $ mapToList pcFlagOverrides
290 where
291 go (name', isOn) = concat
292 [ if isOn then "" else "-"
293 , unFlagName name'
294 ]
296 PackageConstraints {..} = ppConstraints $ piPlan sbPackageInfo
298 buildLibrary = wf libOut $ \outH -> do
299 let run = runChild outH
300 log' $ "Unpacking " ++ namever
301 runParent outH "cabal" ["unpack", namever]
303 log' $ "Configuring " ++ namever
304 run "cabal" $ "configure" : configArgs
306 log' $ "Building " ++ namever
307 run "cabal" ["build"]
309 log' $ "Copying/registering " ++ namever
310 run "cabal" ["copy"]
311 withMVar sbRegisterMutex $ const $
312 run "cabal" ["register"]
314 -- Even if the tests later fail, we can allow other libraries to build
315 -- on top of our successful results
316 --
317 -- FIXME do we need to wait to do this until after Haddocks build?
318 -- otherwise, we could have a race condition and try to build a
319 -- dependency's haddocks before this finishes
320 atomically $ putTMVar (piResult sbPackageInfo) True
322 when (pcHaddocks /= Don'tBuild && not (null $ sdModules $ ppDesc $ piPlan sbPackageInfo)) $ do
323 log' $ "Haddocks " ++ namever
324 hfs <- readTVarIO sbHaddockFiles
325 let hfsOpts = flip map (mapToList hfs) $ \(pkgVer, hf) -> concat
326 [ "--haddock-options=--read-interface="
327 , "../"
328 , pkgVer
329 , "/,"
330 , fpToText hf
331 ]
332 args = "haddock"
333 : "--hyperlink-source"
334 : "--html"
335 : "--hoogle"
336 : "--html-location=../$pkg-$version/"
337 : hfsOpts
339 eres <- tryAny $ run "cabal" args
341 forM_ eres $ \() -> do
342 renameOrCopy
343 (childDir </> "dist" </> "doc" </> "html" </> fpFromText name)
344 (pbDocDir pb </> fpFromText namever)
346 enewPath <- tryIO
347 $ canonicalizePath
348 $ pbDocDir pb
349 </> fpFromText namever
350 </> fpFromText name <.> "haddock"
351 case enewPath of
352 Left e -> warn $ tshow e
353 Right newPath -> atomically
354 $ modifyTVar sbHaddockFiles
355 $ insertMap namever newPath
357 case (eres, pcHaddocks) of
358 (Left e, ExpectSuccess) -> throwM e
359 (Right (), ExpectFailure) -> warn $ namever ++ ": unexpected Haddock success"
360 _ -> return ()
362 runTests = wf testOut $ \outH -> do
363 let run = runChild outH
365 when (pcTests /= Don'tBuild) $ do
366 log' $ "Test configure " ++ namever
367 run "cabal" $ "configure" : "--enable-tests" : configArgs
369 eres <- tryAny $ do
370 log' $ "Test build " ++ namever
371 run "cabal" ["build"]
373 log' $ "Test run " ++ namever
374 run "cabal" ["test", "--log=" ++ fpToText testRunOut]
376 case (eres, pcTests) of
377 (Left e, ExpectSuccess) -> throwM e
378 (Right (), ExpectFailure) -> warn $ namever ++ ": unexpected test success"
379 _ -> return ()
381 warn t = atomically $ modifyTVar sbWarningsVar (. (t:))
383 updateErrs exc = do
384 log' $ concat
385 [ display (piName sbPackageInfo)
386 , ": "
387 , tshow exc
388 ]
389 atomically $ modifyTVar sbErrsVar $ insertMap (piName sbPackageInfo) exc'
390 where
391 exc' =
392 case fromException exc of
393 Just bf -> bf
394 Nothing -> BuildFailureException exc
396renameOrCopy :: FilePath -> FilePath -> IO ()
397renameOrCopy src dest = rename src dest `catchIO` \_ -> copyDir src dest
399copyDir :: FilePath -> FilePath -> IO ()
400copyDir src dest =
401 runResourceT $ sourceDirectoryDeep False src $$ mapM_C go
402 where
403 src' = src </> ""
404 go fp = forM_ (F.stripPrefix src' fp) $ \suffix -> do
405 let dest' = dest </> suffix
406 liftIO $ createTree $ parent dest'
407 sourceFile fp $$ (sinkFile dest' :: Sink ByteString (ResourceT IO) ())
409copyBuiltInHaddocks :: FilePath -> IO ()
410copyBuiltInHaddocks docdir = do
411 mghc <- findExecutable "ghc"
412 case mghc of
413 Nothing -> error "GHC not found on PATH"
414 Just ghc -> do
415 src <- canonicalizePath
416 (parent (fpFromString ghc) </> "../share/doc/ghc/html/libraries")
417 copyDir src docdir