git.iko.soy/stackage
on 771e196 help sign in
stackage/Stackage/PerformBuild.hs
408 lines 14 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 RecordWildCards #-}
6{-# LANGUAGE NoImplicitPrelude #-}
7{-# LANGUAGE OverloadedStrings #-}
8module Stackage.PerformBuild
9 ( performBuild
10 , PerformBuild (..)
11 , BuildException (..)
12 , pbDocDir
13 ) where
15import Stackage.BuildConstraints
16import Stackage.PackageDescription
17import Stackage.BuildPlan
18import Stackage.Prelude hiding (pi)
19import qualified Data.Map as Map
20import Control.Concurrent.STM.TSem
21import Control.Monad.Writer.Strict (execWriter, tell)
22import Data.NonNull (fromNullable)
23import Control.Concurrent.Async (async)
24import System.IO.Temp (withSystemTempDirectory)
25import Filesystem (createTree, removeTree, isDirectory, rename, canonicalizePath, getWorkingDirectory)
26import System.IO (withBinaryFile, IOMode (WriteMode))
27import Filesystem.Path (parent)
28import qualified Filesystem.Path as F
29import System.Environment (getEnvironment)
30import System.Directory (findExecutable)
32data BuildException = BuildException (Map PackageName BuildFailure) [Text]
33 deriving Typeable
34instance Exception BuildException
35instance Show BuildException where
36 show (BuildException m warnings) =
37 unlines $ map go (mapToList m) ++ map unpack warnings
38 where
39 go (PackageName name, bf) = concat
40 [ name
41 , ": "
42 , show bf
43 ]
45data BuildFailure = DependencyFailed PackageName
46 | DependencyMissing PackageName
47 | ToolMissing ExeName
48 | NotImplemented
49 | BuildFailureException SomeException
50 deriving (Show, Typeable)
51instance Exception BuildFailure
53data PerformBuild = PerformBuild
54 { pbPlan :: BuildPlan
55 , pbInstallDest :: FilePath
56 , pbLog :: ByteString -> IO ()
57 , pbLogDir :: FilePath
58 , pbJobs :: Int
59 , pbGlobalInstall :: Bool
60 -- ^ Register packages in the global database
61 }
63data PackageInfo = PackageInfo
64 { piPlan :: PackagePlan
65 , piName :: PackageName
66 , piResult :: TMVar Bool
67 }
69waitForDeps :: Map ExeName (Set PackageName)
70 -> Map PackageName PackageInfo
71 -> Set Component
72 -> BuildPlan
73 -> PackageInfo
74 -> IO a
75 -> IO a
76waitForDeps toolMap packageMap activeComps bp pi action = do
77 atomically $ do
78 mapM_ checkPackage $ Map.keys $ filterUnused $ sdPackages $ ppDesc $ piPlan pi
79 forM_ (Map.keys $ filterUnused $ sdTools $ ppDesc $ piPlan pi) $ \exe -> do
80 case lookup exe toolMap >>= fromNullable . map checkPackage . setToList of
81 Nothing
82 | isCoreExe exe -> return ()
83 | otherwise -> throwSTM $ ToolMissing exe
84 Just packages -> ofoldl1' (<|>) packages
85 action
86 where
87 filterUnused :: Ord key => Map key DepInfo -> Map key DepInfo
88 filterUnused =
89 mapFromList . filter (go . snd) . mapToList
90 where
91 go = not . null . intersection activeComps . diComponents
93 checkPackage package | package == piName pi = return ()
94 checkPackage package =
95 case lookup package packageMap of
96 Nothing
97 | isCore package -> return ()
98 | otherwise -> throwSTM $ DependencyMissing package
99 Just dep -> do
100 res <- readTMVar $ piResult dep
101 unless res $ throwSTM $ DependencyFailed package
103 isCore = (`member` siCorePackages (bpSystemInfo bp))
104 isCoreExe = (`member` siCoreExecutables (bpSystemInfo bp))
106withCounter counter = bracket_
107 (atomically $ modifyTVar counter (+ 1))
108 (atomically $ modifyTVar counter (subtract 1))
110withTSem sem = bracket_ (atomically $ waitTSem sem) (atomically $ signalTSem sem)
112pbDatabase pb
113 | pbGlobalInstall pb = Nothing
114 | otherwise = Just $ pbInstallDest pb </> "pkgdb"
115pbBinDir pb = pbInstallDest pb </> "bin"
116pbLibDir pb = pbInstallDest pb </> "lib"
117pbDataDir pb = pbInstallDest pb </> "share"
118pbDocDir pb = pbInstallDest pb </> "doc"
120performBuild :: PerformBuild -> IO [Text]
121performBuild pb = do
122 cwd <- getWorkingDirectory
123 performBuild' pb
124 { pbInstallDest = cwd </> pbInstallDest pb
125 , pbLogDir = cwd </> pbLogDir pb
126 }
128performBuild' :: PerformBuild -> IO [Text]
129performBuild' pb@PerformBuild {..} = withBuildDir $ \builddir -> do
130 let removeTree' fp = whenM (isDirectory fp) (removeTree fp)
131 mapM_ removeTree' [pbInstallDest, pbLogDir]
133 forM_ (pbDatabase pb) $ \db -> do
134 createTree $ parent db
135 withCheckedProcess (proc "ghc-pkg" ["init", fpToString db])
136 $ \ClosedStream Inherited Inherited -> return ()
137 pbLog $ encodeUtf8 "Copying built-in Haddocks\n"
138 copyBuiltInHaddocks (pbDocDir pb)
140 sem <- atomically $ newTSem pbJobs
141 active <- newTVarIO (0 :: Int)
142 let toolMap = makeToolMap $ bpPackages pbPlan
143 packageMap <- fmap fold $ forM (mapToList $ bpPackages pbPlan)
144 $ \(name, plan) -> do
145 let piPlan = plan
146 piName = name
147 piResult <- newEmptyTMVarIO
148 return $ singletonMap name PackageInfo {..}
150 errsVar <- newTVarIO mempty
151 warningsVar <- newTVarIO id
152 mutex <- newMVar ()
153 env <- getEnvironment
154 haddockFiles <- newTVarIO mempty
156 forM_ packageMap $ \pi -> void $ async $ singleBuild pb SingleBuild
157 { sbSem = sem
158 , sbErrsVar = errsVar
159 , sbWarningsVar = warningsVar
160 , sbActive = active
161 , sbToolMap = toolMap
162 , sbPackageMap = packageMap
163 , sbBuildDir = builddir
164 , sbPackageInfo = pi
165 , sbRegisterMutex = mutex
166 , sbModifiedEnv = maybe
167 id
168 (\db -> (("HASKELL_PACKAGE_SANDBOX", fpToString db):))
169 (pbDatabase pb)
170 (map fixEnv env)
171 , sbHaddockFiles = haddockFiles
172 }
174 void $ tryAny $ atomically $ readTVar active >>= checkSTM . (== 0)
176 warnings <- ($ []) <$> readTVarIO warningsVar
177 errs <- readTVarIO errsVar
178 when (not $ null errs) $ throwM $ BuildException errs warnings
179 return warnings
180 where
181 withBuildDir f = withSystemTempDirectory "stackage-build" (f . fpFromString)
183 fixEnv (p, x)
184 -- Thank you Windows having case-insensitive environment variables...
185 | toUpper p == "PATH" = (p, fpToString (pbBinDir pb) ++ pathSep : x)
186 | otherwise = (p, x)
188 -- | Separate for the PATH environment variable
189 pathSep :: Char
190#ifdef mingw32_HOST_OS
191 pathSep = ';'
192#else
193 pathSep = ':'
194#endif
196data SingleBuild = SingleBuild
197 { sbSem :: TSem
198 , sbErrsVar :: TVar (Map PackageName BuildFailure)
199 , sbWarningsVar :: TVar ([Text] -> [Text])
200 , sbActive :: TVar Int
201 , sbToolMap :: Map ExeName (Set PackageName)
202 , sbPackageMap :: Map PackageName PackageInfo
203 , sbBuildDir :: FilePath
204 , sbPackageInfo :: PackageInfo
205 , sbRegisterMutex :: MVar ()
206 , sbModifiedEnv :: [(String, String)]
207 , sbHaddockFiles :: TVar (Map Text FilePath) -- ^ package-version, .haddock file
208 }
210singleBuild :: PerformBuild -> SingleBuild -> IO ()
211singleBuild pb@PerformBuild {..} SingleBuild {..} =
212 withCounter sbActive
213 $ handle updateErrs
214 $ (`finally` void (atomically $ tryPutTMVar (piResult sbPackageInfo) False))
215 $ inner
216 where
217 libComps = setFromList [CompLibrary, CompExecutable]
218 testComps = insertSet CompTestSuite libComps
219 inner = do
220 let wfd comps =
221 waitForDeps sbToolMap sbPackageMap comps pbPlan sbPackageInfo
222 . withTSem sbSem
223 wfd libComps buildLibrary
225 wfd testComps runTests
227 name = display $ piName sbPackageInfo
228 namever = concat
229 [ name
230 , "-"
231 , display $ ppVersion $ piPlan sbPackageInfo
232 ]
234 runIn wdir outH cmd args =
235 withCheckedProcess cp $ \ClosedStream UseProvidedHandle UseProvidedHandle ->
236 (return () :: IO ())
237 where
238 cp = (proc (unpack $ asText cmd) (map (unpack . asText) args))
239 { cwd = Just $ fpToString wdir
240 , std_out = UseHandle outH
241 , std_err = UseHandle outH
242 , env = Just sbModifiedEnv
243 }
244 runParent = runIn sbBuildDir
245 runChild = runIn childDir
246 childDir = sbBuildDir </> fpFromText namever
248 log' t = do
249 i <- readTVarIO sbActive
250 errs <- readTVarIO sbErrsVar
251 pbLog $ encodeUtf8 $ concat
252 [ t
253 , " (pending: "
254 , tshow i
255 , ", failures: "
256 , tshow $ length errs
257 , ")\n"
258 ]
259 libOut = pbLogDir </> fpFromText namever </> "build.out"
260 testOut = pbLogDir </> fpFromText namever </> "test.out"
261 testRunOut = pbLogDir </> fpFromText namever </> "test-run.out"
263 wf fp inner = do
264 createTree $ parent fp
265 withBinaryFile (fpToString fp) WriteMode inner
267 configArgs = ($ []) $ execWriter $ do
268 tell' "--package-db=clear"
269 tell' "--package-db=global"
270 forM_ (pbDatabase pb) $ \db -> tell' $ "--package-db=" ++ fpToText db
271 tell' $ "--libdir=" ++ fpToText (pbLibDir pb)
272 tell' $ "--bindir=" ++ fpToText (pbBinDir pb)
273 tell' $ "--datadir=" ++ fpToText (pbDataDir pb)
274 tell' $ "--docdir=" ++ fpToText (pbDocDir pb)
275 tell' $ "--flags=" ++ flags
276 where
277 tell' x = tell (x:)
279 flags :: Text
280 flags = unwords $ map go $ mapToList pcFlagOverrides
281 where
282 go (name, isOn) = concat
283 [ if isOn then "" else "-"
284 , unFlagName name
285 ]
287 PackageConstraints {..} = ppConstraints $ piPlan sbPackageInfo
289 buildLibrary = wf libOut $ \outH -> do
290 let run = runChild outH
291 log' $ "Unpacking " ++ namever
292 runParent outH "cabal" ["unpack", namever]
294 log' $ "Configuring " ++ namever
295 run "cabal" $ "configure" : configArgs
297 log' $ "Building " ++ namever
298 run "cabal" ["build"]
300 log' $ "Copying/registering " ++ namever
301 run "cabal" ["copy"]
302 withMVar sbRegisterMutex $ const $
303 run "cabal" ["register"]
305 -- Even if the tests later fail, we can allow other libraries to build
306 -- on top of our successful results
307 --
308 -- FIXME do we need to wait to do this until after Haddocks build?
309 -- otherwise, we could have a race condition and try to build a
310 -- dependency's haddocks before this finishes
311 atomically $ putTMVar (piResult sbPackageInfo) True
313 when (pcHaddocks /= Don'tBuild && not (null $ sdModules $ ppDesc $ piPlan sbPackageInfo)) $ do
314 log' $ "Haddocks " ++ namever
315 hfs <- readTVarIO sbHaddockFiles
316 let hfsOpts = flip map (mapToList hfs) $ \(pkgVer, hf) -> concat
317 [ "--haddock-options=--read-interface="
318 , "../"
319 , pkgVer
320 , "/,"
321 , fpToText hf
322 ]
323 args = "haddock"
324 : "--hyperlink-source"
325 : "--html"
326 : "--hoogle"
327 : "--html-location=../$pkg-$version/"
328 : hfsOpts
330 eres <- tryAny $ run "cabal" args
332 forM_ eres $ \() -> do
333 renameOrCopy
334 (childDir </> "dist" </> "doc" </> "html" </> fpFromText name)
335 (pbDocDir pb </> fpFromText namever)
337 enewPath <- tryIO
338 $ canonicalizePath
339 $ pbDocDir pb
340 </> fpFromText namever
341 </> fpFromText name <.> "haddock"
342 case enewPath of
343 Left e -> warn $ tshow e
344 Right newPath -> atomically
345 $ modifyTVar sbHaddockFiles
346 $ insertMap namever newPath
348 case (eres, pcHaddocks) of
349 (Left e, ExpectSuccess) -> throwM e
350 (Right (), ExpectFailure) -> warn $ namever ++ ": unexpected Haddock success"
351 _ -> return ()
353 runTests = wf testOut $ \outH -> do
354 let run = runChild outH
356 when (pcTests /= Don'tBuild) $ do
357 log' $ "Test configure " ++ namever
358 run "cabal" $ "configure" : "--enable-tests" : configArgs
360 eres <- tryAny $ do
361 log' $ "Test build " ++ namever
362 run "cabal" ["build"]
364 log' $ "Test run " ++ namever
365 run "cabal" ["test", "--log=" ++ fpToText testRunOut]
367 case (eres, pcTests) of
368 (Left e, ExpectSuccess) -> throwM e
369 (Right (), ExpectFailure) -> warn $ namever ++ ": unexpected test success"
370 _ -> return ()
372 warn t = atomically $ modifyTVar sbWarningsVar (. (t:))
374 updateErrs exc = do
375 log' $ concat
376 [ display (piName sbPackageInfo)
377 , ": "
378 , tshow exc
379 ]
380 atomically $ modifyTVar sbErrsVar $ insertMap (piName sbPackageInfo) exc'
381 where
382 exc' =
383 case fromException exc of
384 Just bf -> bf
385 Nothing -> BuildFailureException exc
387renameOrCopy :: FilePath -> FilePath -> IO ()
388renameOrCopy src dest = rename src dest `catchIO` \_ -> copyDir src dest
390copyDir :: FilePath -> FilePath -> IO ()
391copyDir src dest =
392 runResourceT $ sourceDirectoryDeep False src $$ mapM_C go
393 where
394 src' = src </> ""
395 go fp = forM_ (F.stripPrefix src' fp) $ \suffix -> do
396 let dest' = dest </> suffix
397 liftIO $ createTree $ parent dest'
398 sourceFile fp $$ (sinkFile dest' :: Sink ByteString (ResourceT IO) ())
400copyBuiltInHaddocks :: FilePath -> IO ()
401copyBuiltInHaddocks docdir = do
402 mghc <- findExecutable "ghc"
403 case mghc of
404 Nothing -> error "GHC not found on PATH"
405 Just ghc -> do
406 src <- canonicalizePath
407 (parent (fpFromString ghc) </> "../share/doc/ghc/html/libraries")
408 copyDir src docdir