diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,8 @@ +## 0.12.0 + +* New create-plan flags: `--add-package`, `--expect-test-failure` and `--expect-haddock-failure` +* Package description caching + ## 0.11.0 * Use newest version of libraries [#6](https://github.com/fpco/stackage-curator/issues/6) diff --git a/Stackage/BuildConstraints.hs b/Stackage/BuildConstraints.hs --- a/Stackage/BuildConstraints.hs +++ b/Stackage/BuildConstraints.hs @@ -111,6 +111,7 @@ , cfGithubUsers :: Map Text (Set Text) , cfSkippedLibProfiling :: Set PackageName , cfGhcMajorVersion :: Maybe (Int, Int) + , cfTreatAsNonCore :: Set PackageName } instance FromJSON ConstraintFile where @@ -127,6 +128,7 @@ . Map.mapKeysWith const Maintainer cfGithubUsers <- o .: "github-users" cfGhcMajorVersion <- o .:? "ghc-major-version" >>= mapM parseMajorVersion + cfTreatAsNonCore <- getPackages o "treat-as-non-core" <|> return mempty return ConstraintFile {..} where goFlagMap = Map.mapKeysWith const FlagName @@ -149,9 +151,16 @@ deriving (Show, Typeable) instance Exception MismatchedGhcVersion +-- | Remove the given packages from the set of core packages +removeFromCore :: Set PackageName -> SystemInfo -> SystemInfo +removeFromCore forceNonCore si = si + { siCorePackages = siCorePackages si + `Map.difference` mapFromList (map (, ()) $ toList forceNonCore) + } + toBC :: ConstraintFile -> IO BuildConstraints toBC ConstraintFile {..} = do - bcSystemInfo <- getSystemInfo + bcSystemInfo <- removeFromCore cfTreatAsNonCore <$> getSystemInfo forM_ cfGhcMajorVersion $ \(major, minor) -> case versionBranch $ siGhcVersion bcSystemInfo of major':minor':_ | major == major' && minor == minor' -> return () diff --git a/Stackage/BuildPlan.hs b/Stackage/BuildPlan.hs --- a/Stackage/BuildPlan.hs +++ b/Stackage/BuildPlan.hs @@ -117,14 +117,15 @@ mkPackagePlan :: MonadThrow m => BuildConstraints - -> GenericPackageDescription + -> SimplifiedPackageDescription -> m PackagePlan -mkPackagePlan bc gpd = do - ppDesc <- toSimpleDesc CheckCond {..} gpd +mkPackagePlan bc spd = do + ppDesc <- toSimpleDesc CheckCond {..} spd return PackagePlan {..} where - PackageIdentifier name ppVersion = package $ packageDescription gpd - ppGithubPings = getGithubPings bc gpd + name = spdName spd + ppVersion = spdVersion spd + ppGithubPings = applyGithubMapping bc $ spdGithubPings spd ppConstraints = bcPackageConstraints bc name ppUsers = mempty -- must be filled in later @@ -140,9 +141,8 @@ SystemInfo {..} = bcSystemInfo bc overrides = pcFlagOverrides ppConstraints - getFlag MkFlag {..} = - (flagName, fromMaybe flagDefault $ lookup flagName overrides) - flags = mapFromList $ map getFlag $ genPackageFlags gpd + flags = mapWithKey overrideFlag $ spdPackageFlags spd + overrideFlag name defVal = fromMaybe defVal $ lookup name overrides getLatestAllowedPlans :: MonadIO m => BuildConstraints -> m (Map PackageName PackagePlan) getLatestAllowedPlans bc = diff --git a/Stackage/CheckBuildPlan.hs b/Stackage/CheckBuildPlan.hs --- a/Stackage/CheckBuildPlan.hs +++ b/Stackage/CheckBuildPlan.hs @@ -147,7 +147,7 @@ showUser :: (PkgUser, VersionRange) -> Text showUser (pu, range) = concat - [ "- " + [ "- [ ] " , pkgUserShow1 pu , " (" -- add a space after < to avoid confusing Markdown processors (like diff --git a/Stackage/CompleteBuild.hs b/Stackage/CompleteBuild.hs --- a/Stackage/CompleteBuild.hs +++ b/Stackage/CompleteBuild.hs @@ -68,8 +68,11 @@ createPlan :: Target -> FilePath -> [Dependency] -- ^ additional constraints + -> [PackageName] -- ^ newly added packages + -> [PackageName] -- ^ newly expected test failures + -> [PackageName] -- ^ newly expected haddock failures -> IO () -createPlan target dest constraints = do +createPlan target dest constraints addPackages expectTestFailures expectHaddockFailures = do man <- newManager tlsManagerSettings putStrLn $ "Creating plan for: " ++ tshow target bc <- @@ -90,10 +93,27 @@ return $ updateBuildConstraints oldplan _ -> defaultBuildConstraints man - plan <- planFromConstraints $ setConstraints constraints bc + plan <- planFromConstraints + $ flip (foldr expectHaddockFailure) expectHaddockFailures + $ flip (foldr expectTestFailure) expectTestFailures + $ flip (foldr addPackage) addPackages + $ setConstraints constraints bc putStrLn $ "Writing build plan to " ++ pack dest encodeFile dest plan + where + -- Add a new package to the build constraints + addPackage :: PackageName -> BuildConstraints -> BuildConstraints + addPackage name bc = bc { bcPackages = insertSet name $ bcPackages bc } + + expectTestFailure = tweak $ \pc -> pc { pcTests = ExpectFailure } + expectHaddockFailure = tweak $ \pc -> pc { pcHaddocks = ExpectFailure } + + tweak f name bc = bc + { bcPackageConstraints = \name' -> + (if name == name' then f else id) + (bcPackageConstraints bc name') + } planFromConstraints :: MonadIO m => BuildConstraints -> m BuildPlan planFromConstraints bc = do diff --git a/Stackage/Curator/UploadDocs.hs b/Stackage/Curator/UploadDocs.hs --- a/Stackage/Curator/UploadDocs.hs +++ b/Stackage/Curator/UploadDocs.hs @@ -44,6 +44,7 @@ import Text.Blaze.Html.Renderer.Utf8 (renderHtml) import Text.HTML.DOM (eventConduit) import Text.XML (fromEvents) +import Control.Concurrent (threadDelay) upload :: (MonadResource m) => Bool -- ^ compression? @@ -108,16 +109,26 @@ eres <- liftResourceT $ tryAny $ src $$ upload toCompress env bucket name case eres of Left e - | i <= (0 :: Int) -> throwIO e + | i > maxAttempts -> throwIO e | otherwise -> do - putStrLn $ "Exception, retrying: " ++ tshow e - loop $! i - 1 + putStrLn $ concat + [ "Exception (" + , tshow i + , "/" + , tshow maxAttempts + , "), retrying: " + , tshow e + ] + liftIO $ threadDelay $ 2000000 * i + loop $! i + 1 Right () -> return () - loop 3 + loop 1 + where + maxAttempts = 20 isHoogleFile :: FilePath -> FilePath -> Bool isHoogleFile input fp' = fromMaybe False $ do - fp <- F.stripPrefix (fromString input) (fromString fp') + fp <- F.stripPrefix (fromString input F. "") (fromString fp') [dir, name] <- Just $ F.splitDirectories fp pkgver <- stripSuffix "/" $ pack $ F.encodeString dir (pack . F.encodeString -> pkg, ["txt"]) <- Just $ F.splitExtensions name @@ -139,7 +150,7 @@ yield (Nothing, EventBeginDoctype "html" Nothing) yield (Nothing, EventEndDoctype) mapMC $ \e -> do - e' <- goEvent fp toRoot e + e' <- goEvent fp toRoot packageUrl e return (Nothing, e') ) $$ fromEvents @@ -150,25 +161,34 @@ | any (F.hasExtension $ fromString fp) $ words "css js png svg gif" = void $ getName fp | otherwise = upload' True key $ sourceFile fp where - Just suffix = F.stripPrefix (fromString input) (fromString fp) + Just suffix = F.stripPrefix (fromString input F. "") (fromString fp) toRoot = concat $ asList $ replicate (length $ F.splitDirectories suffix) $ asText "../" key = name ++ "/" ++ pack (F.encodeString suffix) + packageUrl = concat + [ "https://www.stackage.org/" + , name + , "/package/" + , takeWhile (/= '/') $ pack $ F.encodeString suffix + ] goEvent :: M m => FilePath -- HTML file path -> Text -- ^ relative prefix to root + -> Text -- ^ package base page -> Event -> m Event -goEvent htmlfp toRoot (EventBeginElement name attrs) = - EventBeginElement name <$> mapM (goAttr htmlfp toRoot) attrs -goEvent _ _ e = return e +goEvent htmlfp toRoot packageUrl (EventBeginElement name attrs) = + EventBeginElement name <$> mapM (goAttr htmlfp toRoot packageUrl) attrs +goEvent _ _ _ e = return e goAttr :: M m => FilePath -- ^ HTML file path -> Text -- ^ relative prefix to root + -> Text -- ^ package base page -> (Name, [Content]) -> m (Name, [Content]) -goAttr htmlfp toRoot pair@(name, [ContentText value]) +goAttr htmlfp toRoot packageUrl pair@(name, [ContentText value]) + | name == "href" && value == "index.html" = return ("href", [ContentText packageUrl]) | isRef name && not (".html" `isSuffixOf` value) = do let fp = FP.takeDirectory htmlfp unpack value exists <- liftIO $ F.isFile $ fromString fp @@ -177,7 +197,7 @@ x <- getName fp return (name, [ContentText $ toRoot ++ x]) else return pair -goAttr _ _ pair = return pair +goAttr _ _ _ pair = return pair isRef :: Name -> Bool isRef "href" = True diff --git a/Stackage/DiffPlans.hs b/Stackage/DiffPlans.hs --- a/Stackage/DiffPlans.hs +++ b/Stackage/DiffPlans.hs @@ -5,10 +5,8 @@ ) where import Data.Map (filterWithKey) -import Data.Text (Text, justifyLeft) -import qualified Data.Text as T +import Data.Text (justifyLeft) import Data.Yaml (decodeFileEither) -import qualified Distribution.Text as DT import Network.HTTP.Client import Network.HTTP.Client.TLS (tlsManagerSettings) import Stackage.Prelude @@ -23,11 +21,13 @@ data AndOr a = Old a | New a | Both a a deriving Show instance Semigroup (AndOr a) where - Old x <> New y = Both x y - New y <> Old x = Both x y - Old x <> Old _ = Old x - New x <> New _ = New x - Both x y <> _ = Both x y + Old x <> New y = Both x y + New y <> Old x = Both x y + Old x <> Old _ = Old x + New x <> New _ = New x + Both x y <> _ = Both x y + Old x <> Both _ y = Both x y + New y <> Both x _ = Both x y type DiffMap = Map Change (Map PackageName (Text,Maybe Text)) @@ -39,10 +39,10 @@ -> Bool -- ^ wrap output in HTML -> IO () diffPlans oldFP newFP diffsOnly useColor True asHtml = do - (oldFP', newFP') <- (,) <$> getLTS (fpToString oldFP) <*> getLTS (fpToString newFP) + (oldFP', newFP') <- (,) <$> getLTS oldFP <*> getLTS newFP diffPlans oldFP' newFP' diffsOnly useColor False asHtml - delFile $ fpToString oldFP' - delFile $ fpToString newFP' + delFile oldFP' + delFile newFP' where delFile fp = removeFile fp `catch` \(_::SomeException) -> return () @@ -61,7 +61,7 @@ then print $ htmlOut True m else consoleOut useColor m where - parse fp = decodeFileEither (fpToString fp) + parse fp = decodeFileEither fp >>= either throwIO (return . toSimple) toSimple = fmap ppVersion . bpPackages @@ -88,13 +88,13 @@ getLTS :: String -> IO FilePath getLTS lts = do createDirectoryIfMissing True tmpDir - withManager tlsManagerSettings $ \man -> do - req <- parseUrl $ ltsRepo <> lts <> ".yaml" - res <- httpLbs req man - writeFile fName $ responseBody res - return fName + man <- newManager tlsManagerSettings + req <- parseUrl $ ltsRepo <> lts <> ".yaml" + res <- httpLbs req man + writeFile fName $ responseBody res + return fName where - fName = fpFromString $ tmpDir <> lts <> ".yaml" + fName = tmpDir <> lts <> ".yaml" ltsRepo = "https://raw.githubusercontent.com/fpco/lts-haskell/master/" tmpDir = "/tmp/stackage-curator/" @@ -109,18 +109,18 @@ MajorBump -> yellow s MinorBump -> blue s where - showInColor consCol htmlColor s + showInColor consCol htmlColor s' | useHtml = "color: " <> htmlColor - | otherwise = "\ESC[" <> consCol <> "m" <> s <> "\ESC[0m" + | otherwise = "\ESC[" <> consCol <> "m" <> s' <> "\ESC[0m" - black = showInColor "30" "black" + --black = showInColor "30" "black" red = showInColor "31" "red" green = showInColor "32" "green" yellow = showInColor "33" "yellow" blue = showInColor "34" "blue" - magenta = showInColor "35" "magenta" - cyan = showInColor "36" "cyan" - white = showInColor "37" "white" + --magenta = showInColor "35" "magenta" + --cyan = showInColor "36" "cyan" + --white = showInColor "37" "white" -- | Display to console @@ -129,9 +129,9 @@ forM_ (mapToList m) $ \(change, m') -> do print change forM_ (mapToList m') $ \(pkg, (x,y)) -> - let pkgName = (if useColor then colorize False change else id) + let pkgName' = (if useColor then colorize False change else id) $ justifyLeft 25 ' ' $ display pkg - in putStrLn $ pkgName <> + in putStrLn $ pkgName' <> justifyLeft 9 ' ' x <> if isJust y then " => " <> fromJust y diff --git a/Stackage/GithubPings.hs b/Stackage/GithubPings.hs --- a/Stackage/GithubPings.hs +++ b/Stackage/GithubPings.hs @@ -4,18 +4,23 @@ {-# LANGUAGE GADTs #-} module Stackage.GithubPings ( getGithubPings + , applyGithubMapping ) where import Distribution.PackageDescription import Stackage.BuildConstraints import Stackage.Prelude +applyGithubMapping :: BuildConstraints -> Set Text -> Set Text +applyGithubMapping bc = + foldMap (\name -> fromMaybe (singletonSet name) (lookup name (bcGithubUsers bc))) + -- | 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))) $ +getGithubPings :: GenericPackageDescription -> Set Text +getGithubPings gpd = + setFromList $ + map pack $ goHomepage (homepage $ packageDescription gpd) ++ concatMap goRepo (sourceRepos $ packageDescription gpd) where diff --git a/Stackage/PackageDescription.hs b/Stackage/PackageDescription.hs --- a/Stackage/PackageDescription.hs +++ b/Stackage/PackageDescription.hs @@ -23,38 +23,34 @@ import Distribution.Package (Dependency (..)) import Distribution.PackageDescription import Distribution.System (Arch, OS) +import Stackage.PackageIndex import Stackage.Prelude -- | Convert a 'GenericPackageDescription' into a 'SimpleDesc' by following the -- constraints in the provided 'CheckCond'. toSimpleDesc :: MonadThrow m => CheckCond - -> GenericPackageDescription + -> SimplifiedPackageDescription -> m SimpleDesc -toSimpleDesc cc gpd = execWriterT $ do - forM_ (condLibrary gpd) $ tellTree cc CompLibrary libBuildInfo getModules - forM_ (condExecutables gpd) $ tellTree cc CompExecutable buildInfo noModules . snd +toSimpleDesc cc spd = execWriterT $ do + forM_ (spdCondLibrary spd) $ tellTree cc CompLibrary + forM_ (spdCondExecutables spd) $ tellTree cc CompExecutable . snd tell mempty { sdProvidedExes = setFromList $ map (fromString . fst) - $ condExecutables gpd + $ spdCondExecutables spd } - 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 + when (ccIncludeTests cc) $ forM_ (spdCondTestSuites spd) + $ tellTree cc CompTestSuite . snd + when (ccIncludeBenchmarks cc) $ forM_ (spdCondBenchmarks spd) + $ tellTree cc CompBenchmark . snd -- | 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 + -> CondTree ConfVar [Dependency] SimplifiedComponentInfo -> m () -tellTree cc component getBI getModules = +tellTree cc component = loop where loop (CondNode dat deps comps) = do @@ -64,7 +60,7 @@ { diComponents = singletonSet component , diRange = simplifyVersionRange y } - , sdTools = unionsWith (<>) $ flip map (buildTools $ getBI dat) + , sdTools = unionsWith (<>) $ flip map (sciBuildTools dat) $ \(Dependency name range) -> singletonMap -- In practice, cabal files refer to the exe name, not the -- package name. @@ -73,7 +69,7 @@ { diComponents = singletonSet component , diRange = simplifyVersionRange range } - , sdModules = getModules dat + , sdModules = sciModules dat } forM_ comps $ \(cond, ontrue, onfalse) -> do b <- checkCond cc cond diff --git a/Stackage/PackageIndex.hs b/Stackage/PackageIndex.hs --- a/Stackage/PackageIndex.hs +++ b/Stackage/PackageIndex.hs @@ -1,14 +1,21 @@ {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE RecordWildCards #-} -- | Dealing with the 00-index file and all its cabal files. module Stackage.PackageIndex ( sourcePackageIndex , UnparsedCabalFile (..) + , SimplifiedPackageDescription (..) + , SimplifiedComponentInfo (..) , getLatestDescriptions ) where @@ -16,27 +23,51 @@ import Data.Conduit.Lazy (MonadActive, lazyConsume) import qualified Data.Text as T -import Distribution.PackageDescription (package, - packageDescription) +import Distribution.Compiler (CompilerFlavor) +import Distribution.ModuleName (ModuleName) +import Distribution.Package (Dependency) +import Distribution.PackageDescription import Distribution.PackageDescription.Parse (ParseResult (..), parsePackageDescription) import Distribution.ParseUtils (PError) +import Distribution.System (Arch, OS) import Stackage.Prelude -import System.Directory (getAppUserDataDirectory) +import Stackage.Update +import Stackage.GithubPings +import System.Directory (doesFileExist, getAppUserDataDirectory, createDirectoryIfMissing) +import System.FilePath (takeDirectory) +import qualified Data.Binary as Bin (Binary) +import qualified Data.Binary.Tagged as Bin +import qualified Data.ByteString.Base16 as B16 +import qualified Crypto.Hash.SHA256 as SHA256 +import Language.Haskell.Extension (Extension, Language, KnownExtension) +import Data.Proxy -- | 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" + let configFile = c "config" + exists <- liftIO $ doesFileExist configFile + remoteCache <- if exists + then do + configLines <- runResourceT $ sourceFile (c "config") + $$ decodeUtf8C + =$ linesUnboundedC + =$ concatMapC getRemoteCache + =$ sinkList + case configLines of + [x] -> return x + [] -> error $ "No remote-repo-cache found in Cabal config file" + _ -> error $ "Multiple remote-repo-cache entries found in Cabal config file" + else return $ c "packages" + + let tarball = remoteCache "hackage.haskell.org" "00-index.tar" + + unlessM (liftIO $ doesFileExist tarball) $ + stackageUpdate defaultStackageUpdateSettings + + return tarball where getCabalRoot :: IO FilePath getCabalRoot = getAppUserDataDirectory "cabal" @@ -51,9 +82,135 @@ data UnparsedCabalFile = UnparsedCabalFile { ucfName :: PackageName , ucfVersion :: Version - , ucfParse :: forall m. MonadThrow m => m GenericPackageDescription + , ucfPath :: FilePath + , ucfContent :: LByteString } +data SimplifiedComponentInfo = SimplifiedComponentInfo + { sciBuildTools :: [Dependency] + , sciModules :: Set Text + } + deriving Generic +instance Bin.Binary SimplifiedComponentInfo +instance Bin.HasStructuralInfo SimplifiedComponentInfo +instance Bin.HasSemanticVersion SimplifiedComponentInfo + +data SimplifiedPackageDescription = SimplifiedPackageDescription + { spdName :: PackageName + , spdVersion :: Version + , spdCondLibrary :: Maybe (CondTree ConfVar [Dependency] SimplifiedComponentInfo) + , spdCondExecutables :: [(String, CondTree ConfVar [Dependency] SimplifiedComponentInfo)] + , spdCondTestSuites :: [(String, CondTree ConfVar [Dependency] SimplifiedComponentInfo)] + , spdCondBenchmarks :: [(String, CondTree ConfVar [Dependency] SimplifiedComponentInfo)] + , spdPackageFlags :: Map FlagName Bool + , spdGithubPings :: Set Text + } + deriving Generic +instance Bin.Binary SimplifiedPackageDescription +instance Bin.HasStructuralInfo SimplifiedPackageDescription +instance Bin.HasSemanticVersion SimplifiedPackageDescription + +-- BEGIN orphans +deriving instance Generic (CondTree v c a) +deriving instance Generic (Condition c) +deriving instance Generic ConfVar + +instance (Bin.Binary v, Bin.Binary c, Bin.Binary a) => Bin.Binary (CondTree v c a) +instance Bin.Binary c => Bin.Binary (Condition c) +instance Bin.Binary ConfVar + +-- special treatment for recursive datatype +instance Bin.HasStructuralInfo a => Bin.HasStructuralInfo (CondTree ConfVar [Dependency] a) where + structuralInfo x = Bin.NominalType + "CondTree ConfVar [Dependency]" + -- FIXME? (Bin.structuralInfo $ getInnerProxy x) + where + getInnerProxy :: Proxy (CondTree c v a) -> Proxy a + getInnerProxy _ = Proxy + +instance Bin.HasStructuralInfo Dependency +instance Bin.HasStructuralInfo v => Bin.HasStructuralInfo (Condition v) where + structuralInfo x = Bin.NominalNewtype + "Condition" + (Bin.structuralInfo $ getInnerProxy x) + where + getInnerProxy :: Proxy (Condition v) -> Proxy v + getInnerProxy _ = Proxy +instance Bin.HasStructuralInfo ConfVar +instance Bin.HasStructuralInfo Arch +instance Bin.HasStructuralInfo OS +instance Bin.HasStructuralInfo CompilerFlavor +instance Bin.HasStructuralInfo PackageName +instance Bin.HasStructuralInfo VersionRange +instance Bin.HasStructuralInfo FlagName +-- END orphans + +gpdToSpd :: GenericPackageDescription -> SimplifiedPackageDescription +gpdToSpd gpd = SimplifiedPackageDescription + { spdName = name + , spdVersion = version + , spdCondLibrary = fmap (mapCondTree simpleLib) $ condLibrary gpd + , spdCondExecutables = map (fmap $ mapCondTree simpleExe) $ condExecutables gpd + , spdCondTestSuites = map (fmap $ mapCondTree simpleTest) $ condTestSuites gpd + , spdCondBenchmarks = map (fmap $ mapCondTree simpleBench) $ condBenchmarks gpd + , spdPackageFlags = + let getFlag MkFlag {..} = (flagName, flagDefault) + in mapFromList $ map getFlag $ genPackageFlags gpd + , spdGithubPings = getGithubPings gpd + } + where + PackageIdentifier name version = package $ packageDescription gpd + + simpleLib = helper getModules libBuildInfo + simpleExe = helper noModules buildInfo + simpleTest = helper noModules testBuildInfo + simpleBench = helper noModules benchmarkBuildInfo + + helper getModules getBI x = SimplifiedComponentInfo + { sciBuildTools = buildTools $ getBI x + , sciModules = getModules x + } + + noModules = const mempty + getModules = setFromList . map display . exposedModules + +deriving instance Functor (CondTree v c) + +mapCondTree :: (a -> b) -> CondTree v c a -> CondTree v c b +mapCondTree = fmap + +ucfParse :: MonadIO m + => FilePath -- ^ ~/.stackage/curator + -> UnparsedCabalFile + -> m SimplifiedPackageDescription +ucfParse root (UnparsedCabalFile name version fp lbs) = liftIO $ do + eres <- tryIO $ Bin.taggedDecodeFileOrFail cache + case eres of + Right (Right x) -> return x + _ -> do + x <- parseFromText + createDirectoryIfMissing True $ takeDirectory cache + Bin.taggedEncodeFile cache x + return x + where + -- location of the binary cache + cache = root "cache" (unpack $ decodeUtf8 $ B16.encode $ SHA256.hashlazy lbs) + + -- Parse the desc from the contents of the .cabal file + parseFromText = + case parsePackageDescription $ unpack $ dropBOM $ decodeUtf8 lbs of + ParseFailed e -> throwM $ CabalParseException fp e + ParseOk _warnings gpd -> do + let pd = packageDescription gpd + PackageIdentifier name' version' = package pd + when (name /= name' || version /= version') $ + throwM $ MismatchedNameVersion fp + name name' version version' + return $ gpdToSpd gpd + + -- https://github.com/haskell/hackage-server/issues/351 + dropBOM t = fromMaybe t $ stripPrefix "\xFEFF" t + -- | 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 @@ -75,24 +232,11 @@ yield UnparsedCabalFile { ucfName = name , ucfVersion = version - , ucfParse = goContent (Tar.entryPath e) name version lbs + , ucfPath = Tar.entryPath e + , ucfContent = lbs } | otherwise = return () - goContent fp name version lbs = - case parsePackageDescription $ unpack $ dropBOM $ decodeUtf8 lbs of - ParseFailed e -> throwM $ CabalParseException fp e - ParseOk _warnings gpd -> do - let pd = packageDescription gpd - PackageIdentifier name' version' = package pd - when (name /= name' || version /= version') $ - throwM $ MismatchedNameVersion fp - name name' version version' - return gpd - - -- https://github.com/haskell/hackage-server/issues/351 - dropBOM t = fromMaybe t $ stripPrefix "\xFEFF" t - parseNameVersion t1 = do let (p', t2) = break (== '/') $ T.replace "\\" "/" t1 p <- simpleParse p' @@ -116,9 +260,11 @@ -- given criterion. getLatestDescriptions :: MonadIO m => (PackageName -> Version -> Bool) - -> (GenericPackageDescription -> IO desc) + -> (SimplifiedPackageDescription -> IO desc) -> m (Map PackageName desc) getLatestDescriptions f parseDesc = liftIO $ do + root <- fmap ( "curator") $ getAppUserDataDirectory "stackage" + -- Parse twice to avoid keeping stuff in memory: once to determine which -- versions to keep, once to do the actual parsing. liftIO $ putStrLn "Determining target package versions" @@ -129,7 +275,7 @@ (\m ucf -> if lookup (ucfName ucf) (asMap mvers) == Just (ucfVersion ucf) then do - desc <- liftIO $ ucfParse ucf >>= parseDesc + desc <- liftIO $ ucfParse root ucf >>= parseDesc return $! insertMap (ucfName ucf) desc m else return m) where diff --git a/Stackage/PerformBuild.hs b/Stackage/PerformBuild.hs --- a/Stackage/PerformBuild.hs +++ b/Stackage/PerformBuild.hs @@ -31,6 +31,7 @@ import System.Directory (doesDirectoryExist, doesFileExist, findExecutable) import qualified System.FilePath as FP import System.Environment (getEnvironment) +import System.Exit import System.IO (IOMode (WriteMode), openBinaryFile) import System.IO.Temp (withSystemTempDirectory) @@ -136,10 +137,12 @@ | pbGlobalInstall pb = Nothing | otherwise = Just $ pbInstallDest pb "pkgdb" -pbBinDir, pbLibDir, pbDataDir, pbDocDir :: PerformBuild -> FilePath +pbBinDir, pbLibDir, pbDataDir, pbLibexecDir, pbSysconfDir, pbDocDir :: PerformBuild -> FilePath pbBinDir pb = pbInstallDest pb "bin" pbLibDir pb = pbInstallDest pb "lib" pbDataDir pb = pbInstallDest pb "share" +pbLibexecDir pb = pbInstallDest pb "libexec" +pbSysconfDir pb = pbInstallDest pb "etc" pbDocDir pb = pbInstallDest pb "doc" -- | Directory keeping previous result info @@ -342,6 +345,8 @@ tell' $ "--libdir=" ++ pack (pbLibDir pb) tell' $ "--bindir=" ++ pack (pbBinDir pb) tell' $ "--datadir=" ++ pack (pbDataDir pb) + tell' $ "--libexecdir=" ++ pack (pbLibexecDir pb) + tell' $ "--sysconfdir=" ++ pack (pbSysconfDir pb) tell' $ "--docdir=" ++ pack (pbDocDir pb unpack namever) tell' $ "--htmldir=" ++ pack (pbDocDir pb unpack namever) tell' $ "--haddockdir=" ++ pack (pbDocDir pb unpack namever) @@ -427,6 +432,8 @@ log' $ "Haddocks " ++ namever hfs <- readTVarIO sbHaddockFiles haddockDeps <- atomically $ getHaddockDeps pbPlan sbHaddockDeps pname + -- See: https://github.com/commercialhaskell/stack/pull/1070/files + (hyped, _, _) <- readProcessWithExitCode "haddock" ["--hyperlinked-source"] "" let hfsOpts = map hfOpt $ filter ((`member` haddockDeps) . toPackageName . fst) $ mapToList hfs @@ -444,7 +451,9 @@ args = ($ hfsOpts) $ execWriter $ do let tell' x = tell (x:) tell' "haddock" - tell' "--hyperlink-source" + tell' $ if hyped == ExitSuccess + then "--haddock-option=--hyperlinked-source" + else "--hyperlink-source" tell' "--html" when pbBuildHoogle $ tell' "--hoogle" tell' "--html-location=../$pkg-$version/" diff --git a/app/stackage.hs b/app/stackage.hs --- a/app/stackage.hs +++ b/app/stackage.hs @@ -37,6 +37,9 @@ <$> target <*> planFile <*> many constraint + <*> many addPackage + <*> many expectTestFailure + <*> many expectHaddockFailure ) addCommand "check" "Verify that a plan is valid" id (checkPlan <$> (fmap Just planFile <|> pure Nothing)) @@ -253,6 +256,30 @@ case simpleParse $ T.pack s of Nothing -> fail $ "Invalid constraint: " ++ s Just d -> return d + + addPackage = + option packageRead + (long "add-package" ++ + metavar "PACKAGE-NAME" ++ + help "Newly added package") + + expectTestFailure = + option packageRead + (long "expect-test-failure" ++ + metavar "PACKAGE-NAME" ++ + help "Newly expected test failures") + + expectHaddockFailure = + option packageRead + (long "expect-haddock-failure" ++ + metavar "PACKAGE-NAME" ++ + help "Newly expected haddock failures") + + packageRead = do + s <- str + case simpleParse $ T.pack s of + Nothing -> fail $ "Invalid package name: " ++ s + Just p -> return p diffsOnly = switch diff --git a/stackage-curator.cabal b/stackage-curator.cabal --- a/stackage-curator.cabal +++ b/stackage-curator.cabal @@ -1,5 +1,5 @@ name: stackage-curator -version: 0.11.0 +version: 0.12.0 synopsis: Tools for curating Stackage bundles description: Please see for a description and documentation. homepage: https://github.com/fpco/stackage @@ -89,11 +89,15 @@ , stackage-metadata >= 0.3 , stackage-install >= 0.1.1 , lucid + , stackage-update + , binary + , binary-tagged executable stackage-curator default-language: Haskell2010 hs-source-dirs: app main-is: stackage.hs + other-modules: Paths_stackage_curator other-extensions: TemplateHaskell build-depends: base , stackage-curator diff --git a/test/Stackage/BuildPlanSpec.hs b/test/Stackage/BuildPlanSpec.hs --- a/test/Stackage/BuildPlanSpec.hs +++ b/test/Stackage/BuildPlanSpec.hs @@ -57,7 +57,8 @@ check :: (Manager -> IO BuildConstraints) -> (BuildConstraints -> IO (Map PackageName PackagePlan)) -> IO () -check readPlanFile getPlans = withManager tlsManagerSettings $ \man -> do +check readPlanFile getPlans = do + man <- newManager tlsManagerSettings bc <- readPlanFile man plans <- getPlans bc bp <- newBuildPlan plans bc @@ -138,7 +139,6 @@ -- | Test plan. testBuildConstraints :: void -> IO BuildConstraints testBuildConstraints _ = - decodeFileEither - (fpToString fp) >>= + decodeFileEither fp >>= either throwIO toBC where fp = "test/test-build-constraints.yaml" diff --git a/test/Stackage/PackageIndexSpec.hs b/test/Stackage/PackageIndexSpec.hs --- a/test/Stackage/PackageIndexSpec.hs +++ b/test/Stackage/PackageIndexSpec.hs @@ -18,4 +18,4 @@ length m `shouldBe` 1 p <- simpleParse $ asText "base" v <- simpleParse $ asText "4.5.0.0" - (pkgVersion . packageId <$> m) `shouldBe` singletonMap p v + (spdVersion <$> m) `shouldBe` singletonMap p v