getLatestDescriptions

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

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))

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