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