a97335f · stackage · git.iko.soy

git.iko.soy/stackage

on master help sign in

getLatestDescriptions

a97335fMichael Snoyman12 years ago

Stackage2/PackageIndex.hs+36−4

compare with master

unifiedsplit

@@ -7,6 +7,8 @@

7-- | Dealing with the 00-index file and all its cabal files.

8module Stackage2.PackageIndex

9 ( sourcePackageIndex

10+ , UnparsedCabalFile (..)

11+ , getLatestDescriptions

10 ) where

12 ) where

12import qualified Codec.Archive.Tar as Tar

14import qualified Codec.Archive.Tar as Tar

@@ -14,7 +16,7 @@ import qualified Codec.Archive.Tar.Entry as TarEntry

14import Data.Conduit.Lazy (MonadActive,

16import Data.Conduit.Lazy (MonadActive,

15 lazyConsume)

17 lazyConsume)

16import qualified Data.Text as T

18import qualified Data.Text as T

17−import Distribution.PackageDescription (GenericPackageDescription)

19+import Distribution.PackageDescription (GenericPackageDescription, packageDescription, package)

18import Distribution.PackageDescription.Parse (ParseResult (..),

20import Distribution.PackageDescription.Parse (ParseResult (..),

19 parsePackageDescription)

21 parsePackageDescription)

20import Distribution.ParseUtils (PError)

22import Distribution.ParseUtils (PError)

@@ -42,12 +44,16 @@ getPackageIndexPath = liftIO $ do

42 ("remote-repo-cache", stripPrefix ":" -> Just v) <- Just $ break (== ':') s

44 ("remote-repo-cache", stripPrefix ":" -> Just v) <- Just $ break (== ':') s

43 Just $ fpFromText $ T.strip v

45 Just $ fpFromText $ T.strip v

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.

45data UnparsedCabalFile = UnparsedCabalFile

50data UnparsedCabalFile = UnparsedCabalFile

46 { ucfName :: PackageName

51 { ucfName :: PackageName

47 , ucfVersion :: Version

52 , ucfVersion :: Version

48 , ucfParse :: forall m. MonadThrow m => m GenericPackageDescription

53 , ucfParse :: forall m. MonadThrow m => m GenericPackageDescription

49 }

54 }

56+-- | Stream all of the cabal files from the 00-index tar file.

51sourcePackageIndex :: (MonadThrow m, MonadResource m, MonadActive m, MonadBaseControl IO m)

57sourcePackageIndex :: (MonadThrow m, MonadResource m, MonadActive m, MonadBaseControl IO m)

52 => Producer m UnparsedCabalFile

58 => Producer m UnparsedCabalFile

53sourcePackageIndex = do

59sourcePackageIndex = do

@@ -68,14 +74,20 @@ sourcePackageIndex = do

68 yield UnparsedCabalFile

74 yield UnparsedCabalFile

69 { ucfName = name

75 { ucfName = name

70 , ucfVersion = version

76 , ucfVersion = version

71− , ucfParse = goContent (Tar.entryPath e) lbs

77+ , ucfParse = goContent (Tar.entryPath e) name version lbs

72 }

78 }

73 | otherwise = return ()

79 | otherwise = return ()

75− goContent fp lbs =

81+ goContent fp name version lbs =

76 case parsePackageDescription $ unpack $ decodeUtf8 lbs of

82 case parsePackageDescription $ unpack $ decodeUtf8 lbs of

77 ParseFailed e -> throwM $ CabalParseException (fpFromString fp) e

83 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

80 parseNameVersion t1 = do

92 parseNameVersion t1 = do

81 let (p', t2) = break (== '/') t1

93 let (p', t2) = break (== '/') t1

@@ -92,5 +104,25 @@ data InvalidCabalPath = InvalidCabalPath Text Text

92instance Exception InvalidCabalPath

104instance Exception InvalidCabalPath

105

94data CabalParseException = CabalParseException FilePath PError

106data CabalParseException = CabalParseException FilePath PError

107+ | MismatchedNameVersion FilePath PackageName PackageName Version Version

95 deriving (Show, Typeable)

108 deriving (Show, Typeable)

96instance Exception CabalParseException

109instance 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

Stackage2/Prelude.hs+2−1

@@ -10,7 +10,8 @@ module Stackage2.Prelude

10import ClassyPrelude.Conduit as X

11import Data.Conduit.Process as X

12import Data.Typeable (TypeRep, typeOf)

13+import Distribution.Package as X (PackageIdentifier (..),

13−import Distribution.Package as X (PackageName (PackageName))

14+ PackageName (PackageName))

14import qualified Distribution.Text as DT

15import qualified Distribution.Text as DT

15import Distribution.Version as X (Version (..), VersionRange)

16import Distribution.Version as X (Version (..), VersionRange)

16import System.Exit (ExitCode (ExitSuccess))

17import System.Exit (ExitCode (ExitSuccess))

test/Stackage2/PackageIndexSpec.hs+12−1

@@ -6,4 +6,15 @@ import Stackage2.Prelude

6import Test.Hspec

8spec :: Spec

9+spec = do

9−spec = it "works" $ (runResourceT $ sourcePackageIndex $$ sinkNull :: IO ())

10+ it "works" $ (runResourceT $ sourcePackageIndex $$ sinkNull :: IO ())

11+ it "getLatestDescriptions gives reasonable results" $ do

12+ let f x y = (display x, display y) `member` asSet (setFromList

13+ [ (asText "base", asText "4.5.0.0")

14+ , ("does-not-exist", "9999999999999999999")

15+ ])

16+ m <- getLatestDescriptions f

17+ length m `shouldBe` 1

18+ p <- simpleParse $ asText "base"

19+ v <- simpleParse $ asText "4.5.0.0"

20+ (fst <$> m) `shouldBe` singletonMap p v