diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,68 @@ +## 0.7.0 + +* Renamed to stackage-curator + +## 0.6.1 + +* Switch to V2 upload by default +* --skip-hoogle option + +## 0.6.0 + +* Upload bundle V2 stuff + +## 0.5.2 + +* Upload LTS to Hackage with the name LTSHaskell + +## 0.5.1 + +* `loadBuildConstraints` +* More command line options + +## 0.5.0 + +* Print "Still Alive" while checking, to avoid Travis timeouts +* Include `stackage upload-nightly` command +* Optional plan checking + +## 0.4.0 + +* Command line uses optparse-applicative with additional options +* Library profiling support during build +* Remove cfGlobalFlags (just use package-specific flags) + +## 0.3.1 + +* Added `justCheck` and `stackage check` command line. + +## 0.3.0.1 + +Pre-fetch all packages from Hackage to catch Hackage downtime early. + +## 0.3.0.0 + +* Return progress URL from uploadBundle + +## 0.2.1.4 + +Generate a `core` file in bundles. + +## 0.2.1.1 + +Run postBuild earlier to avoid problems from broken doc uploads. + +## 0.2.1.0 + +* Use TLS manager (to download from Github) + +## 0.2.0.0 + +* Minor fixes +* `pbGlobalInstall` + +## 0.1.0.0 + +First version of Stackage which is made available as its own package. The +codebase has been completely rewritten at this point, to be ready for generated +both Stackage Nightly and LTS Haskell distributions. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2012 FP Complete, http://www.fpcomplete.com/ + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,12 @@ +## stackage-curator + +This repository contains the code for curating Stackage package sets and +building reusable package databases. It was originally simply called the +stackage package and was part of the stackage repository, but since this is a +tool very few people need to use, we split it into its own package with a name +to indicate it's limited usage (curators only). + +More information on Stackage: + +* [Stackage Homepage](https://www.stackage.org) +* [Main stackage repo](https://github.com/fpco/stackage) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Stackage/BuildConstraints.hs b/Stackage/BuildConstraints.hs new file mode 100644 --- /dev/null +++ b/Stackage/BuildConstraints.hs @@ -0,0 +1,234 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +-- | The constraints on package selection for a new build plan. +module Stackage.BuildConstraints + ( BuildConstraints (..) + , PackageConstraints (..) + , TestState (..) + , SystemInfo (..) + , getSystemInfo + , defaultBuildConstraints + , toBC + , BuildConstraintsSource (..) + , loadBuildConstraints + ) where + +import Control.Monad.Writer.Strict (execWriter, tell) +import Data.Aeson +import qualified Data.Map as Map +import Data.Yaml (decodeEither', decodeFileEither) +import Distribution.Package (Dependency (..)) +import Distribution.System (Arch, OS) +import qualified Distribution.System +import Distribution.Version (anyVersion) +import Filesystem (isFile) +import Network.HTTP.Client (Manager, httpLbs, responseBody, Request) +import Stackage.CorePackages +import Stackage.Prelude + +data TestState = ExpectSuccess + | ExpectFailure + | Don'tBuild -- ^ when the test suite will pull in things we don't want + deriving (Show, Eq, Ord, Bounded, Enum) + +testStateToText :: TestState -> Text +testStateToText ExpectSuccess = "expect-success" +testStateToText ExpectFailure = "expect-failure" +testStateToText Don'tBuild = "do-not-build" + +instance ToJSON TestState where + toJSON = toJSON . testStateToText +instance FromJSON TestState where + parseJSON = withText "TestState" $ \t -> + case lookup t states of + Nothing -> fail $ "Invalid state: " ++ unpack t + Just v -> return v + where + states = asHashMap $ mapFromList + $ map (\x -> (testStateToText x, x)) [minBound..maxBound] + +data SystemInfo = SystemInfo + { siGhcVersion :: Version + , siOS :: OS + , siArch :: Arch + , siCorePackages :: Map PackageName Version + , siCoreExecutables :: Set ExeName + } + deriving (Show, Eq, Ord) +instance ToJSON SystemInfo where + toJSON SystemInfo {..} = object + [ "ghc-version" .= display siGhcVersion + , "os" .= display siOS + , "arch" .= display siArch + , "core-packages" .= Map.mapKeysWith const unPackageName (map display siCorePackages) + , "core-executables" .= siCoreExecutables + ] +instance FromJSON SystemInfo where + parseJSON = withObject "SystemInfo" $ \o -> do + let helper name = (o .: name) >>= either (fail . show) return . simpleParse + siGhcVersion <- helper "ghc-version" + siOS <- helper "os" + siArch <- helper "arch" + siCorePackages <- (o .: "core-packages") >>= goPackages + siCoreExecutables <- o .: "core-executables" + return SystemInfo {..} + where + goPackages = either (fail . show) return + . mapM simpleParse + . Map.mapKeysWith const mkPackageName + +data BuildConstraints = BuildConstraints + { bcPackages :: Set PackageName + -- ^ This does not include core packages. + , bcPackageConstraints :: PackageName -> PackageConstraints + + , bcSystemInfo :: SystemInfo + + , bcGithubUsers :: Map Text (Set Text) + -- ^ map an account to set of pingees + } + +data PackageConstraints = PackageConstraints + { pcVersionRange :: VersionRange + , pcMaintainer :: Maybe Maintainer + , pcTests :: TestState + , pcHaddocks :: TestState + , pcBuildBenchmarks :: Bool + , pcFlagOverrides :: Map FlagName Bool + , pcEnableLibProfile :: Bool + } + deriving (Show, Eq) +instance ToJSON PackageConstraints where + toJSON PackageConstraints {..} = object $ addMaintainer + [ "version-range" .= display pcVersionRange + , "tests" .= pcTests + , "haddocks" .= pcHaddocks + , "build-benchmarks" .= pcBuildBenchmarks + , "flags" .= Map.mapKeysWith const unFlagName pcFlagOverrides + , "library-profiling" .= pcEnableLibProfile + ] + where + addMaintainer = maybe id (\m -> (("maintainer" .= m):)) pcMaintainer +instance FromJSON PackageConstraints where + parseJSON = withObject "PackageConstraints" $ \o -> do + pcVersionRange <- (o .: "version-range") + >>= either (fail . show) return . simpleParse + pcTests <- o .: "tests" + pcHaddocks <- o .: "haddocks" + pcBuildBenchmarks <- o .: "build-benchmarks" + pcFlagOverrides <- Map.mapKeysWith const mkFlagName <$> o .: "flags" + pcMaintainer <- o .:? "maintainer" + pcEnableLibProfile <- fmap (fromMaybe True) (o .:? "library-profiling") + return PackageConstraints {..} + +-- | The proposed plan from the requirements provided by contributors. +-- +-- Checks the current directory for a build-constraints.yaml file and uses it +-- if present. If not, downloads from Github. +defaultBuildConstraints :: Manager -> IO BuildConstraints +defaultBuildConstraints = loadBuildConstraints BCSDefault + +data BuildConstraintsSource + = BCSDefault + | BCSFile FilePath + | BCSWeb Request + deriving (Show) + +loadBuildConstraints :: BuildConstraintsSource -> Manager -> IO BuildConstraints +loadBuildConstraints bcs man = do + case bcs of + BCSDefault -> do + e <- isFile fp0 + if e + then loadFile fp0 + else loadReq req0 + BCSFile fp -> loadFile fp + BCSWeb req -> loadReq req + where + fp0 = "build-constraints.yaml" + req0 = "https://raw.githubusercontent.com/fpco/stackage/master/build-constraints.yaml" + + loadFile fp = decodeFileEither (fpToString fp) >>= either throwIO toBC + loadReq req = httpLbs req man >>= + either throwIO toBC . decodeEither' . toStrict . responseBody + + +getSystemInfo :: IO SystemInfo +getSystemInfo = do + siCorePackages <- getCorePackages + siCoreExecutables <- getCoreExecutables + siGhcVersion <- getGhcVersion + return SystemInfo {..} + where + -- FIXME consider not hard-coding the next two values + siOS = Distribution.System.Linux + siArch = Distribution.System.X86_64 + +data ConstraintFile = ConstraintFile + { cfPackageFlags :: Map PackageName (Map FlagName Bool) + , cfSkippedTests :: Set PackageName + , cfExpectedTestFailures :: Set PackageName + , cfExpectedHaddockFailures :: Set PackageName + , cfSkippedBenchmarks :: Set PackageName + , cfPackages :: Map Maintainer (Vector Dependency) + , cfGithubUsers :: Map Text (Set Text) + , cfSkippedLibProfiling :: Set PackageName + } + +instance FromJSON ConstraintFile where + parseJSON = withObject "ConstraintFile" $ \o -> do + cfPackageFlags <- (goPackageMap . fmap goFlagMap) <$> o .: "package-flags" + cfSkippedTests <- getPackages o "skipped-tests" + cfExpectedTestFailures <- getPackages o "expected-test-failures" + cfExpectedHaddockFailures <- getPackages o "expected-haddock-failures" + cfSkippedBenchmarks <- getPackages o "skipped-benchmarks" + cfSkippedLibProfiling <- getPackages o "skipped-profiling" + cfPackages <- o .: "packages" + >>= mapM (mapM toDep) + . Map.mapKeysWith const Maintainer + cfGithubUsers <- o .: "github-users" + return ConstraintFile {..} + where + goFlagMap = Map.mapKeysWith const FlagName + goPackageMap = Map.mapKeysWith const PackageName + getPackages o name = (setFromList . map PackageName) <$> o .: name + + toDep :: Monad m => Text -> m Dependency + toDep = either (fail . show) return . simpleParse + +toBC :: ConstraintFile -> IO BuildConstraints +toBC ConstraintFile {..} = do + bcSystemInfo <- getSystemInfo + return BuildConstraints {..} + where + combine (maintainer, range1) (_, range2) = + (maintainer, intersectVersionRanges range1 range2) + revmap = unionsWith combine $ ($ []) $ execWriter + $ forM_ (mapToList cfPackages) + $ \(maintainer, deps) -> forM_ deps + $ \(Dependency name range) -> + tell (singletonMap name (maintainer, range):) + + bcPackages = Map.keysSet revmap + + bcPackageConstraints name = + PackageConstraints {..} + where + mpair = lookup name revmap + pcMaintainer = fmap fst mpair + pcVersionRange = maybe anyVersion snd mpair + pcEnableLibProfile = not (name `member` cfSkippedLibProfiling) + pcTests + | name `member` cfSkippedTests = Don'tBuild + | name `member` cfExpectedTestFailures = ExpectFailure + | otherwise = ExpectSuccess + pcBuildBenchmarks = name `notMember` cfSkippedBenchmarks + pcHaddocks + | name `member` cfExpectedHaddockFailures = ExpectFailure + + | otherwise = ExpectSuccess + pcFlagOverrides = fromMaybe mempty $ lookup name cfPackageFlags + + bcGithubUsers = cfGithubUsers diff --git a/Stackage/BuildPlan.hs b/Stackage/BuildPlan.hs new file mode 100644 --- /dev/null +++ b/Stackage/BuildPlan.hs @@ -0,0 +1,214 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +-- | Representation of a concrete build plan, and how to generate a new one +-- based on constraints. +module Stackage.BuildPlan + ( BuildPlan (..) + , PackagePlan (..) + , newBuildPlan + , makeToolMap + , getLatestAllowedPlans + ) where + +import Control.Monad.State.Strict (execState, get, put) +import Data.Aeson +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Distribution.Compiler +import Distribution.PackageDescription +import Stackage.BuildConstraints +import Stackage.GithubPings +import Stackage.PackageDescription +import Stackage.PackageIndex +import Stackage.Prelude + +data BuildPlan = BuildPlan + { bpSystemInfo :: SystemInfo + , bpTools :: Vector (PackageName, Version) + , bpPackages :: Map PackageName PackagePlan + , bpGithubUsers :: Map Text (Set Text) + } + deriving (Show, Eq) + +instance ToJSON BuildPlan where + toJSON BuildPlan {..} = object + [ "system-info" .= bpSystemInfo + , "tools" .= map goTool bpTools + , "packages" .= Map.mapKeysWith const unPackageName bpPackages + , "github-users" .= bpGithubUsers + ] + where + goTool (k, v) = object + [ "name" .= display k + , "version" .= display v + ] +instance FromJSON BuildPlan where + parseJSON = withObject "BuildPlan" $ \o -> do + bpSystemInfo <- o .: "system-info" + bpTools <- (o .: "tools") >>= mapM goTool + bpPackages <- Map.mapKeysWith const mkPackageName <$> (o .: "packages") + bpGithubUsers <- o .:? "github-users" .!= mempty + return BuildPlan {..} + where + goTool = withObject "Tool" $ \o -> (,) + <$> ((o .: "name") >>= + either (fail . show) return . simpleParse . asText) + <*> ((o .: "version") >>= + either (fail . show) return . simpleParse . asText) + +data PackagePlan = PackagePlan + { ppVersion :: Version + , ppGithubPings :: Set Text + , ppUsers :: Set PackageName + , ppConstraints :: PackageConstraints + , ppDesc :: SimpleDesc + } + deriving (Show, Eq) + +instance ToJSON PackagePlan where + toJSON PackagePlan {..} = object + [ "version" .= asText (display ppVersion) + , "github-pings" .= ppGithubPings + , "users" .= map unPackageName (unpack ppUsers) + , "constraints" .= ppConstraints + , "description" .= ppDesc + ] +instance FromJSON PackagePlan where + parseJSON = withObject "PackageBuild" $ \o -> do + ppVersion <- o .: "version" + >>= either (fail . show) return + . simpleParse . asText + ppGithubPings <- o .:? "github-pings" .!= mempty + ppUsers <- Set.map PackageName <$> (o .:? "users" .!= mempty) + ppConstraints <- o .: "constraints" + ppDesc <- o .: "description" + return PackagePlan {..} + +-- | Make a build plan given these package set and build constraints. +newBuildPlan :: MonadIO m => Map PackageName PackagePlan -> BuildConstraints -> m BuildPlan +newBuildPlan packagesOrig bc@BuildConstraints {..} = liftIO $ do + let toolMap = makeToolMap packagesOrig + packages = populateUsers $ removeUnincluded bc toolMap packagesOrig + toolNames :: [ExeName] + toolNames = concatMap (Map.keys . sdTools . ppDesc) packages + tools <- topologicalSortTools toolMap $ mapFromList $ do + exeName <- toolNames + guard $ exeName `notMember` siCoreExecutables + packageName <- maybe mempty setToList $ lookup exeName toolMap + packagePlan <- maybeToList $ lookup packageName packagesOrig + return (packageName, packagePlan) + -- FIXME topologically sort packages? maybe just leave that to the build phase + return BuildPlan + { bpSystemInfo = bcSystemInfo + , bpTools = tools + , bpPackages = packages + , bpGithubUsers = bcGithubUsers + } + where + SystemInfo {..} = bcSystemInfo + +makeToolMap :: Map PackageName PackagePlan + -> Map ExeName (Set PackageName) +makeToolMap = + unionsWith (++) . map go . mapToList + where + go (packageName, pp) = + foldMap go' $ sdProvidedExes $ ppDesc pp + where + go' exeName = singletonMap exeName (singletonSet packageName) + +topologicalSortTools :: MonadThrow m + => Map ExeName (Set PackageName) + -> Map PackageName PackagePlan + -> m (Vector (PackageName, Version)) +topologicalSortTools toolMap = topologicalSort + ppVersion + (concatMap (fromMaybe mempty . flip lookup toolMap) . Map.keys . sdTools . ppDesc) + +-- | Include only packages which are dependencies of the required packages and +-- their build tools. +removeUnincluded :: BuildConstraints + -> Map ExeName (Set PackageName) + -> Map PackageName PackagePlan + -> Map PackageName PackagePlan +removeUnincluded BuildConstraints {..} toolMap orig = + mapFromList $ filter (\(x, _) -> x `member` included) $ mapToList orig + where + SystemInfo {..} = bcSystemInfo + + included :: Set PackageName + included = flip execState mempty $ mapM_ add bcPackages + + add name = do + inc <- get + when (name `notMember` inc) $ do + put $ insertSet name inc + case lookup name orig of + Nothing -> return () + Just pb -> do + mapM_ add $ Map.keys $ sdPackages $ ppDesc pb + forM_ (Map.keys $ sdTools $ ppDesc pb) $ + \exeName -> when (exeName `notMember` siCoreExecutables) + $ mapM_ add $ fromMaybe mempty $ lookup exeName toolMap + +populateUsers :: Map PackageName PackagePlan + -> Map PackageName PackagePlan +populateUsers orig = + mapWithKey go orig + where + go name pb = pb { ppUsers = foldMap (go2 name) (mapToList orig) } + + go2 dep (user, pb) + | dep `member` sdPackages (ppDesc pb) = singletonSet user + | otherwise = mempty + +-- | Check whether the given package/version combo meets the constraints +-- currently in place. +isAllowed :: BuildConstraints + -> PackageName -> Version -> Bool +isAllowed bc = \name version -> + case lookup name $ siCorePackages $ bcSystemInfo bc of + Just _ -> False -- never reinstall a core package + Nothing -> withinRange version $ pcVersionRange $ bcPackageConstraints bc name + +mkPackagePlan :: MonadThrow m + => BuildConstraints + -> GenericPackageDescription + -> m PackagePlan +mkPackagePlan bc gpd = do + ppDesc <- toSimpleDesc CheckCond {..} gpd + return PackagePlan {..} + where + PackageIdentifier name ppVersion = package $ packageDescription gpd + ppGithubPings = getGithubPings bc gpd + ppConstraints = bcPackageConstraints bc name + ppUsers = mempty -- must be filled in later + + ccPackageName = name + ccOS = siOS + ccArch = siArch + ccCompilerFlavor = Distribution.Compiler.GHC + ccCompilerVersion = siGhcVersion + ccFlags = flags + ccIncludeTests = pcTests ppConstraints /= Don'tBuild + ccIncludeBenchmarks = pcBuildBenchmarks ppConstraints + + SystemInfo {..} = bcSystemInfo bc + + overrides = pcFlagOverrides ppConstraints + getFlag MkFlag {..} = + (flagName, fromMaybe flagDefault $ lookup flagName overrides) + flags = mapFromList $ map getFlag $ genPackageFlags gpd + +getLatestAllowedPlans :: MonadIO m => BuildConstraints -> m (Map PackageName PackagePlan) +getLatestAllowedPlans bc = + getLatestDescriptions + (isAllowed bc) + (mkPackagePlan bc) diff --git a/Stackage/CheckBuildPlan.hs b/Stackage/CheckBuildPlan.hs new file mode 100644 --- /dev/null +++ b/Stackage/CheckBuildPlan.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} +-- | Confirm that a build plan has a consistent set of dependencies. +module Stackage.CheckBuildPlan + ( checkBuildPlan + , BadBuildPlan + ) where + +import Control.Monad.Writer.Strict (Writer, execWriter, tell) +import qualified Data.Map.Strict as M +import qualified Data.Text as T +import Stackage.BuildConstraints +import Stackage.BuildPlan +import Stackage.PackageDescription +import Stackage.Prelude + +-- | Check the build plan for missing deps, wrong versions, etc. +checkBuildPlan :: (MonadThrow m) => BuildPlan -> m () +checkBuildPlan BuildPlan {..} + | null errs' = return () + | otherwise = throwM errs + where + allPackages = map (,mempty) (siCorePackages bpSystemInfo) ++ + map (ppVersion &&& M.keys . M.filter libAndExe . sdPackages . ppDesc) bpPackages + errs@(BadBuildPlan errs') = + execWriter $ mapM_ (checkDeps allPackages) $ mapToList bpPackages + -- Only looking at libraries and executables, benchmarks and tests + -- are allowed to create cycles (e.g. test-framework depends on + -- text, which uses test-framework in its test-suite). + libAndExe (DepInfo cs _) = any (flip elem [CompLibrary,CompExecutable]) cs + +-- | For a given package name and plan, check that its dependencies are: +-- +-- 1. Existent (existing in the provided package map) +-- 2. Within version range +-- 3. Check for dependency cycles. +checkDeps :: Map PackageName (Version,[PackageName]) + -> (PackageName, PackagePlan) + -> Writer BadBuildPlan () +checkDeps allPackages (user, pb) = + mapM_ go $ mapToList $ sdPackages $ ppDesc pb + where + go (dep, diRange -> range) = + case lookup dep allPackages of + Nothing -> tell $ BadBuildPlan $ singletonMap (dep, Nothing) errMap + Just (version,deps) + | version `withinRange` range -> + occursCheck allPackages + (\d v -> + tell $ BadBuildPlan $ singletonMap + (d,v) + errMap) + dep + deps + [] + | otherwise -> tell $ BadBuildPlan $ singletonMap + (dep, Just version) + errMap + where + errMap = singletonMap pu range + pu = PkgUser + { puName = user + , puVersion = ppVersion pb + , puMaintainer = pcMaintainer $ ppConstraints pb + , puGithubPings = ppGithubPings pb + } + +-- | Check whether the package(s) occurs within its own dependency +-- tree. +occursCheck + :: Monad m + => Map PackageName (Version,[PackageName]) + -- ^ All packages. + -> (PackageName -> Maybe Version -> m ()) + -- ^ Report an erroneous package. + -> PackageName + -- ^ Starting package to check for cycles in. + -> [PackageName] + -- ^ Dependencies of the package. + -> [PackageName] + -- ^ Previously seen packages up the dependency tree. + -> m () +occursCheck allPackages reportError = + go + where + go pkg deps seen = + case find (flip elem seen) deps of + Just cyclic -> + reportError cyclic $ + fmap fst (lookup cyclic allPackages) + Nothing -> + forM_ deps $ + \pkg' -> + case lookup pkg' allPackages of + Just (_v,deps') + | pkg' /= pkg -> go pkg' deps' seen' + _ -> return () + where seen' = pkg : seen + +data PkgUser = PkgUser + { puName :: PackageName + , puVersion :: Version + , puMaintainer :: Maybe Maintainer + , puGithubPings :: Set Text + } + deriving (Eq, Ord) + +pkgUserShow1 :: PkgUser -> Text +pkgUserShow1 PkgUser {..} = concat + [ display puName + , "-" + , display puVersion + ] + +pkgUserShow2 :: PkgUser -> Text +pkgUserShow2 PkgUser {..} = unwords + $ (maybe "No maintainer" unMaintainer puMaintainer ++ ".") + : map (cons '@') (setToList puGithubPings) + +newtype BadBuildPlan = + BadBuildPlan (Map (PackageName, Maybe Version) (Map PkgUser VersionRange)) + deriving Typeable +instance Exception BadBuildPlan +instance Show BadBuildPlan where + show (BadBuildPlan errs) = + unpack $ concatMap go $ mapToList errs + where + go ((dep, mdepVer), users) = unlines + $ "" + : showDepVer dep mdepVer + : map showUser (mapToList users) + + showDepVer :: PackageName -> Maybe Version -> Text + showDepVer dep Nothing = display dep ++ " (not present) depended on by:" + showDepVer dep (Just version) = concat + [ display dep + , "-" + , display version + , " depended on by:" + ] + + showUser :: (PkgUser, VersionRange) -> Text + showUser (pu, range) = concat + [ "- " + , pkgUserShow1 pu + , " (" + -- add a space after < to avoid confusing Markdown processors (like + -- Github's issue tracker) + , T.replace "<" "< " $ display range + , "). " + , pkgUserShow2 pu + ] + +instance Monoid BadBuildPlan where + mempty = BadBuildPlan mempty + mappend (BadBuildPlan x) (BadBuildPlan y) = + BadBuildPlan $ unionWith (unionWith intersectVersionRanges) x y diff --git a/Stackage/CompleteBuild.hs b/Stackage/CompleteBuild.hs new file mode 100644 --- /dev/null +++ b/Stackage/CompleteBuild.hs @@ -0,0 +1,337 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Stackage.CompleteBuild + ( BuildType (..) + , BumpType (..) + , BuildFlags (..) + , completeBuild + , justCheck + , justUploadNightly + , getStackageAuthToken + ) where + +import Control.Concurrent (threadDelay) +import Control.Concurrent.Async (withAsync) +import Data.Default.Class (def) +import Data.Semigroup (Max (..), Option (..)) +import Data.Text.Read (decimal) +import Data.Time +import Data.Yaml (decodeFileEither, encodeFile) +import Network.HTTP.Client +import Network.HTTP.Client.TLS (tlsManagerSettings) +import Stackage.BuildConstraints +import Stackage.BuildPlan +import Stackage.CheckBuildPlan +import Stackage.PerformBuild +import Stackage.Prelude +import Stackage.ServerBundle +import Stackage.UpdateBuildPlan +import Stackage.Upload +import System.Environment (lookupEnv) +import System.IO (BufferMode (LineBuffering), hSetBuffering) + +-- | Flags passed in from the command line. +data BuildFlags = BuildFlags + { bfEnableTests :: !Bool + , bfEnableHaddock :: !Bool + , bfDoUpload :: !Bool + , bfEnableLibProfile :: !Bool + , bfEnableExecDyn :: !Bool + , bfVerbose :: !Bool + , bfSkipCheck :: !Bool + , bfUploadV1 :: !Bool + , bfServer :: !StackageServer + , bfBuildHoogle :: !Bool + } deriving (Show) + +data BuildType = Nightly | LTS BumpType + deriving (Show, Read, Eq, Ord) + +data BumpType = Major | Minor + deriving (Show, Read, Eq, Ord) + +data Settings = Settings + { plan :: BuildPlan + , planFile :: FilePath + , buildDir :: FilePath + , logDir :: FilePath + , title :: Text -> Text -- ^ GHC version -> title + , slug :: Text + , setArgs :: Text -> UploadBundle -> UploadBundle + , postBuild :: IO () + , distroName :: Text -- ^ distro name on Hackage + , snapshotType :: SnapshotType + , bundleDest :: FilePath + } + +nightlyPlanFile :: Text -- ^ day + -> FilePath +nightlyPlanFile day = fpFromText ("nightly-" ++ day) <.> "yaml" + +nightlySettings :: Text -- ^ day + -> BuildPlan + -> Settings +nightlySettings day plan' = Settings + { planFile = nightlyPlanFile day + , buildDir = fpFromText $ "builds/nightly" + , logDir = fpFromText $ "logs/stackage-nightly-" ++ day + , title = \ghcVer -> concat + [ "Stackage Nightly " + , day + , ", GHC " + , ghcVer + ] + , slug = slug' + , setArgs = \ghcVer ub -> ub { ubNightly = Just ghcVer } + , plan = plan' + , postBuild = return () + , distroName = "Stackage" + , snapshotType = STNightly + , bundleDest = fpFromText $ "stackage-nightly-" ++ day ++ ".bundle" + } + where + slug' = "nightly-" ++ day + +getSettings :: Manager -> BuildType -> IO Settings +getSettings man Nightly = do + day <- tshow . utctDay <$> getCurrentTime + bc <- defaultBuildConstraints man + pkgs <- getLatestAllowedPlans bc + plan' <- newBuildPlan pkgs bc + return $ nightlySettings day plan' +getSettings man (LTS bumpType) = do + Option mlts <- fmap (fmap getMax) $ runResourceT + $ sourceDirectory "." + $$ foldMapC (Option . fmap Max . parseLTSVer . filename) + + (new, plan') <- case bumpType of + Major -> do + let new = + case mlts of + Nothing -> LTSVer 0 0 + Just (LTSVer x _) -> LTSVer (x + 1) 0 + bc <- defaultBuildConstraints man + pkgs <- getLatestAllowedPlans bc + plan' <- newBuildPlan pkgs bc + return (new, plan') + Minor -> do + old <- maybe (error "No LTS plans found in current directory") return mlts + oldplan <- decodeFileEither (fpToString $ renderLTSVer old) + >>= either throwM return + let new = incrLTSVer old + let bc = updateBuildConstraints oldplan + pkgs <- getLatestAllowedPlans bc + plan' <- newBuildPlan pkgs bc + return (new, plan') + + let newfile = renderLTSVer new + + return Settings + { planFile = newfile + , buildDir = fpFromText $ "builds/lts" + , logDir = fpFromText $ "logs/stackage-lts-" ++ tshow new + , title = \ghcVer -> concat + [ "LTS Haskell " + , tshow new + , ", GHC " + , ghcVer + ] + , slug = "lts-" ++ tshow new + , setArgs = \_ ub -> ub { ubLTS = Just $ tshow new } + , plan = plan' + , postBuild = do + let git args = withCheckedProcess + (proc "git" args) $ \ClosedStream Inherited Inherited -> + return () + putStrLn "Committing new LTS file to Git" + git ["add", fpToString newfile] + git ["commit", "-m", "Added new LTS release: " ++ show new] + putStrLn "Pushing to Git repository" + git ["push"] + , distroName = "LTSHaskell" + , snapshotType = + case new of + LTSVer x y -> STLTS x y + , bundleDest = fpFromText $ "stackage-lts-" ++ tshow new ++ ".bundle" + } + +data LTSVer = LTSVer !Int !Int + deriving (Eq, Ord) +instance Show LTSVer where + show (LTSVer x y) = concat [show x, ".", show y] +incrLTSVer :: LTSVer -> LTSVer +incrLTSVer (LTSVer x y) = LTSVer x (y + 1) + +parseLTSVer :: FilePath -> Maybe LTSVer +parseLTSVer fp = do + w <- stripPrefix "lts-" $ fpToText fp + x <- stripSuffix ".yaml" w + Right (major, y) <- Just $ decimal x + z <- stripPrefix "." y + Right (minor, "") <- Just $ decimal z + return $ LTSVer major minor +renderLTSVer :: LTSVer -> FilePath +renderLTSVer lts = fpFromText $ concat + [ "lts-" + , tshow lts + , ".yaml" + ] + +-- | Just print a message saying "still alive" every minute, to appease Travis. +stillAlive :: IO () -> IO () +stillAlive inner = + withAsync (printer 1) $ const inner + where + printer i = forever $ do + threadDelay 60000000 + putStrLn $ "Still alive: " ++ tshow i + printer $! i + 1 + +-- | Generate and check a new build plan, but do not execute it. +-- +-- Since 0.3.1 +justCheck :: IO () +justCheck = stillAlive $ withManager tlsManagerSettings $ \man -> do + putStrLn "Loading build constraints" + bc <- defaultBuildConstraints man + + putStrLn "Creating build plan" + plans <- getLatestAllowedPlans bc + plan <- newBuildPlan plans bc + + putStrLn $ "Writing build plan to check-plan.yaml" + encodeFile "check-plan.yaml" plan + + putStrLn "Checking plan" + checkBuildPlan plan + + putStrLn "Plan seems valid!" + +getPerformBuild :: BuildFlags -> Settings -> PerformBuild +getPerformBuild buildFlags Settings {..} = PerformBuild + { pbPlan = plan + , pbInstallDest = buildDir + , pbLogDir = logDir + , pbLog = hPut stdout + , pbJobs = 8 + , pbGlobalInstall = False + , pbEnableTests = bfEnableTests buildFlags + , pbEnableHaddock = bfEnableHaddock buildFlags + , pbEnableLibProfiling = bfEnableLibProfile buildFlags + , pbEnableExecDyn = bfEnableExecDyn buildFlags + , pbVerbose = bfVerbose buildFlags + , pbAllowNewer = bfSkipCheck buildFlags + , pbBuildHoogle = bfBuildHoogle buildFlags + } + +-- | Make a complete plan, build, test and upload bundle, docs and +-- distro. +completeBuild :: BuildType -> BuildFlags -> IO () +completeBuild buildType buildFlags = withManager tlsManagerSettings $ \man -> do + hSetBuffering stdout LineBuffering + + putStrLn $ "Loading settings for: " ++ tshow buildType + settings@Settings {..} <- getSettings man buildType + + putStrLn $ "Writing build plan to: " ++ fpToText planFile + encodeFile (fpToString planFile) plan + + if bfSkipCheck buildFlags + then putStrLn "Skipping build plan check" + else do + putStrLn "Checking build plan" + checkBuildPlan plan + + putStrLn "Performing build" + let pb = getPerformBuild buildFlags settings + performBuild pb >>= mapM_ putStrLn + + putStrLn $ "Creating bundle (v2) at: " ++ fpToText bundleDest + createBundleV2 CreateBundleV2 + { cb2Plan = plan + , cb2Type = snapshotType + , cb2DocsDir = pbDocDir pb + , cb2Dest = bundleDest + } + + when (bfDoUpload buildFlags) $ + finallyUpload + (not $ bfUploadV1 buildFlags) + (bfServer buildFlags) + settings + man + +justUploadNightly + :: Text -- ^ nightly date + -> IO () +justUploadNightly day = do + plan <- decodeFileEither (fpToString $ nightlyPlanFile day) + >>= either throwM return + withManager tlsManagerSettings $ finallyUpload False def $ nightlySettings day plan + +getStackageAuthToken :: IO Text +getStackageAuthToken = do + mtoken <- lookupEnv "STACKAGE_AUTH_TOKEN" + case mtoken of + Nothing -> decodeUtf8 <$> readFile "/auth-token" + Just token -> return $ pack token + +-- | The final part of the complete build process: uploading a bundle, +-- docs and a distro to hackage. +finallyUpload :: Bool -- ^ use v2 upload + -> StackageServer + -> Settings -> Manager -> IO () +finallyUpload useV2 server settings@Settings{..} man = do + putStrLn "Uploading bundle to Stackage Server" + + token <- getStackageAuthToken + + if useV2 + then do + res <- flip uploadBundleV2 man UploadBundleV2 + { ub2Server = server + , ub2AuthToken = token + , ub2Bundle = bundleDest + } + putStrLn $ "New snapshot available at: " ++ res + else do + now <- epochTime + let ghcVer = display $ siGhcVersion $ bpSystemInfo plan + (ident, mloc) <- flip uploadBundle man $ setArgs ghcVer def + { ubContents = serverBundle now (title ghcVer) slug plan + , ubAuthToken = token + } + putStrLn $ "New ident: " ++ unSnapshotIdent ident + forM_ mloc $ \loc -> + putStrLn $ "Track progress at: " ++ loc + + putStrLn "Uploading docs to Stackage Server" + res1 <- tryAny $ uploadDocs UploadDocs + { udServer = def + , udAuthToken = token + , udDocs = pbDocDir pb + , udSnapshot = ident + } man + putStrLn $ "Doc upload response: " ++ tshow res1 + + putStrLn "Uploading doc map" + tryAny (uploadDocMap UploadDocMap + { udmServer = def + , udmAuthToken = token + , udmSnapshot = ident + , udmDocDir = pbDocDir pb + , udmPlan = plan + } man) >>= print + + postBuild `catchAny` print + + ecreds <- tryIO $ readFile "/hackage-creds" + case map encodeUtf8 $ words $ decodeUtf8 $ either (const "") id ecreds of + [username, password] -> do + putStrLn "Uploading as Hackage distro" + res2 <- uploadHackageDistroNamed distroName plan username password man + putStrLn $ "Distro upload response: " ++ tshow res2 + _ -> putStrLn "No creds found, skipping Hackage distro upload" + where + pb = getPerformBuild (error "finallyUpload.buildFlags") settings diff --git a/Stackage/CorePackages.hs b/Stackage/CorePackages.hs new file mode 100644 --- /dev/null +++ b/Stackage/CorePackages.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +module Stackage.CorePackages + ( getCorePackages + , getCoreExecutables + , getGhcVersion + ) where + +import qualified Data.Text as T +import Filesystem (listDirectory) +import Stackage.Prelude +import System.Directory (findExecutable) + +-- | Get a @Map@ of all of the core packages. Core packages are defined as +-- packages which ship with GHC itself. +-- +-- Precondition: GHC global package database has only core packages, and GHC +-- ships with just a single version of each packages. +getCorePackages :: IO (Map PackageName Version) +getCorePackages = + withCheckedProcess cp $ \ClosedStream src Inherited -> + src $$ decodeUtf8C =$ linesUnboundedC =$ foldMapMC parsePackage + where + cp = proc "ghc-pkg" ["--no-user-package-conf", "list"] + parsePackage t + | ":" `isInfixOf` t = return mempty + | Just p <- stripSuffix "-" p' = singletonMap + <$> simpleParse p + <*> simpleParse v + | otherwise = return mempty + where + (p', v) = T.breakOnEnd "-" $ dropParens $ T.strip t + + dropParens s + | length s > 2 && headEx s == '(' && lastEx s == ')' = + initEx $ tailEx s + | otherwise = s + +-- | A list of executables that are shipped with GHC. +getCoreExecutables :: IO (Set ExeName) +getCoreExecutables = do + mfp <- findExecutable "ghc" + dir <- + case mfp of + Nothing -> error "No ghc executable found on PATH" + Just fp -> return $ directory $ fpFromString fp + (setFromList . map (ExeName . fpToText . filename)) <$> listDirectory dir + +getGhcVersion :: IO Version +getGhcVersion = do + withCheckedProcess (proc "ghc" ["--numeric-version"]) $ + \ClosedStream src Inherited -> + (src $$ decodeUtf8C =$ foldC) >>= simpleParse diff --git a/Stackage/GhcPkg.hs b/Stackage/GhcPkg.hs new file mode 100644 --- /dev/null +++ b/Stackage/GhcPkg.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +-- | General commands related to ghc-pkg. + +module Stackage.GhcPkg + ( setupPackageDatabase + ) where + +import Data.Conduit +import qualified Data.Conduit.List as CL +import Data.Conduit.Process +import qualified Data.Conduit.Text as CT +import Data.Maybe +import Data.Text (Text) +import qualified Data.Text as T +import Distribution.Compat.ReadP +import Distribution.Package +import Distribution.Text (parse) +import Filesystem.Path.CurrentOS (FilePath) +import qualified Filesystem.Path.CurrentOS as FP +import Data.Map (Map) +import Data.Version (Version) +import Stackage.Prelude +import Filesystem (removeTree) + +setupPackageDatabase + :: Maybe FilePath -- ^ database location, Nothing if using global DB + -> FilePath -- ^ documentation root + -> (ByteString -> IO ()) -- ^ logging + -> Map PackageName Version -- ^ packages and versions to be installed + -> (PackageIdentifier -> IO ()) -- ^ callback to be used when unregistering a package + -> IO (Set PackageName) -- ^ packages remaining in the database after cleanup +setupPackageDatabase mdb docDir log' toInstall onUnregister = do + registered1 <- getRegisteredPackages flags + forM_ registered1 $ \pi@(PackageIdentifier name version) -> + case lookup name toInstall of + Just version' | version /= version' -> unregisterPackage log' onUnregister docDir flags pi + _ -> return () + broken <- getBrokenPackages flags + forM_ broken $ unregisterPackage log' onUnregister docDir flags + foldMap (\(PackageIdentifier name _) -> singletonSet name) + <$> getRegisteredPackages flags + where + flags = ghcPkgFlags mdb + +ghcPkgFlags :: Maybe FilePath -> [String] +ghcPkgFlags mdb = + "--no-user-package-db" : + case mdb of + Nothing -> ["--global"] + Just fp -> ["--package-db=" ++ fpToString fp] + +-- | Get broken packages. +getBrokenPackages :: [String] -> IO [PackageIdentifier] +getBrokenPackages flags = do + (_,ps) <- sourceProcessWithConsumer + (proc + "ghc-pkg" + ("check" : "--simple-output" : flags)) + (CT.decodeUtf8 $= CT.lines $= CL.consume) + return (mapMaybe parsePackageIdent (T.words (T.unlines ps))) + +-- | Get available packages. +getRegisteredPackages :: [String] -> IO [PackageIdentifier] +getRegisteredPackages flags = do + (_,ps) <- sourceProcessWithConsumer + (proc + "ghc-pkg" + ("list" : "--simple-output" : flags)) + (CT.decodeUtf8 $= CT.lines $= CL.consume) + return (mapMaybe parsePackageIdent (T.words (T.unlines ps))) + +-- | Parse a package identifier: foo-1.2.3 +parsePackageIdent :: Text -> Maybe PackageIdentifier +parsePackageIdent = fmap fst . + listToMaybe . + filter (null . snd) . + readP_to_S parse . T.unpack + +-- | Unregister a package. +unregisterPackage :: (ByteString -> IO ()) -- ^ log func + -> (PackageIdentifier -> IO ()) -- ^ callback to be used when unregistering a package + -> FilePath -- ^ doc directory + -> [String] -> PackageIdentifier -> IO () +unregisterPackage log' onUnregister docDir flags ident@(PackageIdentifier name _) = do + log' $ "Unregistering " ++ encodeUtf8 (display ident) ++ "\n" + onUnregister ident + + -- Delete libraries + sourceProcessWithConsumer + (proc "ghc-pkg" ("describe" : flags ++ [unpack $ display ident])) + (CT.decodeUtf8 + $= CT.lines + $= CL.mapMaybe parseLibraryDir + $= CL.mapM_ (void . tryIO . removeTree)) + + void (readProcessWithExitCode + "ghc-pkg" + ("unregister": flags ++ ["--force", unpack $ display name]) + "") + + void $ tryIO $ removeTree $ docDir fpFromText (display ident) + where + parseLibraryDir = fmap fpFromText . stripPrefix "library-dirs: " diff --git a/Stackage/GithubPings.hs b/Stackage/GithubPings.hs new file mode 100644 --- /dev/null +++ b/Stackage/GithubPings.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} +module Stackage.GithubPings + ( getGithubPings + ) where + +import Distribution.PackageDescription +import Stackage.BuildConstraints +import Stackage.Prelude + +-- | Determine accounts to be pinged on Github based on various metadata in the +-- package description. +getGithubPings :: BuildConstraints -- ^ for mapping to pingees + -> GenericPackageDescription -> Set Text +getGithubPings bc gpd = + foldMap (\(pack -> name) -> fromMaybe (singletonSet name) (lookup name (bcGithubUsers bc))) $ + goHomepage (homepage $ packageDescription gpd) ++ + concatMap goRepo (sourceRepos $ packageDescription gpd) + where + goHomepage t = do + prefix <- + [ "http://github.com/" + , "https://github.com/" + , "git://github.com/" + , "git@github.com:" + ] + t' <- maybeToList $ stripPrefix prefix t + let t'' = takeWhile (/= '/') t' + guard $ not $ null t'' + return t'' + + goRepo sr = + case (repoType sr, repoLocation sr) of + (Just Git, Just s) -> goHomepage s + _ -> [] diff --git a/Stackage/InstallBuild.hs b/Stackage/InstallBuild.hs new file mode 100644 --- /dev/null +++ b/Stackage/InstallBuild.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Stackage.InstallBuild + ( InstallFlags (..) + , BuildPlanSource (..) + , installBuild + ) where + +import qualified Codec.Archive.Tar as Tar +import qualified Codec.Compression.GZip as GZip +import qualified Data.Yaml as Yaml +import Network.HTTP.Client +import Network.HTTP.Client.TLS (tlsManagerSettings) +import Stackage.BuildPlan +import Stackage.CheckBuildPlan +import Stackage.PerformBuild +import Stackage.Prelude +import System.IO (BufferMode (LineBuffering), hSetBuffering) + +-- | Flags passed in from the command line. +data InstallFlags = InstallFlags + { ifPlanSource :: !BuildPlanSource + , ifInstallDest :: !FilePath + , ifLogDir :: !(Maybe FilePath) + , ifJobs :: !Int + , ifGlobalInstall :: !Bool + , ifEnableTests :: !Bool + , ifEnableHaddock :: !Bool + , ifEnableLibProfiling :: !Bool + , ifEnableExecDyn :: !Bool + , ifVerbose :: !Bool + , ifSkipCheck :: !Bool + , ifBuildHoogle :: !Bool + } deriving (Show) + +-- | Source for build plan. +data BuildPlanSource = BPSBundleWeb String + | BPSFile FilePath + deriving (Show) + +getPerformBuild :: BuildPlan -> InstallFlags -> PerformBuild +getPerformBuild plan InstallFlags{..} = + PerformBuild + { pbPlan = plan + , pbInstallDest = ifInstallDest + , pbLogDir = fromMaybe (ifInstallDest "logs") ifLogDir + , pbLog = hPut stdout + , pbJobs = ifJobs + , pbGlobalInstall = ifGlobalInstall + , pbEnableTests = ifEnableTests + , pbEnableHaddock = ifEnableHaddock + , pbEnableLibProfiling = ifEnableLibProfiling + , pbEnableExecDyn = ifEnableExecDyn + , pbVerbose = ifVerbose + , pbAllowNewer = ifSkipCheck + , pbBuildHoogle = ifBuildHoogle + } + +-- | Install stackage from an existing build plan. +installBuild :: InstallFlags -> IO () +installBuild installFlags@InstallFlags{..} = do + hSetBuffering stdout LineBuffering + + putStrLn $ "Loading build plan" + plan <- case ifPlanSource of + BPSBundleWeb url -> withManager tlsManagerSettings $ \man -> do + req <- parseUrl url + res <- httpLbs req man + planBSL <- getPlanEntry $ Tar.read $ GZip.decompress (responseBody res) + decodeBuildPlan planBSL + BPSFile path -> Yaml.decodeFileEither (fpToString path) >>= either throwM return + + if ifSkipCheck + then putStrLn "Skipping build plan check" + else do + putStrLn "Checking build plan" + checkBuildPlan plan + + putStrLn "Performing build" + performBuild (getPerformBuild plan installFlags) >>= mapM_ putStrLn + + where + getPlanEntry Tar.Done = throwIO NoBuildPlanException + getPlanEntry (Tar.Fail e) = throwIO e + getPlanEntry (Tar.Next entry entries) + | Tar.entryPath entry == "build-plan.yaml" = + case Tar.entryContent entry of + Tar.NormalFile bs _ -> return bs + _ -> throwIO NoBuildPlanException + | otherwise = getPlanEntry entries + + decodeBuildPlan = + either throwIO return . Yaml.decodeEither' . toStrict + +data InstallBuildException = NoBuildPlanException + deriving (Typeable) +instance Exception InstallBuildException +instance Show InstallBuildException where + show NoBuildPlanException = "Bundle has missing or invalid build-plan.yaml" diff --git a/Stackage/PackageDescription.hs b/Stackage/PackageDescription.hs new file mode 100644 --- /dev/null +++ b/Stackage/PackageDescription.hs @@ -0,0 +1,200 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +-- | Manipulate @GenericPackageDescription@ from Cabal into something more +-- useful for us. +module Stackage.PackageDescription + ( SimpleDesc (..) + , toSimpleDesc + , CheckCond (..) + , Component (..) + , DepInfo (..) + ) where + +import Control.Monad.Writer.Strict (MonadWriter, execWriterT, + tell) +import Data.Aeson +import qualified Data.Map as Map +import Distribution.Compiler (CompilerFlavor) +import Distribution.Package (Dependency (..)) +import Distribution.PackageDescription +import Distribution.System (Arch, OS) +import Stackage.Prelude + +data Component = CompLibrary + | CompExecutable + | CompTestSuite + | CompBenchmark + deriving (Show, Read, Eq, Ord, Enum, Bounded) + +compToText :: Component -> Text +compToText CompLibrary = "library" +compToText CompExecutable = "executable" +compToText CompTestSuite = "test-suite" +compToText CompBenchmark = "benchmark" + +instance ToJSON Component where + toJSON = toJSON . compToText +instance FromJSON Component where + parseJSON = withText "Component" $ \t -> maybe + (fail $ "Invalid component: " ++ unpack t) + return + (lookup t comps) + where + comps = asHashMap $ mapFromList $ map (compToText &&& id) [minBound..maxBound] + +data DepInfo = DepInfo + { diComponents :: Set Component + , diRange :: VersionRange + } + deriving (Show, Eq) + +instance Semigroup DepInfo where + DepInfo a x <> DepInfo b y = DepInfo + (a <> b) + (intersectVersionRanges x y) +instance ToJSON DepInfo where + toJSON DepInfo {..} = object + [ "components" .= diComponents + , "range" .= display diRange + ] +instance FromJSON DepInfo where + parseJSON = withObject "DepInfo" $ \o -> do + diComponents <- o .: "components" + diRange <- o .: "range" >>= either (fail . show) return . simpleParse + return DepInfo {..} + +-- | A simplified package description that tracks: +-- +-- * Package dependencies +-- +-- * Build tool dependencies +-- +-- * Provided executables +-- +-- It has fully resolved all conditionals +data SimpleDesc = SimpleDesc + { sdPackages :: Map PackageName DepInfo + , sdTools :: Map ExeName DepInfo + , sdProvidedExes :: Set ExeName + , sdModules :: Set Text + -- ^ modules exported by the library + } + deriving (Show, Eq) +instance Monoid SimpleDesc where + mempty = SimpleDesc mempty mempty mempty mempty + mappend (SimpleDesc a b c d) (SimpleDesc w x y z) = SimpleDesc + (unionWith (<>) a w) + (unionWith (<>) b x) + (c ++ y) + (d ++ z) +instance ToJSON SimpleDesc where + toJSON SimpleDesc {..} = object + [ "packages" .= Map.mapKeysWith const unPackageName sdPackages + , "tools" .= Map.mapKeysWith const unExeName sdTools + , "provided-exes" .= sdProvidedExes + , "modules" .= sdModules + ] +instance FromJSON SimpleDesc where + parseJSON = withObject "SimpleDesc" $ \o -> do + sdPackages <- Map.mapKeysWith const mkPackageName <$> (o .: "packages") + sdTools <- Map.mapKeysWith const ExeName <$> (o .: "tools") + sdProvidedExes <- o .: "provided-exes" + sdModules <- o .: "modules" + return SimpleDesc {..} + +-- | Convert a 'GenericPackageDescription' into a 'SimpleDesc' by following the +-- constraints in the provided 'CheckCond'. +toSimpleDesc :: MonadThrow m + => CheckCond + -> GenericPackageDescription + -> m SimpleDesc +toSimpleDesc cc gpd = execWriterT $ do + forM_ (condLibrary gpd) $ tellTree cc CompLibrary libBuildInfo getModules + forM_ (condExecutables gpd) $ tellTree cc CompExecutable buildInfo noModules . snd + tell mempty { sdProvidedExes = setFromList + $ map (fromString . fst) + $ condExecutables gpd + } + when (ccIncludeTests cc) $ forM_ (condTestSuites gpd) + $ tellTree cc CompTestSuite testBuildInfo noModules . snd + when (ccIncludeBenchmarks cc) $ forM_ (condBenchmarks gpd) + $ tellTree cc CompBenchmark benchmarkBuildInfo noModules . snd + where + noModules = const mempty + getModules = setFromList . map display . exposedModules + +-- | Convert a single CondTree to a 'SimpleDesc'. +tellTree :: (MonadWriter SimpleDesc m, MonadThrow m) + => CheckCond + -> Component + -> (a -> BuildInfo) + -> (a -> Set Text) -- ^ get module names + -> CondTree ConfVar [Dependency] a + -> m () +tellTree cc component getBI getModules = + loop + where + loop (CondNode dat deps comps) = do + tell mempty + { sdPackages = unionsWith (<>) $ flip map deps + $ \(Dependency x y) -> singletonMap x DepInfo + { diComponents = singletonSet component + , diRange = simplifyVersionRange y + } + , sdTools = unionsWith (<>) $ flip map (buildTools $ getBI dat) + $ \(Dependency name range) -> singletonMap + -- In practice, cabal files refer to the exe name, not the + -- package name. + (ExeName $ unPackageName name) + DepInfo + { diComponents = singletonSet component + , diRange = simplifyVersionRange range + } + , sdModules = getModules dat + } + forM_ comps $ \(cond, ontrue, onfalse) -> do + b <- checkCond cc cond + if b + then loop ontrue + else maybe (return ()) loop onfalse + +-- | Resolve a condition to a boolean based on the provided 'CheckCond'. +checkCond :: MonadThrow m => CheckCond -> Condition ConfVar -> m Bool +checkCond CheckCond {..} cond0 = + go cond0 + where + go (Var (OS os)) = return $ os == ccOS + go (Var (Arch arch)) = return $ arch == ccArch + go (Var (Flag flag)) = + case lookup flag ccFlags of + Nothing -> throwM $ FlagNotDefined ccPackageName flag cond0 + Just b -> return b + go (Var (Impl flavor range)) = return + $ flavor == ccCompilerFlavor + && ccCompilerVersion `withinRange` range + go (Lit b) = return b + go (CNot c) = not `liftM` go c + go (CAnd x y) = (&&) `liftM` go x `ap` go y + go (COr x y) = (||) `liftM` go x `ap` go y + +data CheckCondException = FlagNotDefined PackageName FlagName (Condition ConfVar) + deriving (Show, Typeable) +instance Exception CheckCondException + +data CheckCond = CheckCond + { ccPackageName :: PackageName -- for debugging only + , ccOS :: OS + , ccArch :: Arch + , ccFlags :: Map FlagName Bool + , ccCompilerFlavor :: CompilerFlavor + , ccCompilerVersion :: Version + , ccIncludeTests :: Bool + , ccIncludeBenchmarks :: Bool + } diff --git a/Stackage/PackageIndex.hs b/Stackage/PackageIndex.hs new file mode 100644 --- /dev/null +++ b/Stackage/PackageIndex.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ViewPatterns #-} +-- | Dealing with the 00-index file and all its cabal files. +module Stackage.PackageIndex + ( sourcePackageIndex + , UnparsedCabalFile (..) + , getLatestDescriptions + ) where + +import qualified Codec.Archive.Tar as Tar +import Data.Conduit.Lazy (MonadActive, + lazyConsume) +import qualified Data.Text as T +import Distribution.PackageDescription (package, + packageDescription) +import Distribution.PackageDescription.Parse (ParseResult (..), + parsePackageDescription) +import Distribution.ParseUtils (PError) +import Stackage.Prelude +import System.Directory (getAppUserDataDirectory) + +-- | Name of the 00-index.tar downloaded from Hackage. +getPackageIndexPath :: MonadIO m => m FilePath +getPackageIndexPath = liftIO $ do + c <- getCabalRoot + configLines <- runResourceT $ sourceFile (c "config") + $$ decodeUtf8C + =$ linesUnboundedC + =$ concatMapC getRemoteCache + =$ sinkList + case configLines of + [x] -> return $ x "hackage.haskell.org" "00-index.tar" + [] -> error $ "No remote-repo-cache found in Cabal config file" + _ -> error $ "Multiple remote-repo-cache entries found in Cabal config file" + where + getCabalRoot :: IO FilePath + getCabalRoot = fpFromString <$> getAppUserDataDirectory "cabal" + + getRemoteCache s = do + ("remote-repo-cache", stripPrefix ":" -> Just v) <- Just $ break (== ':') s + Just $ fpFromText $ T.strip v + +-- | A cabal file with name and version parsed from the filepath, and the +-- package description itself ready to be parsed. It's left in unparsed form +-- for efficiency. +data UnparsedCabalFile = UnparsedCabalFile + { ucfName :: PackageName + , ucfVersion :: Version + , ucfParse :: forall m. MonadThrow m => m GenericPackageDescription + } + +-- | Stream all of the cabal files from the 00-index tar file. +sourcePackageIndex :: (MonadThrow m, MonadResource m, MonadActive m, MonadBaseControl IO m) + => Producer m UnparsedCabalFile +sourcePackageIndex = do + fp <- getPackageIndexPath + -- yay for the tar package. Use lazyConsume instead of readFile to get some + -- kind of resource protection + lbs <- lift $ fromChunks <$> lazyConsume (sourceFile fp) + loop (Tar.read lbs) + where + loop (Tar.Next e es) = goE e >> loop es + loop Tar.Done = return () + loop (Tar.Fail e) = throwM e + + goE e + | Just front <- stripSuffix ".cabal" $ pack $ Tar.entryPath e + , Tar.NormalFile lbs _size <- Tar.entryContent e = do + (name, version) <- parseNameVersion front + yield UnparsedCabalFile + { ucfName = name + , ucfVersion = version + , ucfParse = goContent (Tar.entryPath e) name version lbs + } + | otherwise = return () + + goContent fp name version lbs = + case parsePackageDescription $ unpack $ decodeUtf8 lbs of + ParseFailed e -> throwM $ CabalParseException (fpFromString fp) e + ParseOk _warnings gpd -> do + let pd = packageDescription gpd + PackageIdentifier name' version' = package pd + when (name /= name' || version /= version') $ + throwM $ MismatchedNameVersion (fpFromString fp) + name name' version version' + return gpd + + parseNameVersion t1 = do + let (p', t2) = break (== '/') $ T.replace "\\" "/" t1 + p <- simpleParse p' + t3 <- maybe (throwM $ InvalidCabalPath t1 "no slash") return + $ stripPrefix "/" t2 + let (v', t4) = break (== '/') t3 + v <- simpleParse v' + when (t4 /= cons '/' p') $ throwM $ InvalidCabalPath t1 $ "Expected at end: " ++ p' + return (p, v) + +data InvalidCabalPath = InvalidCabalPath Text Text + deriving (Show, Typeable) +instance Exception InvalidCabalPath + +data CabalParseException = CabalParseException FilePath PError + | MismatchedNameVersion FilePath PackageName PackageName Version Version + deriving (Show, Typeable) +instance Exception CabalParseException + +-- | Get all of the latest descriptions for name/version pairs matching the +-- given criterion. +getLatestDescriptions :: MonadIO m + => (PackageName -> Version -> Bool) + -> (GenericPackageDescription -> IO desc) + -> m (Map PackageName desc) +getLatestDescriptions f parseDesc = liftIO $ do + m <- runResourceT $ sourcePackageIndex $$ filterC f' =$ foldlC add mempty + forM m $ \ucf -> liftIO $ ucfParse ucf >>= parseDesc + where + f' ucf = f (ucfName ucf) (ucfVersion ucf) + add m ucf = + case lookup name m of + Just ucf' | ucfVersion ucf < ucfVersion ucf' -> m + _ -> insertMap name ucf m + where + name = ucfName ucf diff --git a/Stackage/PerformBuild.hs b/Stackage/PerformBuild.hs new file mode 100644 --- /dev/null +++ b/Stackage/PerformBuild.hs @@ -0,0 +1,560 @@ +-- | 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 #-} +module Stackage.PerformBuild + ( performBuild + , PerformBuild (..) + , BuildException (..) + , pbDocDir + ) where + +import Control.Concurrent.Async (async) +import Control.Concurrent.STM.TSem +import Control.Monad.Writer.Strict (execWriter, tell) +import qualified Data.Map as Map +import Data.NonNull (fromNullable) +import Filesystem (canonicalizePath, createTree, + getWorkingDirectory, isDirectory, + removeTree, rename, isFile, removeFile) +import Filesystem.Path (parent) +import qualified Filesystem.Path as F +import Stackage.BuildConstraints +import Stackage.BuildPlan +import Stackage.GhcPkg +import Stackage.PackageDescription +import Stackage.Prelude hiding (pi) +import System.Directory (findExecutable) +import System.Environment (getEnvironment) +import System.IO (IOMode (WriteMode), + openBinaryFile) +import System.IO.Temp (withSystemTempDirectory) + +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 + , ": " + , 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 + , pbEnableHaddock :: Bool + , pbEnableLibProfiling :: Bool + , pbEnableExecDyn :: Bool + , pbVerbose :: Bool + , pbAllowNewer :: Bool + -- ^ Pass --allow-newer to cabal configure + , pbBuildHoogle :: Bool + -- ^ Should we build Hoogle database? + -- + -- May be disabled due to: https://ghc.haskell.org/trac/ghc/ticket/9921 + } + +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 $ Map.keys $ 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)) + +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, pbDocDir :: PerformBuild -> FilePath +pbBinDir pb = pbInstallDest pb "bin" +pbLibDir pb = pbInstallDest pb "lib" +pbDataDir pb = pbInstallDest pb "share" +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 = cwd pbInstallDest pb + , pbLogDir = cwd pbLogDir pb + } + +performBuild' :: PerformBuild -> IO [Text] +performBuild' pb@PerformBuild {..} = withBuildDir $ \builddir -> do + -- First make sure to fetch all of the dependencies... just in case Hackage + -- has an outage. Don't feel like wasting hours of CPU time. + pbLog $ encodeUtf8 "Pre-fetching all packages\n" + let toDownload = flip map (mapToList $ bpPackages pbPlan) + $ \(name, plan) -> unpack $ concat + [ display name + , "-" + , display $ ppVersion plan + ] + withCheckedProcess + (proc "cabal" + $ "fetch" + : "--no-dependencies" + : toDownload) + $ \ClosedStream Inherited Inherited -> return () + + let removeTree' fp = whenM (isDirectory fp) (removeTree fp) + removeTree' pbLogDir + + forM_ (pbDatabase pb) $ \db -> + unlessM (isFile $ db "package.cache") $ do + createTree $ parent db + withCheckedProcess (proc "ghc-pkg" ["init", fpToString 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 $ bpPackages pbPlan + packageMap <- fmap fold $ forM (mapToList $ bpPackages pbPlan) + $ \(name, plan) -> do + let piPlan = plan + piName = name + piResult <- newEmptyTMVarIO + return $ singletonMap name PackageInfo {..} + + errsVar <- newTVarIO mempty + warningsVar <- newTVarIO id + mutex <- newMVar () + env <- getEnvironment + haddockFiles <- newTVarIO mempty + + registeredPackages <- setupPackageDatabase + (pbDatabase pb) + (pbDocDir pb) + pbLog + (ppVersion <$> bpPackages pbPlan) + (deletePreviousResults pb) + + forM_ packageMap $ \pi -> void $ 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", fpToString db):)) + (pbDatabase pb) + (filter allowedEnv $ map fixEnv env) + , sbHaddockFiles = haddockFiles + } + + 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 . fpFromString) + + fixEnv (p, x) + -- Thank you Windows having case-insensitive environment variables... + | toUpper p == "PATH" = (p, fpToString (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 + } + +singleBuild :: PerformBuild + -> Set PackageName -- ^ registered packages + -> SingleBuild -> IO () +singleBuild pb@PerformBuild {..} registeredPackages SingleBuild {..} = + withCounter sbActive + $ handle updateErrs + $ (`finally` void (atomically $ tryPutTMVar (piResult sbPackageInfo) False)) + $ inner + where + libComps = setFromList [CompLibrary, CompExecutable] + testComps = insertSet CompTestSuite libComps + inner = do + let wfd comps = + waitForDeps sbToolMap sbPackageMap comps pbPlan sbPackageInfo + . withTSem sbSem + withUnpacked <- wfd libComps buildLibrary + + wfd testComps (runTests withUnpacked) + + pname = piName sbPackageInfo + pident = PackageIdentifier pname (ppVersion $ piPlan sbPackageInfo) + name = display pname + namever = concat + [ name + , "-" + , display $ ppVersion $ piPlan sbPackageInfo + ] + + runIn wdir getOutH cmd args = do + outH <- getOutH + withCheckedProcess (cp outH) $ \ClosedStream UseProvidedHandle UseProvidedHandle -> + (return () :: IO ()) + where + cp outH = (proc (unpack $ asText cmd) (map (unpack . asText) args)) + { cwd = Just $ fpToString wdir + , std_out = UseHandle outH + , std_err = UseHandle outH + , env = Just sbModifiedEnv + } + runParent = runIn sbBuildDir + runChild = runIn childDir + childDir = sbBuildDir fpFromText namever + + log' t = do + i <- readTVarIO sbActive + errs <- readTVarIO sbErrsVar + pbLog $ encodeUtf8 $ concat + [ t + , " (pending: " + , tshow i + , ", failures: " + , tshow $ length errs + , ")\n" + ] + libOut = pbLogDir fpFromText namever "build.out" + testOut = pbLogDir fpFromText namever "test.out" + testRunOut = pbLogDir fpFromText namever "test-run.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 fp + h <- openBinaryFile (fpToString fp) WriteMode + writeIORef ref $ Just h + return h + + inner' getH `finally` cleanup + + configArgs = ($ []) $ execWriter $ do + when pbAllowNewer $ tell' "--allow-newer" + tell' "--package-db=clear" + tell' "--package-db=global" + forM_ (pbDatabase pb) $ \db -> tell' $ "--package-db=" ++ fpToText db + tell' $ "--libdir=" ++ fpToText (pbLibDir pb) + tell' $ "--bindir=" ++ fpToText (pbBinDir pb) + tell' $ "--datadir=" ++ fpToText (pbDataDir pb) + tell' $ "--docdir=" ++ fpToText (pbDocDir pb) + tell' $ "--flags=" ++ flags + when (pbEnableLibProfiling && pcEnableLibProfile) $ + tell' "--enable-library-profiling" + when pbEnableExecDyn $ tell' "--enable-executable-dynamic" + 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 + + buildLibrary = wf libOut $ \getOutH -> do + let run a b = do when pbVerbose $ log' (unwords (a : b)) + runChild getOutH a b + + isUnpacked <- newIORef False + let withUnpacked inner = do + unlessM (readIORef isUnpacked) $ do + log' $ "Unpacking " ++ namever + runParent getOutH "cabal" ["unpack", namever] + writeIORef isUnpacked True + inner + + isConfiged <- newIORef False + let withConfiged inner = withUnpacked $ do + unlessM (readIORef isConfiged) $ do + log' $ "Configuring " ++ namever + run "cabal" $ "configure" : configArgs + writeIORef isConfiged True + inner + + prevBuildResult <- getPreviousResult pb Build pident + unless (prevBuildResult == PRSuccess) $ withConfiged $ do + assert (pname `notMember` registeredPackages) $ do + deletePreviousResults pb pident + + log' $ "Building " ++ namever + run "cabal" ["build"] + + log' $ "Copying/registering " ++ namever + run "cabal" ["copy"] + withMVar sbRegisterMutex $ const $ + run "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) + when needHaddock $ withConfiged $ do + log' $ "Haddocks " ++ namever + hfs <- readTVarIO sbHaddockFiles + let hfsOpts = flip map (mapToList hfs) $ \(pkgVer, hf) -> concat + [ "--haddock-options=--read-interface=" + , "../" + , pkgVer + , "/," + , fpToText hf + ] + args = ($ hfsOpts) $ execWriter $ do + let tell' x = tell (x:) + tell' "haddock" + tell' "--hyperlink-source" + tell' "--html" + when pbBuildHoogle $ tell' "--hoogle" + tell' "--html-location=../$pkg-$version/" + + eres <- tryAny $ run "cabal" args + + forM_ eres $ \() -> do + renameOrCopy + (childDir "dist" "doc" "html" fpFromText name) + (pbDocDir pb fpFromText namever) + + enewPath <- tryIO + $ canonicalizePath + $ pbDocDir pb + fpFromText namever + fpFromText name <.> "haddock" + case enewPath of + Left e -> warn $ tshow e + Right newPath -> atomically + $ modifyTVar sbHaddockFiles + $ insertMap namever 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 + let run = runChild getOutH + + prevTestResult <- getPreviousResult pb Test pident + let needTest = pbEnableTests + && checkPrevResult prevTestResult pcTests + when needTest $ withUnpacked $ do + log' $ "Test configure " ++ namever + run "cabal" $ "configure" : "--enable-tests" : configArgs + + eres <- tryAny $ do + log' $ "Test build " ++ namever + run "cabal" ["build"] + + log' $ "Test run " ++ namever + run "cabal" ["test", "--log=" ++ fpToText testRunOut] + + 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 () + + warn t = atomically $ modifyTVar sbWarningsVar (. (t:)) + + updateErrs exc = do + log' $ concat + [ display (piName sbPackageInfo) + , ": " + , tshow exc + ] + atomically $ modifyTVar sbErrsVar $ insertMap (piName sbPackageInfo) exc' + where + exc' = + case fromException exc of + Just bf -> bf + Nothing -> BuildFailureException exc + +renameOrCopy :: FilePath -> FilePath -> IO () +renameOrCopy src dest = rename src 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 + src <- canonicalizePath + (parent (fpFromString ghc) "../share/doc/ghc/html/libraries") + copyDir src docdir + +------------- Previous results + +-- | The previous actions that can be run +data ResultType = Build | Haddock | Test + 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 fp + inner fp + where + fp = pbPrevResDir pb fpFromString (show rt) fpFromText (display ident) + +successBS, failureBS :: ByteString +successBS = "success" +failureBS = "failure" + +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 + +savePreviousResult :: PerformBuild -> ResultType -> PackageIdentifier -> Bool -> IO () +savePreviousResult pb rt ident res = + withPRPath pb rt ident $ \fp -> 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 fp diff --git a/Stackage/Prelude.hs b/Stackage/Prelude.hs new file mode 100644 --- /dev/null +++ b/Stackage/Prelude.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +module Stackage.Prelude + ( module X + , module Stackage.Prelude + ) where + +import ClassyPrelude.Conduit as X +import Data.Aeson (FromJSON, ToJSON) +import Data.Conduit.Process as X +import qualified Data.Map as Map +import Data.Typeable (TypeRep, typeOf) +import Distribution.Package as X (PackageIdentifier (..), PackageName (PackageName)) +import Distribution.PackageDescription as X (FlagName (..), GenericPackageDescription) +import qualified Distribution.Text as DT +import Distribution.Version as X (Version (..), + VersionRange) +import Distribution.Version as X (withinRange) +import qualified Distribution.Version as C +import Filesystem (createTree) +import Filesystem.Path (parent) +import qualified Filesystem.Path as F + +unPackageName :: PackageName -> Text +unPackageName (PackageName str) = pack str + +unFlagName :: FlagName -> Text +unFlagName (FlagName str) = pack str + +mkPackageName :: Text -> PackageName +mkPackageName = PackageName . unpack + +mkFlagName :: Text -> FlagName +mkFlagName = FlagName . unpack + +display :: DT.Text a => a -> Text +display = fromString . DT.display + +simpleParse :: (MonadThrow m, DT.Text a, Typeable a) => Text -> m a +simpleParse orig = withTypeRep $ \rep -> + case DT.simpleParse str of + Nothing -> throwM (ParseFailedException rep (pack str)) + Just v -> return v + where + str = unpack orig + + withTypeRep :: Typeable a => (TypeRep -> m a) -> m a + withTypeRep f = + res + where + res = f (typeOf (unwrap res)) + + unwrap :: m a -> a + unwrap _ = error "unwrap" + +data ParseFailedException = ParseFailedException TypeRep Text + deriving (Show, Typeable) +instance Exception ParseFailedException + +newtype Maintainer = Maintainer { unMaintainer :: Text } + deriving (Show, Eq, Ord, Hashable, ToJSON, FromJSON, IsString) + +-- | Name of an executable. +newtype ExeName = ExeName { unExeName :: Text } + deriving (Show, Eq, Ord, Hashable, ToJSON, FromJSON, IsString) + +intersectVersionRanges :: VersionRange -> VersionRange -> VersionRange +intersectVersionRanges x y = C.simplifyVersionRange $ C.intersectVersionRanges x y + +-- | There seems to be a bug in Cabal where serializing and deserializing +-- version ranges winds up with different representations. So we have a +-- super-simplifier to deal with that. +simplifyVersionRange :: VersionRange -> VersionRange +simplifyVersionRange vr = + fromMaybe (assert False vr') $ simpleParse $ display vr' + where + vr' = C.simplifyVersionRange vr + +-- | Topologically sort so that items with dependencies occur after those +-- dependencies. +topologicalSort :: (Ord key, Show key, MonadThrow m, Typeable key) + => (value -> finalValue) + -> (value -> Set key) -- ^ deps + -> Map key value + -> m (Vector (key, finalValue)) +topologicalSort toFinal toDeps = + loop id . mapWithKey removeSelfDeps . fmap (toDeps &&& toFinal) + where + removeSelfDeps k (deps, final) = (deleteSet k deps, final) + loop front toProcess | null toProcess = return $ pack $ front [] + loop front toProcess + | null noDeps = throwM $ NoEmptyDeps (map fst toProcess') + | otherwise = loop (front . noDeps') (mapFromList hasDeps) + where + toProcess' = fmap (first removeUnavailable) toProcess + allKeys = Map.keysSet toProcess + removeUnavailable = asSet . setFromList . filter (`member` allKeys) . setToList + (noDeps, hasDeps) = partition (null . fst . snd) $ mapToList toProcess' + noDeps' = (map (second snd) noDeps ++) + +data TopologicalSortException key = NoEmptyDeps (Map key (Set key)) + deriving (Show, Typeable) +instance (Show key, Typeable key) => Exception (TopologicalSortException key) + +copyDir :: FilePath -> FilePath -> IO () +copyDir src dest = + runResourceT $ sourceDirectoryDeep False src $$ mapM_C go + where + src' = src "" + go fp = forM_ (F.stripPrefix src' fp) $ \suffix -> do + let dest' = dest suffix + liftIO $ createTree $ parent dest' + sourceFile fp $$ (sinkFile dest' :: Sink ByteString (ResourceT IO) ()) diff --git a/Stackage/ServerBundle.hs b/Stackage/ServerBundle.hs new file mode 100644 --- /dev/null +++ b/Stackage/ServerBundle.hs @@ -0,0 +1,271 @@ +-- | Create a bundle to be uploaded to Stackage Server. +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Stackage.ServerBundle + ( serverBundle + , epochTime + , bpAllPackages + , docsListing + , createBundleV2 + , CreateBundleV2 (..) + , SnapshotType (..) + , writeIndexStyle + , DocMap + , PackageDocs (..) + ) where + +import qualified Codec.Archive.Tar as Tar +import qualified Codec.Archive.Tar.Entry as Tar +import qualified Codec.Compression.GZip as GZip +import qualified Data.Map as M +import Data.Aeson (ToJSON (..), (.=), object, FromJSON (..), (.:), withObject) +import System.IO.Temp (withTempDirectory) +import qualified Data.Yaml as Y +import Filesystem (isFile, getWorkingDirectory, listDirectory, isDirectory, canonicalizePath) +import Foreign.C.Types (CTime (CTime)) +import Stackage.BuildConstraints +import Stackage.BuildPlan +import Stackage.Prelude +import System.IO.Temp (withTempDirectory) +import qualified System.PosixCompat.Time as PC +import qualified Text.XML as X +import Text.XML.Cursor +import System.PosixCompat.Files (createSymbolicLink) + +-- | Get current time +epochTime :: IO Tar.EpochTime +epochTime = (\(CTime t) -> fromIntegral t) <$> PC.epochTime + +-- | All package/versions in a build plan, including core packages. +-- +-- Note that this may include packages not available on Hackage. +bpAllPackages :: BuildPlan -> Map PackageName Version +bpAllPackages BuildPlan {..} = + siCorePackages bpSystemInfo ++ map ppVersion bpPackages + +serverBundle :: Tar.EpochTime + -> Text -- ^ title + -> Text -- ^ slug + -> BuildPlan + -> LByteString +serverBundle time title slug bp@BuildPlan {..} = GZip.compress $ Tar.write + [ fe "build-plan.yaml" (fromStrict $ Y.encode bp) + , fe "hackage" hackage + , fe "slug" (fromStrict $ encodeUtf8 slug) + , fe "desc" (fromStrict $ encodeUtf8 title) + , fe "core" corePackagesList + ] + where + fe name contents = + case Tar.toTarPath False name of + Left s -> error s + Right name' -> (Tar.fileEntry name' contents) + { Tar.entryTime = time + } + hackage = builderToLazy $ foldMap goPair $ mapToList packageMap + + -- need to remove some packages that don't exist on Hackage + packageMap = foldr deleteMap (bpAllPackages bp) $ map PackageName + [ "bin-package-db" + , "ghc" + , "rts" + ] + + goPair (name, version) = + toBuilder (display name) ++ + toBuilder (asText "-") ++ + toBuilder (display version) ++ + toBuilder (asText "\n") + + corePackagesList = + builderToLazy $ toBuilder $ unlines $ + map (\(PackageName name) -> name) + (M.keys $ siCorePackages bpSystemInfo) + +-- | Package name is key +type DocMap = Map Text PackageDocs +data PackageDocs = PackageDocs + { pdVersion :: Text + , pdModules :: Map Text [Text] + -- ^ module name, path + } +instance ToJSON PackageDocs where + toJSON PackageDocs {..} = object + [ "version" .= pdVersion + , "modules" .= pdModules + ] +instance FromJSON PackageDocs where + parseJSON = withObject "PackageDocs" $ \o -> PackageDocs + <$> o .: "version" + <*> o .: "modules" + +docsListing :: BuildPlan + -> FilePath -- ^ docs directory + -> IO DocMap +docsListing bp docsDir = + fmap fold $ mapM go $ mapToList $ bpAllPackages bp + where + go :: (PackageName, Version) -> IO DocMap + go (package, version) = do -- handleAny (const $ return mempty) $ do + let dirname = fpFromText (concat + [ display package + , "-" + , display version + ]) + indexFP = (docsDir dirname "index.html") + ie <- isFile indexFP + if ie + then do + doc <- flip X.readFile indexFP X.def + { X.psDecodeEntities = X.decodeHtmlEntities + } + let cursor = fromDocument doc + getPair x = take 1 $ do + href <- attribute "href" x + let name = concat $ x $// content + guard $ not $ null name + return (href, name) + pairs = cursor $// attributeIs "class" "module" + &/ laxElement "a" >=> getPair + m <- fmap fold $ forM pairs $ \(href, name) -> do + let suffix = dirname fpFromText href + e <- isFile $ docsDir suffix + return $ if e + then asMap $ singletonMap name [fpToText dirname, href] + else mempty + return $ singletonMap (display package) $ PackageDocs + { pdVersion = display version + , pdModules = m + } + else return mempty + +data SnapshotType = STNightly + | STLTS !Int !Int -- ^ major, minor + deriving (Show, Read, Eq, Ord) + +instance ToJSON SnapshotType where + toJSON STNightly = object + [ "type" .= asText "nightly" + ] + toJSON (STLTS major minor) = object + [ "type" .= asText "lts" + , "major" .= major + , "minor" .= minor + ] +instance FromJSON SnapshotType where + parseJSON = withObject "SnapshotType" $ \o -> do + t <- o .: "type" + case asText t of + "nightly" -> return STNightly + "lts" -> STLTS + <$> o .: "major" + <*> o .: "minor" + _ -> fail $ "Unknown type for SnapshotType: " ++ unpack t + +data CreateBundleV2 = CreateBundleV2 + { cb2Plan :: BuildPlan + , cb2Type :: SnapshotType + , cb2DocsDir :: FilePath + , cb2Dest :: FilePath + } + +-- | Create a V2 bundle, which contains the build plan, metadata, docs, and doc +-- map. +createBundleV2 :: CreateBundleV2 -> IO () +createBundleV2 CreateBundleV2 {..} = do + docsDir <- canonicalizePath cb2DocsDir + docMap <- docsListing cb2Plan cb2DocsDir + + Y.encodeFile (fpToString $ docsDir "build-plan.yaml") cb2Plan + Y.encodeFile (fpToString $ docsDir "build-type.yaml") cb2Type + Y.encodeFile (fpToString $ docsDir "docs-map.yaml") docMap + void $ writeIndexStyle Nothing cb2DocsDir + + currentDir <- getWorkingDirectory + files <- listDirectory docsDir + + let args = "cfJ" + : fpToString (currentDir cb2Dest) + : "--dereference" + : map (fpToString . filename) files + cp = (proc "tar" args) { cwd = Just $ fpToString docsDir } + withCheckedProcess cp $ \ClosedStream Inherited Inherited -> return () + +writeIndexStyle :: Maybe Text -- ^ snapshot id + -> FilePath -- ^ docs dir + -> IO [String] +writeIndexStyle msnapid dir = do + dirs <- fmap sort + $ runResourceT + $ sourceDirectory dir + $$ filterMC (liftIO . isDirectory) + =$ mapC (fpToString . filename) + =$ sinkList + writeFile (dir "index.html") $ mkIndex + (unpack <$> msnapid) + dirs + writeFile (dir "style.css") styleCss + return dirs + +mkIndex :: Maybe String -> [String] -> String +mkIndex msnapid dirs = concat + [ "\nHaddocks index" + , "" + , "" + , "" + , "" + , "
" + , "
" + , "

