stackage-curator 0.11.0 → 0.12.0
raw patch · 15 files changed
+350/−109 lines, 15 filesdep +binarydep +binary-tagged
Dependencies added: binary, binary-tagged
Files
- ChangeLog.md +5/−0
- Stackage/BuildConstraints.hs +10/−1
- Stackage/BuildPlan.hs +8/−8
- Stackage/CheckBuildPlan.hs +1/−1
- Stackage/CompleteBuild.hs +22/−2
- Stackage/Curator/UploadDocs.hs +32/−12
- Stackage/DiffPlans.hs +26/−26
- Stackage/GithubPings.hs +9/−4
- Stackage/PackageDescription.hs +14/−18
- Stackage/PackageIndex.hs +176/−30
- Stackage/PerformBuild.hs +11/−2
- app/stackage.hs +27/−0
- stackage-curator.cabal +5/−1
- test/Stackage/BuildPlanSpec.hs +3/−3
- test/Stackage/PackageIndexSpec.hs +1/−1
ChangeLog.md view
@@ -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)
Stackage/BuildConstraints.hs view
@@ -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 ()
Stackage/BuildPlan.hs view
@@ -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 =
Stackage/CheckBuildPlan.hs view
@@ -147,7 +147,7 @@ showUser :: (PkgUser, VersionRange) -> Text showUser (pu, range) = concat- [ "- "+ [ "- [ ] " , pkgUserShow1 pu , " (" -- add a space after < to avoid confusing Markdown processors (like
Stackage/CompleteBuild.hs view
@@ -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
Stackage/Curator/UploadDocs.hs view
@@ -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
Stackage/DiffPlans.hs view
@@ -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
Stackage/GithubPings.hs view
@@ -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
Stackage/PackageDescription.hs view
@@ -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
Stackage/PackageIndex.hs view
@@ -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
Stackage/PerformBuild.hs view
@@ -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/"
app/stackage.hs view
@@ -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
stackage-curator.cabal view
@@ -1,5 +1,5 @@ name: stackage-curator-version: 0.11.0+version: 0.12.0 synopsis: Tools for curating Stackage bundles description: Please see <http://www.stackage.org/package/stackage-curator> 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
test/Stackage/BuildPlanSpec.hs view
@@ -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"
test/Stackage/PackageIndexSpec.hs view
@@ -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