@@ -0,0 +1,371 @@
1+-- | Perform an actual build, generate a binary package database and a
2+-- documentation directory in the process.
4+{-# LANGUAGE DeriveDataTypeable #-}
5+{-# LANGUAGE RecordWildCards #-}
6+{-# LANGUAGE NoImplicitPrelude #-}
7+{-# LANGUAGE OverloadedStrings #-}
8+module Stackage2.PerformBuild
11+ , BuildException (..)
14+import Stackage2.BuildConstraints
15+import Stackage2.PackageDescription
16+import Stackage2.BuildPlan
17+import Stackage2.Prelude hiding (pi)
18+import qualified Data.Map as Map
19+import Control.Concurrent.STM.TSem
20+import Data.NonNull (fromNullable)
21+import Control.Concurrent.Async (async)
22+import System.IO.Temp (withSystemTempDirectory)
23+import Filesystem (createTree, removeTree, isDirectory, rename, canonicalizePath)
24+import System.IO (withBinaryFile, IOMode (WriteMode))
25+import Filesystem.Path (parent)
26+import qualified Filesystem.Path as F
27+import System.Environment (getEnvironment)
28+import System.Directory (findExecutable)
30+data BuildException = BuildException (Map PackageName BuildFailure) [Text]
32+instance Exception BuildException
33+instance Show BuildException where
34+ show (BuildException m warnings) =
35+ unlines $ map go (mapToList m) ++ map unpack warnings
37+ go (PackageName name, bf) = concat
43+data BuildFailure = DependencyFailed PackageName
44+ | DependencyMissing PackageName
45+ | ToolMissing ExeName
47+ | BuildFailureException SomeException
48+ deriving (Show, Typeable)
49+instance Exception BuildFailure
51+data PerformBuild = PerformBuild
52+ { pbPlan :: BuildPlan
53+ , pbInstallDest :: FilePath
54+ , pbLog :: ByteString -> IO ()
55+ , pbLogDir :: FilePath
59+data PackageInfo = PackageInfo
60+ { piPlan :: PackagePlan
61+ , piName :: PackageName
62+ , piResult :: TMVar Bool
65+waitForDeps :: Map ExeName (Set PackageName)
66+ -> Map PackageName PackageInfo
72+waitForDeps toolMap packageMap activeComps bp pi action = do
74+ mapM_ checkPackage $ Map.keys $ filterUnused $ sdPackages $ ppDesc $ piPlan pi
75+ forM_ (Map.keys $ filterUnused $ sdTools $ ppDesc $ piPlan pi) $ \exe -> do
76+ case lookup exe toolMap >>= fromNullable . map checkPackage . setToList of
77+ Nothing -> throwSTM $ ToolMissing exe
78+ Just packages -> ofoldl1' (<|>) packages
81+ filterUnused :: Ord key => Map key DepInfo -> Map key DepInfo
83+ mapFromList . filter (go . snd) . mapToList
85+ go = not . null . intersection activeComps . diComponents
87+ checkPackage package | package == piName pi = return ()
88+ checkPackage package =
89+ case lookup package packageMap of
91+ | isCore package -> return ()
92+ | otherwise -> throwSTM $ DependencyMissing package
94+ res <- readTMVar $ piResult dep
95+ unless res $ throwSTM $ DependencyFailed package
97+ isCore = (`member` siCorePackages (bpSystemInfo bp))
99+withCounter counter = bracket_
100+ (atomically $ modifyTVar counter (+ 1))
101+ (atomically $ modifyTVar counter (`subtract` 1))
103+withTSem sem = bracket_ (atomically $ waitTSem sem) (atomically $ signalTSem sem)
105+pbDatabase pb = pbInstallDest pb </> "pkgdb"
106+pbBinDir pb = pbInstallDest pb </> "bin"
107+pbLibDir pb = pbInstallDest pb </> "lib"
108+pbDataDir pb = pbInstallDest pb </> "share"
109+pbDocDir pb = pbInstallDest pb </> "doc"
111+performBuild :: PerformBuild -> IO [Text]
112+performBuild pb@PerformBuild {..} = withBuildDir $ \builddir -> do
113+ let removeTree' fp = whenM (isDirectory fp) (removeTree fp)
114+ mapM_ removeTree' [pbInstallDest, pbLogDir]
116+ withCheckedProcess (proc "ghc-pkg" ["init", fpToString (pbDatabase pb)])
117+ $ \ClosedStream Inherited Inherited -> return ()
118+ pbLog $ encodeUtf8 "Copying built-in Haddocks\n"
119+ copyBuiltInHaddocks (pbDocDir pb)
121+ sem <- atomically $ newTSem pbJobs
122+ active <- newTVarIO (0 :: Int)
123+ let toolMap = makeToolMap $ bpPackages pbPlan
124+ packageMap <- fmap fold $ forM (mapToList $ bpPackages pbPlan)
125+ $ \(name, plan) -> do
128+ piResult <- newEmptyTMVarIO
129+ return $ singletonMap name PackageInfo {..}
131+ errsVar <- newTVarIO mempty
132+ warningsVar <- newTVarIO id
134+ env <- getEnvironment
135+ haddockFiles <- newTVarIO mempty
137+ forM_ packageMap $ \pi -> void $ async $ singleBuild pb SingleBuild
139+ , sbErrsVar = errsVar
140+ , sbWarningsVar = warningsVar
142+ , sbToolMap = toolMap
143+ , sbPackageMap = packageMap
144+ , sbBuildDir = builddir
145+ , sbPackageInfo = pi
146+ , sbRegisterMutex = mutex
147+ , sbModifiedEnv = ("HASKELL_PACKAGE_SANDBOX", fpToString $ pbDatabase pb)
149+ , sbHaddockFiles = haddockFiles
152+ void $ tryAny $ atomically $ readTVar active >>= checkSTM . (== 0)
154+ warnings <- ($ []) <$> readTVarIO warningsVar
155+ errs <- readTVarIO errsVar
156+ when (not $ null errs) $ throwM $ BuildException errs warnings
159+ withBuildDir f = withSystemTempDirectory "stackage-build" (f . fpFromString)
162+ -- Thank you Windows having case-insensitive environment variables...
163+ | toUpper p == "PATH" = (p, fpToString (pbBinDir pb) ++ pathSep : x)
164+ | otherwise = (p, x)
166+ -- | Separate for the PATH environment variable
168+#ifdef mingw32_HOST_OS
174+data SingleBuild = SingleBuild
176+ , sbErrsVar :: TVar (Map PackageName BuildFailure)
177+ , sbWarningsVar :: TVar ([Text] -> [Text])
178+ , sbActive :: TVar Int
179+ , sbToolMap :: Map ExeName (Set PackageName)
180+ , sbPackageMap :: Map PackageName PackageInfo
181+ , sbBuildDir :: FilePath
182+ , sbPackageInfo :: PackageInfo
183+ , sbRegisterMutex :: MVar ()
184+ , sbModifiedEnv :: [(String, String)]
185+ , sbHaddockFiles :: TVar (Map Text FilePath) -- ^ package-version, .haddock file
188+singleBuild :: PerformBuild -> SingleBuild -> IO ()
189+singleBuild pb@PerformBuild {..} SingleBuild {..} =
190+ withCounter sbActive
192+ $ (`finally` void (atomically $ tryPutTMVar (piResult sbPackageInfo) False))
195+ libComps = setFromList [CompLibrary, CompExecutable]
196+ testComps = insertSet CompTestSuite libComps
199+ waitForDeps sbToolMap sbPackageMap comps pbPlan sbPackageInfo
201+ wfd libComps buildLibrary
203+ -- Even if the tests later fail, we can allow other libraries to build
204+ -- on top of our successful results
205+ atomically $ putTMVar (piResult sbPackageInfo) True
207+ wfd testComps runTests
209+ name = display $ piName sbPackageInfo
213+ , display $ ppVersion $ piPlan sbPackageInfo
216+ runIn wdir outH errH cmd args =
217+ withCheckedProcess cp $ \ClosedStream out err -> do
218+ void $ async $ out $$ sinkHandle outH
219+ void $ async $ err $$ sinkHandle errH
220+ (return () :: IO ())
222+ cp = (proc (unpack $ asText cmd) (map (unpack . asText) args))
223+ { cwd = Just $ fpToString wdir
224+ {- FIXME UseProvidedHandle is broken
225+ , std_out = UseHandle outH
226+ , std_err = UseHandle errH
228+ , env = Just sbModifiedEnv
230+ runParent = runIn sbBuildDir
231+ runChild = runIn childDir
232+ childDir = sbBuildDir </> fpFromText namever
234+ log' = pbLog . encodeUtf8 . (++ "\n")
235+ libOut = pbLogDir </> fpFromText namever </> "build.out"
236+ libErr = pbLogDir </> fpFromText namever </> "build.err"
237+ testOut = pbLogDir </> fpFromText namever </> "test.out"
238+ testErr = pbLogDir </> fpFromText namever </> "test.err"
239+ testRunOut = pbLogDir </> fpFromText namever </> "test-run.out"
242+ createTree $ parent fp
243+ withBinaryFile (fpToString fp) WriteMode inner
246+ [ "--package-db=clear"
247+ , "--package-db=global"
248+ , "--package-db=" ++ fpToText (pbDatabase pb)
249+ , "--libdir=" ++ fpToText (pbLibDir pb)
250+ , "--bindir=" ++ fpToText (pbBinDir pb)
251+ , "--datadir=" ++ fpToText (pbDataDir pb)
252+ , "--docdir=" ++ fpToText (pbDocDir pb)
253+ , "--flags=" ++ flags
257+ flags = unwords $ map go $ mapToList pcFlagOverrides
259+ go (name, isOn) = concat
260+ [ if isOn then "" else "-"
264+ PackageConstraints {..} = ppConstraints $ piPlan sbPackageInfo
266+ buildLibrary = wf libOut $ \outH -> wf libErr $ \errH -> do
267+ let run = runChild outH errH
268+ log' $ "Unpacking " ++ namever
269+ runParent outH errH "cabal" ["unpack", namever]
271+ log' $ "Configuring " ++ namever
272+ run "cabal" $ "configure" : configArgs
274+ log' $ "Building " ++ namever
275+ run "cabal" ["build"]
277+ log' $ "Copying/registering " ++ namever
278+ run "cabal" ["copy"]
279+ withMVar sbRegisterMutex $ const $
280+ run "cabal" ["register"]
282+ when (pcHaddocks /= Don'tBuild) $ do
283+ log' $ "Haddocks " ++ namever
284+ hfs <- readTVarIO sbHaddockFiles
285+ let hfsOpts = flip map (mapToList hfs) $ \(pkgVer, hf) -> concat
286+ [ "--haddock-options=--read-interface="
293+ : "--hyperlink-source"
296+ : "--html-location=../$pkg-$version/"
299+ eres <- tryAny $ run "cabal" args
301+ forM_ eres $ \() -> do
303+ (childDir </> "dist" </> "doc" </> "html" </> fpFromText name)
304+ (pbDocDir pb </> fpFromText namever)
309+ $ docdir </> package </> packageName' <.> "haddock"
311+ Left _ -> return () -- print e
312+ Right newPath -> atomicModifyIORef haddockFilesRef $ \hfs'
313+ -> ((package, newPath) : hfs', ())
316+ case (eres, pcHaddocks) of
317+ (Left e, ExpectSuccess) -> throwM e
318+ (Right (), ExpectFailure) -> warn $ namever ++ ": unexpected Haddock success"
321+ runTests = wf testOut $ \outH -> wf testErr $ \errH -> do
322+ let run = runChild outH errH
324+ when (pcTests /= Don'tBuild) $ do
325+ log' $ "Test configure " ++ namever
326+ run "cabal" $ "configure" : "--enable-tests" : configArgs
329+ log' $ "Test build " ++ namever
330+ run "cabal" ["build"]
332+ log' $ "Test run " ++ namever
333+ run "cabal" ["test", "--log=" ++ fpToText testRunOut]
335+ case (eres, pcTests) of
336+ (Left e, ExpectSuccess) -> throwM e
337+ (Right (), ExpectFailure) -> warn $ namever ++ ": unexpected test success"
340+ warn t = atomically $ modifyTVar sbWarningsVar (. (t:))
343+ atomically $ modifyTVar sbErrsVar $ insertMap (piName sbPackageInfo) exc'
346+ case fromException exc of
348+ Nothing -> BuildFailureException exc
350+renameOrCopy :: FilePath -> FilePath -> IO ()
351+renameOrCopy src dest = rename src dest `catchIO` \_ -> copyDir src dest
353+copyDir :: FilePath -> FilePath -> IO ()
355+ runResourceT $ sourceDirectoryDeep False src $$ mapM_C go
358+ go fp = forM_ (F.stripPrefix src' fp) $ \suffix -> do
359+ let dest' = dest </> suffix
360+ liftIO $ createTree $ parent dest'
361+ sourceFile fp $$ (sinkFile dest' :: Sink ByteString (ResourceT IO) ())
363+copyBuiltInHaddocks :: FilePath -> IO ()
364+copyBuiltInHaddocks docdir = do
365+ mghc <- findExecutable "ghc"
367+ Nothing -> error "GHC not found on PATH"
369+ src <- canonicalizePath
370+ (parent (fpFromString ghc) </> "../share/doc/ghc/html/libraries")