@@ -7,6 +7,8 @@
77-- | Dealing with the 00-index file and all its cabal files.
88module Stackage2.PackageIndex
99 ( sourcePackageIndex
10+ , UnparsedCabalFile (..)
11+ , getLatestDescriptions
1012 ) where
1113
1214import qualified Codec.Archive.Tar as Tar
@@ -14,7 +16,7 @@ import qualified Codec.Archive.Tar.Entry as TarEntry
1416import Data.Conduit.Lazy (MonadActive,
1517 lazyConsume)
1618import qualified Data.Text as T
17−import Distribution.PackageDescription (GenericPackageDescription)
19+import Distribution.PackageDescription (GenericPackageDescription, packageDescription, package)
1820import Distribution.PackageDescription.Parse (ParseResult (..),
1921 parsePackageDescription)
2022import Distribution.ParseUtils (PError)
@@ -42,12 +44,16 @@ getPackageIndexPath = liftIO $ do
4244 ("remote-repo-cache", stripPrefix ":" -> Just v) <- Just $ break (== ':') s
4345 Just $ fpFromText $ T.strip v
4446
47+-- | A cabal file with name and version parsed from the filepath, and the
48+-- package description itself ready to be parsed. It's left in unparsed form
49+-- for efficiency.
4550data UnparsedCabalFile = UnparsedCabalFile
4651 { ucfName :: PackageName
4752 , ucfVersion :: Version
4853 , ucfParse :: forall m. MonadThrow m => m GenericPackageDescription
4954 }
5055
56+-- | Stream all of the cabal files from the 00-index tar file.
5157sourcePackageIndex :: (MonadThrow m, MonadResource m, MonadActive m, MonadBaseControl IO m)
5258 => Producer m UnparsedCabalFile
5359sourcePackageIndex = do
@@ -68,14 +74,20 @@ sourcePackageIndex = do
6874 yield UnparsedCabalFile
6975 { ucfName = name
7076 , ucfVersion = version
71− , ucfParse = goContent (Tar.entryPath e) lbs
77+ , ucfParse = goContent (Tar.entryPath e) name version lbs
7278 }
7379 | otherwise = return ()
7480
75− goContent fp lbs =
81+ goContent fp name version lbs =
7682 case parsePackageDescription $ unpack $ decodeUtf8 lbs of
7783 ParseFailed e -> throwM $ CabalParseException (fpFromString fp) e
78− ParseOk _warnings gpd -> return gpd
84+ ParseOk _warnings gpd -> do
85+ let pd = packageDescription gpd
86+ PackageIdentifier name' version' = package pd
87+ when (name /= name' || version /= version') $
88+ throwM $ MismatchedNameVersion (fpFromString fp)
89+ name name' version version'
90+ return gpd
7991
8092 parseNameVersion t1 = do
8193 let (p', t2) = break (== '/') t1
@@ -92,5 +104,25 @@ data InvalidCabalPath = InvalidCabalPath Text Text
92104instance Exception InvalidCabalPath
93105
94106data CabalParseException = CabalParseException FilePath PError
107+ | MismatchedNameVersion FilePath PackageName PackageName Version Version
95108 deriving (Show, Typeable)
96109instance Exception CabalParseException
110+
111+-- | Get all of the latest descriptions for name/version pairs matching the
112+-- given criterion.
113+getLatestDescriptions :: MonadIO m
114+ => (PackageName -> Version -> Bool)
115+ -> m (Map PackageName (Version, GenericPackageDescription))
116+getLatestDescriptions f = liftIO $ do
117+ m <- runResourceT $ sourcePackageIndex $$ filterC f' =$ foldlC add mempty
118+ forM m $ \ucf -> do
119+ gpd <- ucfParse ucf
120+ return (ucfVersion ucf, gpd)
121+ where
122+ f' ucf = f (ucfName ucf) (ucfVersion ucf)
123+ add m ucf =
124+ case lookup name m of
125+ Just ucf' | ucfVersion ucf < ucfVersion ucf' -> m
126+ _ -> insertMap name ucf m
127+ where
128+ name = ucfName ucf