stackage-curator-0.14.3: Stackage/PerformBuild.hs
-- | Perform an actual build, generate a binary package database and a
-- documentation directory in the process.
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Stackage.PerformBuild
( performBuild
, PerformBuild (..)
, BuildException (..)
, pbDocDir
, sdistFilePath
) where
import Control.Concurrent.Async (async)
import Control.Concurrent.STM.TSem
import Control.Monad.Writer.Strict (execWriter, tell)
import qualified Data.ByteString as S
import Data.Generics (mkT, everywhere)
import qualified Data.Map as Map
import Data.NonNull (fromNullable)
import Distribution.PackageDescription (buildType, packageDescription, BuildType (Simple),
condTestSuites)
import Distribution.Package (Dependency (..))
import Distribution.PackageDescription.PrettyPrint (writeGenericPackageDescription)
import Distribution.Version (anyVersion)
import Filesystem (canonicalizePath, createTree,
getWorkingDirectory,
removeTree, rename, removeFile)
import Filesystem.Path (parent)
import qualified Filesystem.Path.CurrentOS as F
import Network.HTTP.Simple
import Stackage.BuildConstraints
import Stackage.BuildPlan
import Stackage.GhcPkg
import Stackage.PackageDescription
import Stackage.PackageIndex (gpdFromLBS)
import Stackage.Prelude hiding (pi)
import System.Directory (doesDirectoryExist, doesFileExist, findExecutable, getDirectoryContents)
import qualified System.Directory
import qualified System.FilePath as FP
import System.Environment (getEnvironment)
import System.Exit
import System.IO (IOMode (WriteMode),
openBinaryFile, hFlush)
import System.IO.Temp (withSystemTempDirectory, withSystemTempFile)
import System.Timeout (timeout)
data BuildException = BuildException (Map PackageName BuildFailure) [Text]
deriving Typeable
instance Exception BuildException
instance Show BuildException where
show (BuildException m warnings) =
unlines $ "" : "" : "" : map go (mapToList m) ++ map unpack warnings
where
go (PackageName name, bf) = concat
[ name
, ": "
, take 500 $ show bf
]
data BuildFailure = DependencyFailed PackageName
| DependencyMissing PackageName
| ToolMissing ExeName
| NotImplemented
| BuildFailureException SomeException
deriving (Show, Typeable)
instance Exception BuildFailure
data PerformBuild = PerformBuild
{ pbPlan :: BuildPlan
, pbInstallDest :: FilePath
, pbLog :: ByteString -> IO ()
, pbLogDir :: FilePath
, pbJobs :: Int
, pbGlobalInstall :: Bool
-- ^ Register packages in the global database
, pbEnableTests :: Bool
, pbEnableBenches :: Bool
, pbEnableHaddock :: Bool
, pbEnableLibProfiling :: Bool
, pbEnableExecDyn :: Bool
, pbVerbose :: Bool
, pbAllowNewer :: Bool
-- ^ Strip out version bounds in .cabal files
, pbBuildHoogle :: Bool
-- ^ Should we build Hoogle database?
--
-- May be disabled due to: https://ghc.haskell.org/trac/ghc/ticket/9921
, pbNoRebuildCabal :: !Bool
-- ^ Ignore new Cabal version from the plan and use whatever's in the
-- database. Useful for testing pre-release GHCs
, pbCabalFromHead :: !Bool
-- ^ Used for testing Cabal itself: grab the most recent version of Cabal
-- from Github master
}
data PackageInfo = PackageInfo
{ piPlan :: PackagePlan
, piName :: PackageName
, piResult :: TMVar Bool
}
waitForDeps :: Map ExeName (Set PackageName)
-> Map PackageName PackageInfo
-> Set Component
-> BuildPlan
-> PackageInfo
-> IO a
-> IO a
waitForDeps toolMap packageMap activeComps bp pi action = do
atomically $ do
mapM_ checkPackage $ addCabal $ Map.keysSet $ filterUnused $ sdPackages $ ppDesc $ piPlan pi
forM_ (Map.keys $ filterUnused $ sdTools $ ppDesc $ piPlan pi) $ \exe -> do
case lookup exe toolMap >>= fromNullable . map checkPackage . setToList of
Nothing
| isCoreExe exe -> return ()
-- https://github.com/jgm/zip-archive/issues/23
-- - | otherwise -> throwSTM $ ToolMissing exe
| otherwise -> return ()
Just packages -> ofoldl1' (<|>) packages
action
where
filterUnused :: Ord key => Map key DepInfo -> Map key DepInfo
filterUnused =
mapFromList . filter (go . snd) . mapToList
where
go = not . null . intersection activeComps . diComponents
checkPackage package | package == piName pi = return ()
checkPackage package =
case lookup package packageMap of
Nothing
| isCore package -> return ()
| otherwise -> throwSTM $ DependencyMissing package
Just dep -> do
res <- readTMVar $ piResult dep
unless res $ throwSTM $ DependencyFailed package
isCore = (`member` siCorePackages (bpSystemInfo bp))
isCoreExe = (`member` siCoreExecutables (bpSystemInfo bp))
-- Since we build every package using the Cabal library, it's an implicit
-- dependency of everything
addCabal :: Set PackageName -> Set PackageName
addCabal = insertSet (PackageName "Cabal")
withCounter :: TVar Int -> IO a -> IO a
withCounter counter = bracket_
(atomically $ modifyTVar counter (+ 1))
(atomically $ modifyTVar counter (subtract 1))
withTSem :: TSem -> IO a -> IO a
withTSem sem = bracket_ (atomically $ waitTSem sem) (atomically $ signalTSem sem)
-- | Returns @Nothing@ if installing to a global database
pbDatabase :: PerformBuild -> Maybe FilePath
pbDatabase pb
| pbGlobalInstall pb = Nothing
| otherwise = Just $ pbInstallDest pb </> "pkgdb"
pbBinDir, pbLibDir, pbDataDir, pbLibexecDir, pbSysconfDir, pbDocDir :: PerformBuild -> FilePath
pbBinDir pb = pbInstallDest pb </> "bin"
pbLibDir pb = pbInstallDest pb </> "lib"
pbDataDir pb = pbInstallDest pb </> "share"
pbLibexecDir pb = pbInstallDest pb </> "libexec"
pbSysconfDir pb = pbInstallDest pb </> "etc"
pbDocDir pb = pbInstallDest pb </> "doc"
-- | Directory keeping previous result info
pbPrevResDir :: PerformBuild -> FilePath
pbPrevResDir pb = pbInstallDest pb </> "prevres"
performBuild :: PerformBuild -> IO [Text]
performBuild pb = do
cwd <- getWorkingDirectory
performBuild' pb
{ pbInstallDest = F.encodeString cwd </> pbInstallDest pb
, pbLogDir = F.encodeString cwd </> pbLogDir pb
}
performBuild' :: PerformBuild -> IO [Text]
performBuild' pb@PerformBuild {..} = withBuildDir $ \builddir -> do
let removeTree' fp = whenM (doesDirectoryExist fp) (removeTree $ fromString fp)
removeTree' $ fromString pbLogDir
forM_ (pbDatabase pb) $ \db ->
unlessM (doesFileExist $ db </> "package.cache") $ do
createTree $ parent $ fromString db
withCheckedProcess (proc "ghc-pkg" ["init", db])
$ \ClosedStream Inherited Inherited -> return ()
pbLog $ encodeUtf8 "Copying built-in Haddocks\n"
copyBuiltInHaddocks (pbDocDir pb)
sem <- atomically $ newTSem pbJobs
active <- newTVarIO (0 :: Int)
let toolMap = makeToolMap (bpBuildToolOverrides pbPlan) (bpPackages pbPlan)
errsVar <- newTVarIO mempty
warningsVar <- newTVarIO id
mutex <- newMVar ()
env <- getEnvironment
registeredPackages <- setupPackageDatabase
(pbDatabase pb)
(pbDocDir pb)
pbLog
(ppVersion <$> bpPackages pbPlan)
(deletePreviousResults pb)
allPreviousResults <- getAllPreviousResults pb
packageMap' <- fmap fold $ forM (mapToList $ bpPackages pbPlan)
$ \(name, plan) -> do
let piPlan = plan
piName = name
piResult <- newEmptyTMVarIO
return $ asMap $ singletonMap name PackageInfo {..}
packageMap <- calculatePackageMap pb registeredPackages allPreviousResults packageMap'
pbLog "Collecting existing .haddock files\n"
haddockFiles <- getHaddockFiles pb >>= newTVarIO
haddockDeps <- newTVarIO mempty
forM_ packageMap $ \pi -> void $ Control.Concurrent.Async.async $ singleBuild pb registeredPackages
SingleBuild
{ sbSem = sem
, sbErrsVar = errsVar
, sbWarningsVar = warningsVar
, sbActive = active
, sbToolMap = toolMap
, sbPackageMap = packageMap
, sbBuildDir = builddir
, sbPackageInfo = pi
, sbRegisterMutex = mutex
, sbModifiedEnv = maybe
id
(\db -> (("HASKELL_PACKAGE_SANDBOX", db):))
(pbDatabase pb)
(filter allowedEnv $ map fixEnv env)
, sbHaddockFiles = haddockFiles
, sbHaddockDeps = haddockDeps
}
void $ tryAny $ atomically $ readTVar active >>= checkSTM . (== 0)
warnings <- ($ []) <$> readTVarIO warningsVar
errs <- readTVarIO errsVar
when (not $ null errs) $ throwM $ BuildException errs warnings
return warnings
where
withBuildDir f = withSystemTempDirectory "stackage-build" f
fixEnv (p, x)
-- Thank you Windows having case-insensitive environment variables...
| toUpper p == "PATH" = (p, pbBinDir pb ++ pathSep : x)
| otherwise = (p, x)
allowedEnv (k, _) = k `notMember` bannedEnvs
-- | Separate for the PATH environment variable
pathSep :: Char
#ifdef mingw32_HOST_OS
pathSep = ';'
#else
pathSep = ':'
#endif
-- | Environment variables we don't allow to be passed on to child processes.
bannedEnvs :: Set String
bannedEnvs = setFromList
[ "STACKAGE_AUTH_TOKEN"
]
data SingleBuild = SingleBuild
{ sbSem :: TSem
, sbErrsVar :: TVar (Map PackageName BuildFailure)
, sbWarningsVar :: TVar ([Text] -> [Text])
, sbActive :: TVar Int
, sbToolMap :: Map ExeName (Set PackageName)
, sbPackageMap :: Map PackageName PackageInfo
, sbBuildDir :: FilePath
, sbPackageInfo :: PackageInfo
, sbRegisterMutex :: MVar ()
, sbModifiedEnv :: [(String, String)]
, sbHaddockFiles :: TVar (Map Text FilePath) -- ^ package-version, .haddock file
, sbHaddockDeps :: TVar (Map PackageName (Set PackageName))
-- ^ Deep deps of library and executables
}
singleBuild :: PerformBuild
-> Map PackageName Version -- ^ registered packages
-> SingleBuild -> IO ()
singleBuild pb@PerformBuild {..} registeredPackages SingleBuild {..} = do
withCounter sbActive
$ handle updateErrs
$ (`finally` void (atomically $ tryPutTMVar (piResult sbPackageInfo) False))
$ inner
where
libComps = setFromList [CompLibrary, CompExecutable]
testComps = insertSet CompTestSuite libComps
benchComps = insertSet CompBenchmark libComps
thisIsCabal = pname == PackageName "Cabal" -- cue Sparta joke
inner
| thisIsCabal && pbNoRebuildCabal =
atomically $ putTMVar (piResult sbPackageInfo) True
| otherwise = do
let wfd comps =
waitForDeps sbToolMap sbPackageMap comps pbPlan sbPackageInfo
. withTSem sbSem
withUnpacked <- wfd libComps buildLibrary
wfd testComps (runTests withUnpacked)
wfd benchComps (buildBenches withUnpacked)
pname = piName sbPackageInfo
pident = PackageIdentifier pname (ppVersion $ piPlan sbPackageInfo)
name = display pname
version = display $ ppVersion $ piPlan sbPackageInfo
namever = concat
[ name
, "-"
, version
]
quote :: Text -> Text
quote s
| any special s = tshow s
| otherwise = s
where
special ' ' = True
special '\'' = True
special '"' = True
special _ = False
runIn :: FilePath -> IO Handle -> Text -> [Text] -> IO ()
runIn wdir getOutH cmd args = do
outH <- getOutH
S.hPut outH $ encodeUtf8 $ concat
[ "> "
, pack wdir
, "$ "
, unwords $ map quote $ cmd : args
, "\n"
]
hFlush outH
-- instead of using withCheckedProcess, we go lower-level so that we
-- can kill the process in the case of an async exception (via the
-- timeout call below)
let cp' = cp outH
(ClosedStream, UseProvidedHandle, UseProvidedHandle, sph)
<- streamingProcess cp'
ec <- waitForStreamingProcess sph `onException` do
-- Call the process
let ph = streamingProcessHandleRaw sph
terminateProcess ph
unless (ec == ExitSuccess) $ throwIO $ ProcessExitedUnsuccessfully cp' ec
where
cp outH = (proc (unpack cmd) (map unpack args))
{ cwd = Just wdir
, std_out = UseHandle outH
, std_err = UseHandle outH
, env = Just sbModifiedEnv
}
runParent = runIn sbBuildDir
log' t = do
i <- readTVarIO sbActive
errs <- readTVarIO sbErrsVar
pbLog $ encodeUtf8 $ concat
[ t
, " (pending: "
, tshow i
, ", failures: "
, tshow $ length errs
, ")\n"
]
libOut = pbLogDir </> unpack namever </> "build.out"
testOut = pbLogDir </> unpack namever </> "test.out"
benchOut = pbLogDir </> unpack namever </> "bench.out"
wf fp inner' = do
ref <- newIORef Nothing
let cleanup = do
mh <- readIORef ref
forM_ mh hClose
getH = do
mh <- readIORef ref
case mh of
Just h -> return h
Nothing -> mask_ $ do
createTree $ parent $ fromString fp
h <- openBinaryFile fp WriteMode
writeIORef ref $ Just h
return h
inner' getH `finally` cleanup
runghcArgs :: [Text] -> [Text]
runghcArgs rest =
"-clear-package-db"
: "-global-package-db"
: (case pbDatabase pb of
Nothing -> rest
Just db -> ("-package-db=" ++ pack db) : rest)
configArgs = ($ []) $ execWriter $ do
tell' "--package-db=clear"
tell' "--package-db=global"
forM_ (pbDatabase pb) $ \db -> tell' $ "--package-db=" ++ pack db
tell' $ "--libdir=" ++ pack (pbLibDir pb)
tell' $ "--bindir=" ++ pack (pbBinDir pb)
tell' $ "--datadir=" ++ pack (pbDataDir pb)
tell' $ "--libexecdir=" ++ pack (pbLibexecDir pb)
tell' $ "--sysconfdir=" ++ pack (pbSysconfDir pb)
tell' $ "--docdir=" ++ pack (pbDocDir pb </> unpack namever)
tell' $ "--htmldir=" ++ pack (pbDocDir pb </> unpack namever)
tell' $ "--haddockdir=" ++ pack (pbDocDir pb </> unpack namever)
tell' $ "--flags=" ++ flags
when (pbEnableLibProfiling && pcEnableLibProfile) $
tell' "--enable-library-profiling"
when pbEnableExecDyn $ tell' "--enable-executable-dynamic"
tell (toList pcConfigureArgs ++)
where
tell' x = tell (x:)
flags :: Text
flags = unwords $ map go $ mapToList pcFlagOverrides
where
go (name', isOn) = concat
[ if isOn then "" else "-"
, unFlagName name'
]
PackageConstraints {..} = ppConstraints $ piPlan sbPackageInfo
hasLib = not $ null $ sdModules $ ppDesc $ piPlan sbPackageInfo
buildLibrary = wf libOut $ \getOutH -> do
gpdRef <- newIORef Nothing
let withUnpacked inner' = do
mgpd <- readIORef gpdRef
(gpd, childDir) <-
case mgpd of
Just x -> return x
Nothing -> do
childDir <- if thisIsCabal && pbCabalFromHead
then do
log' "Getting most recent Cabal from Git"
runParent getOutH "git"
[ "clone"
, "https://github.com/haskell/cabal"
]
return $ sbBuildDir </> "cabal" </> "Cabal"
else do
log' $ "Unpacking " ++ namever
case ppSourceUrl $ piPlan sbPackageInfo of
Nothing -> runParent getOutH "stack" ["unpack", namever]
Just url -> unpackFromURL sbBuildDir url
return $ sbBuildDir </> unpack namever
gpd <- createSetupHs childDir name pbAllowNewer
writeIORef gpdRef $ Just (gpd, childDir)
return (gpd, childDir)
inner' gpd childDir
isConfiged <- newIORef False
let withConfiged inner' = withUnpacked $ \_gpd childDir -> do
let run a b = do when pbVerbose $ log' (unwords (a : b))
runIn childDir getOutH a b
cabal args = run "runghc" $ runghcArgs $ "Setup" : args
unlessM (readIORef isConfiged) $ do
log' $ "Configuring " ++ namever
cabal $ "configure" : configArgs
writeIORef isConfiged True
inner' childDir cabal
prevBuildResult <- getPreviousResult pb Build pident
toBuild <- case () of
()
| pcSkipBuild -> return False
| prevBuildResult /= PRSuccess -> return True
| pname `notMember` registeredPackages && hasLib -> do
log' $ concat
[ "WARNING: Package "
, display pname
, " marked as build success, but not registered"
]
return True
| otherwise -> return False
when toBuild $ withConfiged $ \_childDir cabal -> do
deletePreviousResults pb pident
log' $ "Building " ++ namever
cabal ["build"]
log' $ "Copying/registering " ++ namever
cabal ["copy"]
withMVar sbRegisterMutex $ const $
cabal ["register"]
savePreviousResult pb Build pident True
-- Even if the tests later fail, we can allow other libraries to build
-- on top of our successful results
--
-- FIXME do we need to wait to do this until after Haddocks build?
-- otherwise, we could have a race condition and try to build a
-- dependency's haddocks before this finishes
atomically $ putTMVar (piResult sbPackageInfo) True
prevHaddockResult <- getPreviousResult pb Haddock pident
let needHaddock = pbEnableHaddock
&& checkPrevResult prevHaddockResult pcHaddocks
&& not (null $ sdModules $ ppDesc $ piPlan sbPackageInfo)
&& not pcSkipBuild
when needHaddock $ withConfiged $ \childDir cabal -> do
log' $ "Haddocks " ++ namever
hfs <- readTVarIO sbHaddockFiles
haddockDeps <- atomically $ getHaddockDeps pbPlan sbHaddockDeps pname
-- See: https://github.com/commercialhaskell/stack/pull/1070/files
(hyped, _, _) <- readProcessWithExitCode "haddock" ["--hyperlinked-source"] ""
let hfsOpts = map hfOpt
$ filter ((`member` haddockDeps) . toPackageName . fst)
$ mapToList hfs
toPackageName t =
case simpleParse t of
Just (PackageIdentifier x _) -> x
Nothing -> error $ "Invalid package identifier: " ++ unpack t
hfOpt (pkgVer, hf) = concat
[ "--haddock-options=--read-interface="
, "../"
, pkgVer
, "/,"
, pack hf
]
args = ($ hfsOpts) $ execWriter $ do
let tell' x = tell (x:)
tell' "haddock"
tell' $ if hyped == ExitSuccess
then "--haddock-option=--hyperlinked-source"
else "--hyperlink-source"
tell' "--html"
when pbBuildHoogle $ tell' "--hoogle"
tell' "--html-location=../$pkg-$version/"
eres <- tryAny $ cabal args
forM_ eres $ \() -> do
renameOrCopy
(childDir </> "dist" </> "doc" </> "html" </> unpack name)
(pbDocDir pb </> unpack namever)
enewPath <- tryIO'
$ canonicalizePath
$ fromString
$ pbDocDir pb
</> unpack namever
</> unpack name <.> "haddock"
case enewPath of
Left e -> warn $ tshow e
Right newPath -> atomically
$ modifyTVar sbHaddockFiles
$ insertMap namever (F.encodeString newPath)
savePreviousResult pb Haddock pident $ either (const False) (const True) eres
case (eres, pcHaddocks) of
(Left e, ExpectSuccess) -> throwM e
(Right (), ExpectFailure) -> warn $ namever ++ ": unexpected Haddock success"
_ -> return ()
return withUnpacked
runTests withUnpacked = wf testOut $ \getOutH -> do
prevTestResult <- getPreviousResult pb Test pident
let needTest = pbEnableTests
&& checkPrevResult prevTestResult pcTests
&& not pcSkipBuild
when needTest $ withUnpacked $ \gpd childDir -> do
let run = runIn childDir getOutH
cabal args = run "runghc" $ runghcArgs $ "Setup" : args
log' $ "Test configure " ++ namever
cabal $ "configure" : "--enable-tests" : configArgs
eres <- tryAny $ do
log' $ "Test build " ++ namever
cabal ["build"]
let tests = map fst $ condTestSuites gpd
forM_ tests $ \test -> do
log' $ concat
[ "Test run "
, namever
, " ("
, pack test
, ")"
]
let exe = "dist/build" </> test </> test
exists <- liftIO $ doesFileExist $ childDir </> exe
if exists
then do
mres <- timeout maximumTestSuiteTime $ run (pack exe) []
case mres of
Just () -> return ()
Nothing -> error $ concat
[ "Test suite timed out: "
, unpack namever
, ":"
, test
]
else do
outH <- getOutH
hPutStrLn outH $ "Test suite not built: " ++ test
hFlush outH
savePreviousResult pb Test pident $ either (const False) (const True) eres
case (eres, pcTests) of
(Left e, ExpectSuccess) -> throwM e
(Right (), ExpectFailure) -> warn $ namever ++ ": unexpected test success"
_ -> return ()
buildBenches withUnpacked = wf benchOut $ \getOutH -> do
prevBenchResult <- getPreviousResult pb Bench pident
let needTest = pbEnableBenches
&& checkPrevResult prevBenchResult pcBenches
&& not pcSkipBuild
when needTest $ withUnpacked $ \_gpd childDir -> do
let run = runIn childDir getOutH
cabal args = run "runghc" $ runghcArgs $ "Setup" : args
log' $ "Benchmark configure " ++ namever
cabal $ "configure" : "--enable-benchmarks" : configArgs
eres <- tryAny $ do
log' $ "Benchmark build " ++ namever
cabal ["build"]
savePreviousResult pb Bench pident $ either (const False) (const True) eres
case (eres, pcBenches) of
(Left e, ExpectSuccess) -> throwM e
(Right (), ExpectFailure) -> warn $ namever ++ ": unexpected benchmark success"
_ -> return ()
warn t = atomically $ modifyTVar sbWarningsVar (. (t:))
updateErrs exc = do
log' $ concat
[ display (piName sbPackageInfo)
, ": "
, take 500 $ tshow exc
]
atomically $ modifyTVar sbErrsVar $ insertMap (piName sbPackageInfo) exc'
where
exc' =
case fromException exc of
Just bf -> bf
Nothing -> BuildFailureException exc
-- | Unpack the file at the given URL into the given directory
unpackFromURL :: MonadIO m
=> FilePath -- ^ dest directory
-> Text -- ^ URL
-> m ()
unpackFromURL destDir url = liftIO $ do
req <- parseRequest $ unpack url
withSystemTempFile "unpack-from-url.tar.gz" $ \fp h -> do
httpSink req (const $ sinkHandle h)
hClose h
let cp = (proc "tar" ["xf", fp])
{ cwd = Just destDir
}
withCheckedProcessCleanup cp
$ \ClosedStream ClosedStream ClosedStream -> return ()
-- | Maximum time (in microseconds) to run a single test suite
maximumTestSuiteTime :: Int
maximumTestSuiteTime = 10 * 60 * 1000 * 1000 -- ten minutes
renameOrCopy :: FilePath -> FilePath -> IO ()
renameOrCopy src dest =
rename (fromString src) (fromString dest)
`catchIO'` \_ -> copyDir src dest
copyBuiltInHaddocks :: FilePath -> IO ()
copyBuiltInHaddocks docdir = do
mghc <- findExecutable "ghc"
case mghc of
Nothing -> error "GHC not found on PATH"
Just ghc -> do
-- Starting with GHC 8, the doc/ghc directory is now
-- doc/ghc-8.0.1 (and so on). Let's put in a hacky trick
-- to find the right directory.
let root = F.encodeString (parent (fromString ghc)) </>
"../share/doc"
names <- getDirectoryContents root
let hidden ('.':_) = True
hidden _ = False
name <-
case filter (not . hidden) names of
[x] -> return x
_ -> error $ concat
[ "Unexpected list of contents in "
, root
, ": "
, show names
]
src <- canonicalizePath $ fromString $
root </> name </> "html/libraries"
copyDir (F.encodeString src) docdir
------------- Previous results
-- | The previous actions that can be run
data ResultType = Build | Haddock | Test | Bench
deriving (Show, Enum, Eq, Ord, Bounded, Read)
-- | The result generated on a previous run
data PrevResult = PRNoResult | PRSuccess | PRFailure
deriving (Show, Enum, Eq, Ord, Bounded, Read)
-- | Check if we should rerun based on a PrevResult and the expected status
checkPrevResult :: PrevResult -> TestState -> Bool
checkPrevResult _ Don'tBuild = False
checkPrevResult PRNoResult _ = True
checkPrevResult PRSuccess _ = False
checkPrevResult PRFailure ExpectSuccess = True
checkPrevResult PRFailure _ = False
withPRPath :: PerformBuild -> ResultType -> PackageIdentifier -> (FilePath -> IO a) -> IO a
withPRPath pb rt ident inner = do
createTree $ parent $ fromString fp
inner fp
where
fp = pbPrevResDir pb </> show rt </> unpack (display ident)
successBS, failureBS :: ByteString
successBS = "success"
failureBS = "failure"
getAllPreviousResults :: PerformBuild -> IO (PackageName -> ResultType -> Maybe (Version, PrevResult))
getAllPreviousResults pb = do
m <- fmap fold $ forM [minBound..maxBound] $ \rt -> asMap . singletonMap rt <$> go rt
return $ \pn rt -> lookup rt m >>= lookup pn
where
go :: ResultType -> IO (Map PackageName (Version, PrevResult))
go rt = do
allResults <-
runResourceT
$ sourceDirectory dir
$$ filterMC (liftIO . doesFileExist)
=$ mapMC (liftIO . toMap)
=$ foldlC (unionWith union) mempty
fmap concat $ mapM (uncurry removeDupes) $ mapToList allResults
where
dir = pbPrevResDir pb </> show rt
toMap :: FilePath -> IO (Map PackageName (Map Version PrevResult))
toMap fp = do
case simpleParse $ pack $ FP.takeFileName fp of
Nothing -> return mempty
Just (PackageIdentifier name version) -> do
eres <- tryIO' $ readFile fp
let mres =
case eres of
Right bs
| bs == successBS -> Just PRSuccess
| bs == failureBS -> Just PRFailure
_ -> Nothing
case mres of
Nothing -> return mempty
Just res -> return $ singletonMap name (singletonMap version res)
removeDupes :: PackageName -> Map Version PrevResult -> IO (Map PackageName (Version, PrevResult))
removeDupes name m =
case mapToList m of
[] -> assert False $ return mempty
[pair] -> return $ singletonMap name pair
_pairs -> do
removePreviousResults pb rt name
return mempty
getPreviousResult :: PerformBuild -> ResultType -> PackageIdentifier -> IO PrevResult
getPreviousResult w x y = withPRPath w x y $ \fp -> do
eres <- tryIO' $ readFile fp
return $ case eres of
Right bs
| bs == successBS -> PRSuccess
| bs == failureBS -> PRFailure
_ -> PRNoResult
-- | Remove all previous results to avoid a broken cache
removePreviousResults :: PerformBuild -> ResultType -> PackageName -> IO ()
removePreviousResults pb rt name =
runResourceT
$ sourceDirectory dir
$$ filterC isOurPackage
=$ filterMC (liftIO . doesFileExist)
=$ mapM_C (liftIO . System.Directory.removeFile)
where
dir = pbPrevResDir pb </> show rt
prefix = display name ++ "-"
isOurPackage fp = fromMaybe False $ do
versionT <- stripPrefix prefix $ pack $ FP.takeFileName fp
_ :: Version <- simpleParse versionT
return True
savePreviousResult :: PerformBuild -> ResultType -> PackageIdentifier -> Bool -> IO ()
savePreviousResult pb rt ident@(PackageIdentifier name _version) res =
withPRPath pb rt ident $ \fp -> do
removePreviousResults pb rt name
writeFile fp $ if res then successBS else failureBS
deletePreviousResults :: PerformBuild -> PackageIdentifier -> IO ()
deletePreviousResults pb name =
forM_ [minBound..maxBound] $ \rt ->
withPRPath pb rt name $ \fp ->
void $ tryIO' $ removeFile $ fromString fp
-- | Discover existing .haddock files in the docs directory
getHaddockFiles :: PerformBuild -> IO (Map Text FilePath)
getHaddockFiles pb =
runResourceT
$ sourceDirectory (pbDocDir pb)
$$ foldMapMC (liftIO . go)
where
go :: FilePath -> IO (Map Text FilePath)
go dir =
case simpleParse nameVerText of
Nothing -> return mempty
Just (PackageIdentifier (PackageName name) _) -> do
let fp = dir </> name <.> "haddock"
exists <- doesFileExist fp
return $ if exists
then singletonMap nameVerText fp
else mempty
where
nameVerText = pack $ FP.takeFileName dir
getHaddockDeps :: BuildPlan
-> TVar (Map PackageName (Set PackageName))
-> PackageName
-> STM (Set PackageName)
getHaddockDeps BuildPlan {..} var =
go
where
go :: PackageName -> STM (Set PackageName)
go name = do
m <- readTVar var
case lookup name m of
Just res -> return res
Nothing -> do
-- First thing we do is put in a dummy value in the var for
-- this package, to avoid the possibility of an infinite loop
-- due to packages depending on themselves (which is in fact
-- valid).
modifyTVar var $ insertMap name mempty
res' <- fmap fold $ mapM go $ setToList deps
let res = deps ++ res'
modifyTVar var $ insertMap name res
return res
where
deps =
case lookup name bpPackages of
Nothing -> mempty
Just PackagePlan {..} ->
asSet
$ setFromList
$ map fst
$ filter (isLibExe . snd)
$ mapToList
$ sdPackages ppDesc
isLibExe DepInfo {..} =
CompLibrary `member` diComponents ||
CompExecutable `member` diComponents
sdistFilePath :: IsString filepath
=> FilePath -- ^ stack directory
-> Text -- ^ package name
-> Text -- ^ package name
-> filepath
sdistFilePath stackDir name version = fromString
$ stackDir
</> "indices"
</> "Hackage"
</> "packages"
</> unpack name
</> unpack version
</> unpack (concat [name, "-", version, ".tar.gz"])
-- | Create a default Setup.hs file if the given directory is a simple build plan
--
-- Also deletes any Setup.lhs if necessary
createSetupHs :: FilePath
-> Text -- ^ package name
-> Bool -- ^ allow newer?
-> IO GenericPackageDescription
createSetupHs dir name allowNewer = do
bs <- readFile cabalFP
gpd' <- gpdFromLBS cabalFP (fromStrict bs)
gpd <-
if allowNewer
then do
let gpd = stripVersionBounds gpd'
writeGenericPackageDescription cabalFP gpd
return gpd
else return gpd'
let simple = buildType (packageDescription gpd) == Just Simple
when simple $ do
_ <- tryIO' $ removeFile $ fromString setuplhs
writeFile setuphs $ asByteString "import Distribution.Simple\nmain = defaultMain\n"
return gpd
where
cabalFP = dir </> unpack name <.> "cabal"
setuphs = dir </> "Setup.hs"
setuplhs = dir </> "Setup.lhs"
-- | Strip all version bounds from a GenericPackageDescription
stripVersionBounds :: GenericPackageDescription -> GenericPackageDescription
stripVersionBounds = everywhere $ mkT $ \(Dependency name _) -> Dependency name anyVersion
tryIO' :: IO a -> IO (Either IOException a)
tryIO' = try
catchIO' :: IO a -> (IOException -> IO a) -> IO a
catchIO' = catch
data BuildState = BSFullBuild | BSPartialBuild | NoBuild
deriving Show
calculatePackageMap :: PerformBuild
-> Map PackageName Version -- ^ registered libraries
-> (PackageName -> ResultType -> Maybe (Version, PrevResult))
-> Map PackageName PackageInfo
-> IO (Map PackageName PackageInfo)
calculatePackageMap pb registered prevRes allInfos =
loop initBuildStates
where
-- Calculate initial build states based on whether packages are
-- registered and previous results. This will not take into
-- account dependencies, which will be calculate by loop
initBuildStates :: Map PackageName BuildState
initBuildStates =
foldMap go $ mapToList allInfos
where
go :: (PackageName, PackageInfo) -> Map PackageName BuildState
go (name, info)
-- If we're not going to build it, then don't build it
| pcSkipBuild (ppConstraints plan) = singletonMap name NoBuild
-- If this is a library and it's not registered, then we
-- need to do a full build
| isLib && lookup name registered /= Just version = singletonMap name BSFullBuild
-- If we have a previous successful build result which
-- matches our version, then we'll need to check
-- dependencies to know what to do
| Just (prevVer, prevRes) <- prevRes name Build
, prevVer == version && prevRes == PRSuccess = mempty
-- Something in the previous step failed, so do a full build
| otherwise = singletonMap name BSFullBuild
where
isLib = not $ null $ sdModules $ ppDesc plan
version = ppVersion plan
plan = piPlan info
loop buildStates0 = do
buildStates1 <- foldM step' buildStates0 (mapToList allInfos)
case (keys $ buildStates1 `difference` buildStates0, keys $ allInfos `Map.difference` buildStates1) of
-- Added new build states, and no infos are unaccounted for, so
-- we're done
(_:_, []) -> processBuildStates buildStates1
-- Added new build states, but we still have some unaccounted for
-- packages, so loop
(_:_, _:_) -> loop buildStates1
-- Did not add any build states, but somehow all the infos are
-- accounted for. This is logically impossible, print an error.
([], []) -> do
putStrLn $ "\n\ncalculatePackageMap: Solved all packages, but no change in build states"
mapM_ print $ mapToList buildStates1
putStrLn $ "\n\nPreviously missing packages:" ++ tshow (map display $ keys $ allInfos `Map.difference` buildStates0)
error "FIXME"
-- Did not add any build states, and we still have some infos
-- unaccounted for. That indicates some kind of cyclic dependency.
([], noBuildState) -> error $ "calculatePackageMap: No change in build states, but haven't solved all packages: " ++ show (map display noBuildState)
where
step' buildStates (name, info) = do
res <- step buildStates name info
return $
case res of
Nothing -> buildStates
Just bs -> insertMap name bs buildStates
step :: Map PackageName BuildState -> PackageName -> PackageInfo -> IO (Maybe BuildState)
step states name pi =
go $ keys $ Map.filter ((CompLibrary `member`) . diComponents) $ sdPackages desc
where
plan = piPlan pi
desc = ppDesc plan
go (dep:deps) | dep == name = go deps
go (dep:deps) =
case lookup dep states of
-- Don't know what to do with a dep. Let's see if it's
-- actually in the build plan (as opposed to a core
-- library)
Nothing
-- It's in the build plan, so let's wait
| dep `member` allInfos -> do
when False $ putStrLn $ concat -- debugging
[ display name
, ": don't know state of dep: "
, tshow dep
]
return Nothing
-- Not in the build plan, so ignore and move on
-- (e.g., the base package)
| otherwise -> go deps
-- dep will be rebuilt, so we need to be rebuilt too
Just BSFullBuild -> do
putStrLn $ concat
[ "Rebuilding "
, display name
, " due to dependency "
, display dep
]
return $ Just BSFullBuild
-- dep will not have its library rebuilt, so check the rest
Just BSPartialBuild -> go deps
Just NoBuild -> go deps
-- none of the dependencies will have their libraries rebuilt
go [] = return $ Just BSPartialBuild -- FIXME figure out if we have no need to build at all NoBuild
processBuildStates :: Map PackageName BuildState -> IO (Map PackageName PackageInfo)
processBuildStates buildStates =
fmap fold $ mapM go $ mapToList allInfos
where
go :: (PackageName, PackageInfo) -> IO (Map PackageName PackageInfo)
go (name, info) =
case lookup name buildStates of
Nothing -> error $ "processBuildStates: name not found " ++ show name
Just BSFullBuild -> do
putStrLn $ "Removing all previous results for " ++ display name
forM_ [minBound..maxBound] $ \rt -> removePreviousResults pb rt name
return $ singletonMap name info
Just BSPartialBuild -> return $ singletonMap name info
Just NoBuild -> return mempty