diff --git a/Stackage2/PackageIndex.hs b/Stackage2/PackageIndex.hs index bd5ccbe6..d120cc80 100644 --- a/Stackage2/PackageIndex.hs +++ b/Stackage2/PackageIndex.hs @@ -7,6 +7,8 @@ -- | Dealing with the 00-index file and all its cabal files. module Stackage2.PackageIndex ( sourcePackageIndex + , UnparsedCabalFile (..) + , getLatestDescriptions ) where import qualified Codec.Archive.Tar as Tar @@ -14,7 +16,7 @@ import qualified Codec.Archive.Tar.Entry as TarEntry import Data.Conduit.Lazy (MonadActive, lazyConsume) import qualified Data.Text as T -import Distribution.PackageDescription (GenericPackageDescription) +import Distribution.PackageDescription (GenericPackageDescription, packageDescription, package) import Distribution.PackageDescription.Parse (ParseResult (..), parsePackageDescription) import Distribution.ParseUtils (PError) @@ -42,12 +44,16 @@ getPackageIndexPath = liftIO $ 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 @@ -68,14 +74,20 @@ sourcePackageIndex = do yield UnparsedCabalFile { ucfName = name , ucfVersion = version - , ucfParse = goContent (Tar.entryPath e) lbs + , ucfParse = goContent (Tar.entryPath e) name version lbs } | otherwise = return () - goContent fp lbs = + goContent fp name version lbs = case parsePackageDescription $ unpack $ decodeUtf8 lbs of ParseFailed e -> throwM $ CabalParseException (fpFromString fp) e - ParseOk _warnings gpd -> return gpd + 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 (== '/') t1 @@ -92,5 +104,25 @@ data InvalidCabalPath = InvalidCabalPath Text Text 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) + -> m (Map PackageName (Version, GenericPackageDescription)) +getLatestDescriptions f = liftIO $ do + m <- runResourceT $ sourcePackageIndex $$ filterC f' =$ foldlC add mempty + forM m $ \ucf -> do + gpd <- ucfParse ucf + return (ucfVersion ucf, gpd) + 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/Stackage2/Prelude.hs b/Stackage2/Prelude.hs index 1fe3dc2e..f0790c25 100644 --- a/Stackage2/Prelude.hs +++ b/Stackage2/Prelude.hs @@ -10,7 +10,8 @@ module Stackage2.Prelude import ClassyPrelude.Conduit as X import Data.Conduit.Process as X import Data.Typeable (TypeRep, typeOf) -import Distribution.Package as X (PackageName (PackageName)) +import Distribution.Package as X (PackageIdentifier (..), + PackageName (PackageName)) import qualified Distribution.Text as DT import Distribution.Version as X (Version (..), VersionRange) import System.Exit (ExitCode (ExitSuccess)) diff --git a/test/Stackage2/PackageIndexSpec.hs b/test/Stackage2/PackageIndexSpec.hs index 8dcf1df9..c5b17418 100644 --- a/test/Stackage2/PackageIndexSpec.hs +++ b/test/Stackage2/PackageIndexSpec.hs @@ -6,4 +6,15 @@ import Stackage2.Prelude import Test.Hspec spec :: Spec -spec = it "works" $ (runResourceT $ sourcePackageIndex $$ sinkNull :: IO ()) +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 + length m `shouldBe` 1 + p <- simpleParse $ asText "base" + v <- simpleParse $ asText "4.5.0.0" + (fst <$> m) `shouldBe` singletonMap p v