Haddock documentation index

" + , flip foldMap msnapid $ \snapid -> concat + [ "

Return to snapshot

" + ] + , "
    " + , concatMap toLI dirs + , "
" + ] + where + toLI name = concat + [ "
  • " + , name + , "
    • " + ] + +styleCss :: String +styleCss = concat + [ "@media (min-width: 530px) {" + , "ul { -webkit-column-count: 2; -moz-column-count: 2; column-count: 2 }" + , "}" + , "@media (min-width: 760px) {" + , "ul { -webkit-column-count: 3; -moz-column-count: 3; column-count: 3 }" + , "}" + , "ul {" + , " margin-left: 0;" + , " padding-left: 0;" + , " list-style-type: none;" + , "}" + , "body {" + , " background: #f0f0f0;" + , " font-family: 'Lato', sans-serif;" + , " text-shadow: 1px 1px 1px #ffffff;" + , " font-size: 20px;" + , " line-height: 30px;" + , " padding-bottom: 5em;" + , "}" + , "h1 {" + , " font-weight: normal;" + , " color: #06537d;" + , " font-size: 45px;" + , "}" + , ".return a {" + , " color: #06537d;" + , " font-style: italic;" + , "}" + , ".return {" + , " margin-bottom: 1em;" + , "}"] diff --git a/Stackage/UpdateBuildPlan.hs b/Stackage/UpdateBuildPlan.hs new file mode 100644 --- /dev/null +++ b/Stackage/UpdateBuildPlan.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +-- | Take an existing build plan and bump all packages to the newest version in +-- the same major version number. +module Stackage.UpdateBuildPlan + ( updateBuildConstraints + , updateBuildPlan + ) where + +import qualified Data.Map as Map +import Distribution.Version (anyVersion, earlierVersion, + orLaterVersion) +import Stackage.BuildConstraints +import Stackage.BuildPlan +import Stackage.Prelude + +updateBuildPlan :: Map PackageName PackagePlan -> BuildPlan -> IO BuildPlan +updateBuildPlan packagesOrig + = newBuildPlan packagesOrig . updateBuildConstraints + +updateBuildConstraints :: BuildPlan -> BuildConstraints +updateBuildConstraints BuildPlan {..} = + BuildConstraints {..} + where + bcSystemInfo = bpSystemInfo + bcPackages = Map.keysSet bpPackages + bcGithubUsers = bpGithubUsers + + bcPackageConstraints name = PackageConstraints + { pcVersionRange = addBumpRange (maybe anyVersion pcVersionRange moldPC) + , pcMaintainer = moldPC >>= pcMaintainer + , pcTests = maybe ExpectSuccess pcTests moldPC + , pcHaddocks = maybe ExpectSuccess pcHaddocks moldPC + , pcBuildBenchmarks = maybe True pcBuildBenchmarks moldPC + , pcFlagOverrides = maybe mempty pcFlagOverrides moldPC + , pcEnableLibProfile = maybe False pcEnableLibProfile moldPC + } + where + moldBP = lookup name bpPackages + moldPC = ppConstraints <$> moldBP + + addBumpRange oldRange = + case moldBP of + Nothing -> oldRange + Just bp -> intersectVersionRanges oldRange + $ bumpRange $ ppVersion bp + + bumpRange version = intersectVersionRanges + (orLaterVersion version) + (earlierVersion $ bumpVersion version) + bumpVersion (Version (x:y:_) _) = Version [x, y + 1] [] + bumpVersion (Version [x] _) = Version [x, 1] [] + bumpVersion (Version [] _) = assert False $ Version [1, 0] [] diff --git a/Stackage/Upload.hs b/Stackage/Upload.hs new file mode 100644 --- /dev/null +++ b/Stackage/Upload.hs @@ -0,0 +1,272 @@ +-- | Upload to Stackage and Hackage +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +module Stackage.Upload + ( UploadBundle (..) + , SnapshotIdent (..) + , uploadBundle + , UploadDocs (..) + , uploadDocs + , uploadHackageDistro + , uploadHackageDistroNamed + , UploadDocMap (..) + , uploadDocMap + , uploadBundleV2 + , UploadBundleV2 (..) + , def + , StackageServer + , unStackageServer + ) where + +import Control.Monad.Writer.Strict (execWriter, tell) +import Data.Default.Class (Default (..)) +import Data.Function (fix) +import Filesystem (isDirectory, isFile) +import Network.HTTP.Client +import qualified Network.HTTP.Client.Conduit as HCC +import Network.HTTP.Client.MultipartFormData +import Stackage.BuildPlan (BuildPlan) +import Stackage.Prelude +import Stackage.ServerBundle (bpAllPackages, docsListing, writeIndexStyle) +import System.IO.Temp (withSystemTempFile) +import qualified System.IO as IO +import qualified Data.Yaml as Y + +newtype StackageServer = StackageServer { unStackageServer :: Text } + deriving (Show, Eq, Ord, Hashable, IsString) +instance Default StackageServer where + def = "http://www.stackage.org" + +data UploadBundle = UploadBundle + { ubServer :: StackageServer + , ubContents :: LByteString + , ubAlias :: Maybe Text + , ubNightly :: Maybe Text -- ^ should be GHC version + , ubLTS :: Maybe Text -- ^ e.g. 2.3 + , ubAuthToken :: Text + } +instance Default UploadBundle where + def = UploadBundle + { ubServer = def + , ubContents = mempty + , ubAlias = Nothing + , ubNightly = Nothing + , ubLTS = Nothing + , ubAuthToken = "no-auth-token-provided" + } + +newtype SnapshotIdent = SnapshotIdent { unSnapshotIdent :: Text } + deriving (Show, Eq, Ord, Hashable, IsString) + +uploadBundle :: UploadBundle -> Manager -> IO (SnapshotIdent, Maybe Text) +uploadBundle UploadBundle {..} man = do + req1 <- parseUrl $ unpack $ unStackageServer ubServer ++ "/upload" + req2 <- formDataBody formData req1 + let req3 = req2 + { method = "PUT" + , requestHeaders = + [ ("Authorization", encodeUtf8 ubAuthToken) + , ("Accept", "application/json") + ] ++ requestHeaders req2 + , redirectCount = 0 + , checkStatus = \_ _ _ -> Nothing + , responseTimeout = Just 300000000 + } + res <- httpLbs req3 man + case lookup "x-stackage-ident" $ responseHeaders res of + Just snapid -> return + ( SnapshotIdent $ decodeUtf8 snapid + , decodeUtf8 <$> lookup "location" (responseHeaders res) + ) + Nothing -> error $ "An error occurred: " ++ show res + where + params = mapMaybe (\(x, y) -> (x, ) <$> y) + [ ("alias", ubAlias) + , ("nightly", ubNightly) + , ("lts", ubLTS) + ] + formData = ($ []) $ execWriter $ do + forM_ params $ \(key, value) -> + tell' $ partBS key $ encodeUtf8 value + tell' $ partFileRequestBody "stackage" "stackage" + $ RequestBodyLBS ubContents + + tell' x = tell (x:) + +data UploadDocs = UploadDocs + { udServer :: StackageServer + , udDocs :: FilePath -- ^ may be a directory or a tarball + , udAuthToken :: Text + , udSnapshot :: SnapshotIdent + } + +uploadDocs :: UploadDocs -> Manager -> IO (Response LByteString) +uploadDocs (UploadDocs (StackageServer host) fp0 token ident) man = do + fe <- isFile fp0 + if fe + then uploadDocsFile $ fpToString fp0 + else do + de <- isDirectory fp0 + if de + then uploadDocsDir + else error $ "Path not found: " ++ fpToString fp0 + where + uploadDocsDir = withSystemTempFile "haddocks.tar.xz" $ \fp h -> do + hClose h + dirs <- writeIndexStyle (Just $ unSnapshotIdent ident) fp0 + let cp = (proc "tar" $ "cJf" : fp : "index.html" : "style.css" : dirs) + { cwd = Just $ fpToString fp0 + } + withCheckedProcess cp $ \Inherited Inherited Inherited -> return () + uploadDocsFile fp + uploadDocsFile fp = do + req1 <- parseUrl $ unpack $ concat + [ host + , "/upload-haddock/" + , unSnapshotIdent ident + ] + let formData = + [ partFileSource "tarball" fp + ] + req2 <- formDataBody formData req1 + let req3 = req2 + { method = "PUT" + , requestHeaders = + [ ("Authorization", encodeUtf8 token) + , ("Accept", "application/json") + ] ++ requestHeaders req2 + , redirectCount = 0 + , checkStatus = \_ _ _ -> Nothing + , responseTimeout = Just 300000000 + } + httpLbs req3 man + +uploadHackageDistro :: BuildPlan + -> ByteString -- ^ Hackage username + -> ByteString -- ^ Hackage password + -> Manager + -> IO (Response LByteString) +uploadHackageDistro = uploadHackageDistroNamed "Stackage" + +uploadHackageDistroNamed + :: Text -- ^ distro name + -> BuildPlan + -> ByteString -- ^ Hackage username + -> ByteString -- ^ Hackage password + -> Manager + -> IO (Response LByteString) +uploadHackageDistroNamed name bp username password manager = do + req1 <- parseUrl $ concat + [ "http://hackage.haskell.org/distro/" + , unpack name + , "/packages.csv" + ] + let req2 = req1 + { requestHeaders = [("Content-Type", "text/csv")] + , requestBody = RequestBodyLBS csv + , checkStatus = \_ _ _ -> Nothing + , method = "PUT" + } + httpLbs (applyBasicAuth username password req2) manager + where + csv = encodeUtf8 + $ builderToLazy + $ mconcat + $ intersperse "\n" + $ map go + $ mapToList + $ bpAllPackages bp + go (name, version) = + "\"" ++ + (toBuilder $ display name) ++ + "\",\"" ++ + (toBuilder $ display version) ++ + "\",\"http://www.stackage.org/package/" ++ + (toBuilder $ display name) ++ + "\"" + +data UploadDocMap = UploadDocMap + { udmServer :: StackageServer + , udmAuthToken :: Text + , udmSnapshot :: SnapshotIdent + , udmDocDir :: FilePath + , udmPlan :: BuildPlan + } + +uploadDocMap :: UploadDocMap -> Manager -> IO (Response LByteString) +uploadDocMap UploadDocMap {..} man = do + docmap <- docsListing udmPlan udmDocDir + req1 <- parseUrl $ unpack $ unStackageServer udmServer ++ "/upload-doc-map" + req2 <- formDataBody (formData $ Y.encode docmap) req1 + let req3 = req2 + { method = "PUT" + , requestHeaders = + [ ("Authorization", encodeUtf8 udmAuthToken) + , ("Accept", "application/json") + ] ++ requestHeaders req2 + , redirectCount = 0 + , checkStatus = \_ _ _ -> Nothing + , responseTimeout = Just 300000000 + } + httpLbs req3 man + where + formData docmap = + [ partBS "snapshot" (encodeUtf8 $ unSnapshotIdent udmSnapshot) + , partFileRequestBody "docmap" "docmap" $ RequestBodyBS docmap + ] + +data UploadBundleV2 = UploadBundleV2 + { ub2Server :: StackageServer + , ub2AuthToken :: Text + , ub2Bundle :: FilePath + } + +uploadBundleV2 :: UploadBundleV2 -> Manager -> IO Text +uploadBundleV2 UploadBundleV2 {..} man = IO.withBinaryFile (fpToString ub2Bundle) IO.ReadMode $ \h -> do + size <- IO.hFileSize h + putStrLn $ "Bundle size: " ++ tshow size + req1 <- parseUrl $ unpack $ unStackageServer ub2Server ++ "/upload2" + let req2 = req1 + { method = "PUT" + , requestHeaders = + [ ("Authorization", encodeUtf8 ub2AuthToken) + , ("Accept", "application/json") + , ("Content-Type", "application/x-tar") + ] + , requestBody = HCC.requestBodySource (fromIntegral size) + $ sourceHandle h $= printProgress size + } + sink = decodeUtf8C =$ fix (\loop -> do + mx <- peekC + case mx of + Nothing -> error $ "uploadBundleV2: premature end of stream" + Just _ -> do + l <- lineC $ takeCE 4096 =$ foldC + let (cmd, msg') = break (== ':') l + msg = dropWhile (== ' ') $ dropWhile (== ':') msg' + case cmd of + "CONT" -> do + putStrLn msg + loop + "FAILURE" -> error $ "uploadBundleV2 failed: " ++ unpack msg + "SUCCESS" -> return msg + _ -> error $ "uploadBundleV2: unknown command " ++ unpack cmd + ) + withResponse req2 man $ \res -> HCC.bodyReaderSource (responseBody res) $$ sink + where + printProgress total = + loop 0 0 + where + loop sent lastPercent = + await >>= maybe (putStrLn "Upload complete") go + where + go bs = do + yield bs + let sent' = sent + fromIntegral (length bs) + percent = sent' * 100 `div` total + when (percent /= lastPercent) + $ putStrLn $ "Upload progress: " ++ tshow percent ++ "%" + loop sent' percent diff --git a/app/stackage.hs b/app/stackage.hs new file mode 100644 --- /dev/null +++ b/app/stackage.hs @@ -0,0 +1,210 @@ +{-# LANGUAGE TupleSections #-} + +module Main where + +import Control.Monad +import Data.Monoid +import Data.String (fromString) +import Data.Version +import Options.Applicative +import Filesystem.Path.CurrentOS (decodeString) +import Paths_stackage (version) +import Stackage.CompleteBuild +import Stackage.Upload +import Stackage.InstallBuild +import Network.HTTP.Client (withManager) +import Network.HTTP.Client.TLS (tlsManagerSettings) +import qualified Data.Text as T + +main :: IO () +main = + join $ + execParser $ + info + (helpOption <*> versionOption <*> config) + (header "Stackage" <> + fullDesc) + where + helpOption = + abortOption ShowHelpText $ + long "help" <> + help "Show this help text" + versionOption = + infoOption + ("stackage version " ++ showVersion version) + (long "version" <> + help "Show stackage version") + config = + subparser $ + mconcat + [ cmnd + (uncurry completeBuild) + (fmap (Nightly, ) buildFlags) + "nightly" + "Build, test and upload the Nightly snapshot" + , cmnd + (uncurry completeBuild) + (fmap (LTS Major, ) buildFlags) + "lts-major" + "Build, test and upload the LTS (major) snapshot" + , cmnd + (uncurry completeBuild) + (fmap (LTS Minor, ) buildFlags) + "lts-minor" + "Build, test and upload the LTS (minor) snapshot" + , cmnd + justUploadNightly + nightlyUploadFlags + "upload-nightly" + "Upload an already-built nightly snapshot" + , cmnd + (const justCheck) + (pure ()) + "check" + "Just check that the build plan is ok" + , cmnd + installBuild + installFlags + "install" + "Install a snapshot from an existing build plan" + , cmnd + uploadv2 + uploadv2Flags + "upload2" + "Upload a pre-existing v2 bundle" + ] + + cmnd exec parse name desc = + command name $ + info + (fmap exec (parse <**> helpOption)) + (progDesc desc) + + buildFlags = + BuildFlags <$> + fmap + not + (switch + (long "skip-tests" <> + help "Skip build and running the test suites")) <*> + fmap + not + (switch + (long "skip-haddock" <> + help "Skip generating haddock documentation")) <*> + fmap + not + (switch + (long "skip-upload" <> + help "Skip uploading bundle, docs, etc.")) <*> + switch + (long "enable-library-profiling" <> + help "Enable profiling when building") <*> + switch + (long "enable-executable-dynamic" <> + help "Enable dynamic executables when building") <*> + switch + (long "verbose" <> short 'v' <> + help "Output verbose detail about the build steps") <*> + switch + (long "skip-check" <> + help "Skip the check phase, and pass --allow-newer to cabal configure") <*> + switch + (long "upload-v1" <> + help "Use the V1 upload code") <*> + (fmap fromString (strOption + (long "server-url" <> + metavar "SERVER-URL" <> + showDefault <> value (T.unpack $ unStackageServer def) <> + help "Server to upload bundle to"))) <*> + fmap + not + (switch + (long "skip-hoogle" <> + help "Skip generating Hoogle input files")) + + nightlyUploadFlags = fromString <$> strArgument + (metavar "DATE" <> + help "Date, in YYYY-MM-DD format") + + installFlags = + InstallFlags <$> + (fmap + BPSBundleWeb + (strOption + (long "bundle" <> + metavar "URL" <> + help "Stackage bundle containing build plan")) <|> + fmap + (BPSFile . decodeString) + (strOption + (long "build-plan" <> + metavar "PATH" <> + help "Build-plan YAML file"))) <*> + fmap + decodeString + (strArgument + (metavar "DESTINATION-PATH" <> + help "Destination directory path")) <*> + (fmap + (Just . decodeString) + (strOption + (long "log-dir" <> + metavar "PATH" <> + help "Location of log files (default DESTINATION-PATH/logs)")) <|> + pure Nothing) <*> + option + auto + (long "jobs" <> + metavar "NUMBER" <> + showDefault <> value 8 <> + help "Number of threads") <*> + switch + (long "global" <> + help "Install in global package database") <*> + fmap + not + (switch + (long "skip-tests" <> + help "Skip build and running the test suites")) <*> + fmap + not + (switch + (long "skip-haddock" <> + help "Skip generating haddock documentation")) <*> + switch + (long "enable-library-profiling" <> + help "Enable profiling when building") <*> + switch + (long "enable-executable-dynamic" <> + help "Enable dynamic executables when building") <*> + switch + (long "verbose" <> short 'v' <> + help "Output verbose detail about the build steps") <*> + switch + (long "skip-check" <> + help "Skip the check phase, and pass --allow-newer to cabal configure") <*> + fmap + not + (switch + (long "skip-hoogle" <> + help "Skip generating Hoogle input files")) + + uploadv2 (path, url) = withManager tlsManagerSettings $ \man -> do + token <- getStackageAuthToken + res <- flip uploadBundleV2 man UploadBundleV2 + { ub2AuthToken = token + , ub2Server = fromString url + , ub2Bundle = decodeString path + } + putStrLn $ "New URL: " ++ T.unpack res + + uploadv2Flags = (,) + <$> (strArgument + (metavar "BUNDLE-PATH" <> + help "Bundle path")) + <*> strOption + (long "server-url" <> + metavar "SERVER-URL" <> + showDefault <> value (T.unpack $ unStackageServer def) <> + help "Server to upload bundle to") diff --git a/stackage-curator.cabal b/stackage-curator.cabal new file mode 100644 --- /dev/null +++ b/stackage-curator.cabal @@ -0,0 +1,105 @@ +name: stackage-curator +version: 0.7.0 +synopsis: Tools for curating Stackage bundles +description: Please see for a description and documentation. +homepage: https://github.com/fpco/stackage +license: MIT +license-file: LICENSE +author: Michael Snoyman +maintainer: michael@fpcomplete.com +category: Distribution +build-type: Simple +cabal-version: >=1.10 +extra-source-files: README.md + ChangeLog.md + test/test-build-constraints.yaml + +library + default-language: Haskell2010 + exposed-modules: Stackage.Prelude + Stackage.BuildConstraints + Stackage.CorePackages + Stackage.PackageIndex + Stackage.BuildPlan + Stackage.CheckBuildPlan + Stackage.UpdateBuildPlan + Stackage.GhcPkg + Stackage.GithubPings + Stackage.InstallBuild + Stackage.PackageDescription + Stackage.ServerBundle + Stackage.Upload + Stackage.PerformBuild + Stackage.CompleteBuild + build-depends: base >= 4 && < 5 + , containers + , Cabal >= 1.14 + , tar >= 0.3 + , zlib + , bytestring + , directory + , filepath + , transformers + , process + , old-locale + , time + , utf8-string + + , conduit-extra + , classy-prelude-conduit + , text + , system-fileio + , system-filepath + , mtl + , aeson + , yaml + , unix-compat + , http-client + , http-conduit + , http-client-tls + , temporary + , data-default-class + , stm + , mono-traversable + , async + , streaming-commons >= 0.1.7.1 + , semigroups + , xml-conduit + , conduit + +executable stackage-curator + default-language: Haskell2010 + hs-source-dirs: app + main-is: stackage.hs + build-depends: base + , stackage + , optparse-applicative >= 0.11 + , system-filepath + , http-client + , http-client-tls + , text + ghc-options: -rtsopts -threaded -with-rtsopts=-N + +test-suite spec + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: test + main-is: Spec.hs + other-modules: Stackage.CorePackagesSpec + Stackage.PackageIndexSpec + Stackage.BuildPlanSpec + build-depends: base + , stackage + , hspec + , QuickCheck + , text + , classy-prelude-conduit + , Cabal + , yaml + , containers + , http-client + , http-client-tls + +source-repository head + type: git + location: https://github.com/fpco/stackage diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/Stackage/BuildPlanSpec.hs b/test/Stackage/BuildPlanSpec.hs new file mode 100644 --- /dev/null +++ b/test/Stackage/BuildPlanSpec.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings, NoImplicitPrelude #-} +module Stackage.BuildPlanSpec (spec) where + +import qualified Data.Map as Map +import qualified Data.Map.Strict as M +import qualified Data.Set as S +import Data.Yaml +import qualified Data.Yaml as Y +import Distribution.Version +import Network.HTTP.Client +import Network.HTTP.Client.TLS (tlsManagerSettings) +import Stackage.BuildConstraints +import Stackage.BuildPlan +import Stackage.CheckBuildPlan +import Stackage.PackageDescription +import Stackage.Prelude +import Stackage.UpdateBuildPlan +import Test.Hspec + +spec :: Spec +spec = do + it "simple package set" $ check testBuildConstraints $ makePackageSet + [("foo", [0, 0, 0], [("bar", thisV [0, 0, 0])]) + ,("bar", [0, 0, 0], [])] + it "bad version range on depdendency fails" $ badBuildPlan $ makePackageSet + [("foo", [0, 0, 0], [("bar", thisV [1, 1, 0])]) + ,("bar", [0, 0, 0], [])] + it "nonexistent package fails to check" $ badBuildPlan $ makePackageSet + [("foo", [0, 0, 0], [("nonexistent", thisV [0, 0, 0])]) + ,("bar", [0, 0, 0], [])] + it "mutual cycles fail to check" $ badBuildPlan $ makePackageSet + [("foo", [0, 0, 0], [("bar", thisV [0, 0, 0])]) + ,("bar", [0, 0, 0], [("foo", thisV [0, 0, 0])])] + it "nested cycles fail to check" $ badBuildPlan $ makePackageSet + [("foo", [0, 0, 0], [("bar", thisV [0, 0, 0])]) + ,("bar", [0, 0, 0], [("mu", thisV [0, 0, 0])]) + ,("mu", [0, 0, 0], [("foo", thisV [0, 0, 0])])] + {- Shouldn't be testing this actually + it "default package set checks ok" $ + check defaultBuildConstraints getLatestAllowedPlans + -} + +-- | Checking should be considered a bad build plan. +badBuildPlan :: (BuildConstraints -> IO (Map PackageName PackagePlan)) + -> void + -> IO () +badBuildPlan m _ = do + mu <- try (check testBuildConstraints m) + case mu of + Left (_ :: BadBuildPlan) -> + return () + Right () -> + error "Expected bad build plan." + +-- | Check build plan with the given package set getter. +check :: (Manager -> IO BuildConstraints) + -> (BuildConstraints -> IO (Map PackageName PackagePlan)) + -> IO () +check readPlanFile getPlans = withManager tlsManagerSettings $ \man -> do + bc <- readPlanFile man + plans <- getPlans bc + bp <- newBuildPlan plans bc + let bs = Y.encode bp + ebp' = Y.decodeEither bs + + bp' <- either error return ebp' + + let allPackages = Map.keysSet (bpPackages bp) ++ Map.keysSet (bpPackages bp') + forM_ allPackages $ \name -> + (name, lookup name (bpPackages bp')) `shouldBe` + (name, lookup name (bpPackages bp)) + bpGithubUsers bp' `shouldBe` bpGithubUsers bp + + when (bp' /= bp) $ error "bp' /= bp" + bp2 <- updateBuildPlan plans bp + when (dropVersionRanges bp2 /= dropVersionRanges bp) $ error "bp2 /= bp" + checkBuildPlan bp + where + dropVersionRanges bp = + bp { bpPackages = map go $ bpPackages bp } + where + go pb = pb { ppConstraints = go' $ ppConstraints pb } + go' pc = pc { pcVersionRange = anyVersion } + +-- | Make a package set from a convenient data structure. +makePackageSet + :: [(String,[Int],[(String,VersionRange)])] + -> BuildConstraints + -> IO (Map PackageName PackagePlan) +makePackageSet ps _ = + return $ + M.fromList $ + map + (\(name,ver,deps) -> + ( PackageName name + , dummyPackage ver $ + M.fromList $ + map + (\(dname,dver) -> + ( PackageName dname + , DepInfo {diComponents = S.fromList + [CompLibrary] + ,diRange = dver})) + deps)) + ps + where + dummyPackage v deps = + PackagePlan + {ppVersion = Version v [] + ,ppGithubPings = mempty + ,ppUsers = mempty + ,ppConstraints = + PackageConstraints + {pcVersionRange = anyV + ,pcMaintainer = Nothing + ,pcTests = Don'tBuild + ,pcHaddocks = Don'tBuild + ,pcBuildBenchmarks = False + ,pcFlagOverrides = mempty + ,pcEnableLibProfile = False} + ,ppDesc = + SimpleDesc + {sdPackages = deps + ,sdTools = mempty + ,sdProvidedExes = mempty + ,sdModules = mempty}} + +-- | This exact version is required. +thisV :: [Int] -> VersionRange +thisV ver = thisVersion (Version ver []) + +-- | Accept any version. +anyV :: VersionRange +anyV = anyVersion + +-- | Test plan. +testBuildConstraints :: void -> IO BuildConstraints +testBuildConstraints _ = + decodeFileEither + (fpToString fp) >>= + either throwIO toBC + where fp = "test/test-build-constraints.yaml" diff --git a/test/Stackage/CorePackagesSpec.hs b/test/Stackage/CorePackagesSpec.hs new file mode 100644 --- /dev/null +++ b/test/Stackage/CorePackagesSpec.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE OverloadedStrings, NoImplicitPrelude #-} +module Stackage.CorePackagesSpec (spec) where + +import Stackage.CorePackages +import Stackage.Prelude +import Test.Hspec + +spec :: Spec +spec = do + it "works" $ void getCorePackages + it "contains known core packages" $ do + m <- getCorePackages + forM_ (words "ghc containers base") $ \p -> + m `shouldSatisfy` (member (PackageName p)) + it "getCoreExecutables includes known executables" $ do + s <- getCoreExecutables + s `shouldSatisfy` member "ghc" + s `shouldSatisfy` member "hsc2hs" + s `shouldSatisfy` member "runghc" diff --git a/test/Stackage/PackageIndexSpec.hs b/test/Stackage/PackageIndexSpec.hs new file mode 100644 --- /dev/null +++ b/test/Stackage/PackageIndexSpec.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE OverloadedStrings, NoImplicitPrelude #-} +module Stackage.PackageIndexSpec (spec) where + +import Stackage.PackageIndex +import Stackage.Prelude +import Test.Hspec +import Distribution.Package (packageId) + +spec :: Spec +spec = do + it "works" $ (runResourceT $ sourcePackageIndex $$ sinkNull :: IO ()) + it "getLatestDescriptions gives reasonable results" $ do + let f x y = (display x, display y) `member` asSet (setFromList + [ (asText "base", asText "4.5.0.0") + , ("does-not-exist", "9999999999999999999") + ]) + m <- getLatestDescriptions f return + length m `shouldBe` 1 + p <- simpleParse $ asText "base" + v <- simpleParse $ asText "4.5.0.0" + (pkgVersion . packageId <$> m) `shouldBe` singletonMap p v diff --git a/test/test-build-constraints.yaml b/test/test-build-constraints.yaml new file mode 100644 --- /dev/null +++ b/test/test-build-constraints.yaml @@ -0,0 +1,20 @@ +packages: + "Test": + - foo + - bar + +global-flags: [] + +skipped-tests: [] +expected-test-failures: [] +expected-haddock-failures: [] +skipped-benchmarks: [] +skipped-profiling: [] + +github-users: + bar: + - demo + +package-flags: + foo: + demo: true