diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,14 @@ # Changelog for pantry +## v0.2.0.0 + +Bug fixes: + +* Don't compare the hashes of cabal files. + Addresses bugs such as [Stack + #5045](https://github.com/commercialhaskell/stack/issues/5045). + Data type changes: removed the `pmCabal` and `rpmCabal` fields. + ## v0.1.1.2 Bug fixes: diff --git a/pantry.cabal b/pantry.cabal --- a/pantry.cabal +++ b/pantry.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: e338943a1a53aa6c588e00a1b9eb2d38801ab6382e7ea4c33b31bd9eea0fb994 +-- hash: abfcc422864de256ba0ef8b533df725b381cffd7791dca94f17303a16e69a2a3 name: pantry -version: 0.1.1.2 +version: 0.2.0.0 synopsis: Content addressable Haskell package management description: Please see the README on Github at category: Development diff --git a/src/Pantry.hs b/src/Pantry.hs --- a/src/Pantry.hs +++ b/src/Pantry.hs @@ -390,10 +390,6 @@ -- -- This function ignores all warnings. -- --- Note that, for now, this will not allow support for hpack files in --- these package locations. Instead, all @PackageLocationImmutable@s --- will require a .cabal file. This may be relaxed in the future. --- -- @since 0.1.0.0 loadCabalFileImmutable :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) @@ -402,24 +398,21 @@ loadCabalFileImmutable loc = withCache $ do logDebug $ "Parsing cabal file for " <> display loc bs <- loadCabalFileBytes loc - let foundCabalKey = bsToBlobKey bs (_warnings, gpd) <- rawParseGPD (Left $ toRawPLI loc) bs let pm = case loc of - PLIHackage (PackageIdentifier name version) cfHash mtree -> PackageMetadata + PLIHackage (PackageIdentifier name version) _cfHash mtree -> PackageMetadata { pmIdent = PackageIdentifier name version , pmTreeKey = mtree - , pmCabal = cfHash } PLIArchive _ pm' -> pm' PLIRepo _ pm' -> pm' let exc = MismatchedPackageMetadata (toRawPLI loc) (toRawPM pm) Nothing - foundCabalKey (gpdPackageIdentifier gpd) + (gpdPackageIdentifier gpd) PackageIdentifier name ver = pmIdent pm maybe (throwIO exc) pure $ do guard $ name == gpdPackageName gpd guard $ ver == gpdVersion gpd - guard $ pmCabal pm == foundCabalKey pure gpd where withCache inner = do @@ -448,26 +441,20 @@ loadCabalFileRawImmutable loc = withCache $ do logDebug $ "Parsing cabal file for " <> display loc bs <- loadRawCabalFileBytes loc - let foundCabalKey = bsToBlobKey bs (_warnings, gpd) <- rawParseGPD (Left loc) bs let rpm = case loc of - RPLIHackage (PackageIdentifierRevision name version cfi) mtree -> RawPackageMetadata + RPLIHackage (PackageIdentifierRevision name version _cfi) mtree -> RawPackageMetadata { rpmName = Just name , rpmVersion = Just version , rpmTreeKey = mtree - , rpmCabal = - case cfi of - CFIHash sha (Just size) -> Just $ BlobKey sha size - _ -> Nothing } RPLIArchive _ rpm' -> rpm' RPLIRepo _ rpm' -> rpm' - let exc = MismatchedPackageMetadata loc rpm Nothing foundCabalKey (gpdPackageIdentifier gpd) + let exc = MismatchedPackageMetadata loc rpm Nothing (gpdPackageIdentifier gpd) maybe (throwIO exc) pure $ do guard $ maybe True (== gpdPackageName gpd) (rpmName rpm) guard $ maybe True (== gpdVersion gpd) (rpmVersion rpm) - guard $ maybe True (== foundCabalKey) (rpmCabal rpm) pure gpd where withCache inner = do @@ -766,9 +753,9 @@ => RawPackageLocationImmutable -> RawPackageMetadata -> RIO env PackageMetadata -completePM plOrig rpm@(RawPackageMetadata mn mv mtk mc) - | Just n <- mn, Just v <- mv, Just tk <- mtk, Just c <- mc = - pure $ PackageMetadata (PackageIdentifier n v) tk c +completePM plOrig rpm@(RawPackageMetadata mn mv mtk) + | Just n <- mn, Just v <- mv, Just tk <- mtk = + pure $ PackageMetadata (PackageIdentifier n v) tk | otherwise = do pm <- packagePM <$> loadPackageRaw plOrig let isSame x (Just y) = x == y @@ -777,8 +764,7 @@ allSame = isSame (pkgName $ pmIdent pm) (rpmName rpm) && isSame (pkgVersion $ pmIdent pm) (rpmVersion rpm) && - isSame (pmTreeKey pm) (rpmTreeKey rpm) && - isSame (pmCabal pm) (rpmCabal rpm) + isSame (pmTreeKey pm) (rpmTreeKey rpm) if allSame then pure pm else throwIO $ CompletePackageMetadataMismatch plOrig pm @@ -787,9 +773,6 @@ packagePM package = PackageMetadata { pmIdent = packageIdent package , pmTreeKey = packageTreeKey package - , pmCabal = teBlob $ case packageCabalEntry package of - PCCabalFile cfile -> cfile - PCHpack hfile -> phGenerated hfile } -- | Add in hashes to make a 'SnapshotLocation' reproducible. diff --git a/src/Pantry/Archive.hs b/src/Pantry/Archive.hs --- a/src/Pantry/Archive.hs +++ b/src/Pantry/Archive.hs @@ -51,12 +51,7 @@ -> RIO env () fetchArchives pairs = -- TODO be more efficient, group together shared archives - fetchArchivesRaw [ - let PackageIdentifier nm ver = pmIdent pm - rpm = RawPackageMetadata (Just nm) (Just ver) (Just $ pmTreeKey pm) (Just $ pmCabal pm) - ra = RawArchive (archiveLocation a) (Just $ archiveHash a) (Just $ archiveSize a) (archiveSubdir a) - in (ra, rpm) - | (a, pm) <- pairs] + fetchArchivesRaw [(toRawArchive a, toRawPM pm) | (a, pm) <- pairs] getArchiveKey :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) @@ -172,15 +167,13 @@ -> Either PantryException Package checkPackageMetadata pl pm pa = do let - pkgCabal = case packageCabalEntry pa of - PCCabalFile tentry -> tentry - PCHpack phpack -> phGenerated phpack err = MismatchedPackageMetadata pl pm (Just (packageTreeKey pa)) - (teBlob pkgCabal) (packageIdent pa) + + test :: Eq a => Maybe a -> a -> Bool test (Just x) y = x == y test Nothing _ = True @@ -188,7 +181,6 @@ [ test (rpmTreeKey pm) (packageTreeKey pa) , test (rpmName pm) (pkgName $ packageIdent pa) , test (rpmVersion pm) (pkgVersion $ packageIdent pa) - , test (rpmCabal pm) (teBlob pkgCabal) ] in if and tests then Right pa else Left err diff --git a/src/Pantry/Hackage.hs b/src/Pantry/Hackage.hs --- a/src/Pantry/Hackage.hs +++ b/src/Pantry/Hackage.hs @@ -586,7 +586,6 @@ { rpmName = Just name , rpmVersion = Just ver , rpmTreeKey = Nothing -- with a revision cabal file will differ giving a different tree - , rpmCabal = Nothing -- cabal file in the tarball may be different! } case packageTree package of TreeMap m -> do diff --git a/src/Pantry/Types.hs b/src/Pantry/Types.hs --- a/src/Pantry/Types.hs +++ b/src/Pantry/Types.hs @@ -807,7 +807,6 @@ !RawPackageLocationImmutable !RawPackageMetadata !(Maybe TreeKey) - !BlobKey -- cabal file found !PackageIdentifier | Non200ResponseStatus !Status | InvalidBlobKey !(Mismatch BlobKey) @@ -920,13 +919,12 @@ display loc <> ":\n" <> displayShow e - display (MismatchedPackageMetadata loc pm mtreeKey foundCabal foundIdent) = + display (MismatchedPackageMetadata loc pm mtreeKey foundIdent) = "Mismatched package metadata for " <> display loc <> - "\nFound: " <> fromString (packageIdentifierString foundIdent) <> " with cabal file " <> - display foundCabal <> + "\nFound: " <> fromString (packageIdentifierString foundIdent) <> (case mtreeKey of Nothing -> mempty - Just treeKey -> " and tree " <> display treeKey) <> + Just treeKey -> " with tree " <> display treeKey) <> "\nExpected: " <> display pm display (Non200ResponseStatus status) = "Unexpected non-200 HTTP status code: " <> @@ -1360,10 +1358,6 @@ -- ^ Tree key of the loaded up package -- -- @since 0.1.0.0 - , rpmCabal :: !(Maybe BlobKey) - -- ^ Blob key containing the cabal file - -- - -- @since 0.1.0.0 } deriving (Show, Eq, Ord, Generic, Typeable) instance NFData RawPackageMetadata @@ -1373,7 +1367,6 @@ [ (\name -> "name == " <> fromString (packageNameString name)) <$> rpmName rpm , (\version -> "version == " <> fromString (versionString version)) <$> rpmVersion rpm , (\tree -> "tree == " <> display tree) <$> rpmTreeKey rpm - , (\cabal -> "cabal file == " <> display cabal) <$> rpmCabal rpm ] -- | Exact metadata specifying concrete package @@ -1388,10 +1381,6 @@ -- ^ Tree key of the loaded up package -- -- @since 0.1.0.0 - , pmCabal :: !BlobKey - -- ^ Blob key containing the cabal file - -- - -- @since 0.1.0.0 } deriving (Show, Eq, Ord, Generic, Typeable) -- i PackageMetadata @@ -1401,12 +1390,11 @@ display pm = fold $ intersperse ", " $ [ "ident == " <> fromString (packageIdentifierString $ pmIdent pm) , "tree == " <> display (pmTreeKey pm) - , "cabal file == " <> display (pmCabal pm) ] parsePackageMetadata :: Object -> WarningParser PackageMetadata parsePackageMetadata o = do - pmCabal :: BlobKey <- o ..: "cabal-file" + _oldCabalFile :: Maybe BlobKey <- o ..:? "cabal-file" pantryTree :: BlobKey <- o ..: "pantry-tree" CabalString pkgName <- o ..: "name" CabalString pkgVersion <- o ..: "version" @@ -1419,7 +1407,7 @@ -- -- @since 0.1.0.0 toRawPM :: PackageMetadata -> RawPackageMetadata -toRawPM pm = RawPackageMetadata (Just name) (Just version) (Just $ pmTreeKey pm) (Just $ pmCabal pm) +toRawPM pm = RawPackageMetadata (Just name) (Just version) (Just $ pmTreeKey pm) where PackageIdentifier name version = pmIdent pm @@ -1520,11 +1508,10 @@ RepoHg -> "hg" rpmToPairs :: RawPackageMetadata -> [(Text, Value)] -rpmToPairs (RawPackageMetadata mname mversion mtree mcabal) = concat +rpmToPairs (RawPackageMetadata mname mversion mtree) = concat [ maybe [] (\name -> ["name" .= CabalString name]) mname , maybe [] (\version -> ["version" .= CabalString version]) mversion , maybe [] (\tree -> ["pantry-tree" .= tree]) mtree - , maybe [] (\cabal -> ["cabal-file" .= cabal]) mcabal ] instance FromJSON (WithJSONWarnings (Unresolved PackageLocationImmutable)) where @@ -1621,12 +1608,21 @@ Just x -> pure $ OSSubdirs x Nothing -> OSPackageMetadata <$> o ..:? "subdir" ..!= T.empty - <*> (RawPackageMetadata + <*> (rawPackageMetadataHelper <$> (fmap unCabalString <$> (o ..:? "name")) <*> (fmap unCabalString <$> (o ..:? "version")) <*> o ..:? "pantry-tree" <*> o ..:? "cabal-file") + rawPackageMetadataHelper + :: Maybe PackageName + -> Maybe Version + -> Maybe TreeKey + -> Maybe BlobKey + -> RawPackageMetadata + rawPackageMetadataHelper name version pantryTree _ignoredCabalFile = + RawPackageMetadata name version pantryTree + repo = withObjectWarnings "UnresolvedPackageLocationImmutable.UPLIRepo" $ \o -> do (repoType, repoUrl) <- ((RepoGit, ) <$> o ..: "git") <|> @@ -1665,7 +1661,7 @@ osToRpms (OSPackageMetadata subdir rpm) = pure (subdir, rpm) rpmEmpty :: RawPackageMetadata -rpmEmpty = RawPackageMetadata Nothing Nothing Nothing Nothing +rpmEmpty = RawPackageMetadata Nothing Nothing Nothing -- | Newtype wrapper for easier JSON integration with Cabal types. -- diff --git a/test/Pantry/ArchiveSpec.hs b/test/Pantry/ArchiveSpec.hs --- a/test/Pantry/ArchiveSpec.hs +++ b/test/Pantry/ArchiveSpec.hs @@ -41,7 +41,6 @@ { rpmName = Nothing , rpmVersion = Nothing , rpmTreeKey = Nothing - , rpmCabal = Nothing } parsePackageIdentifier' :: String -> PackageIdentifier diff --git a/test/Pantry/BuildPlanSpec.hs b/test/Pantry/BuildPlanSpec.hs --- a/test/Pantry/BuildPlanSpec.hs +++ b/test/Pantry/BuildPlanSpec.hs @@ -47,7 +47,6 @@ { rpmName = Nothing , rpmVersion = Nothing , rpmTreeKey = Nothing - , rpmCabal = Nothing } actual <- decode'' contents actual `shouldBe` pure expected @@ -75,7 +74,6 @@ { rpmName = Nothing , rpmVersion = Nothing , rpmTreeKey = Nothing - , rpmCabal = Nothing } actual <- decode'' contents actual `shouldBe` pure expected diff --git a/test/Pantry/CabalSpec.hs b/test/Pantry/CabalSpec.hs --- a/test/Pantry/CabalSpec.hs +++ b/test/Pantry/CabalSpec.hs @@ -11,7 +11,8 @@ spec :: Spec spec = describe "wrong cabal file" $ do - let test name action = it name (runPantryApp action :: IO ()) + let test :: HasCallStack => String -> RIO PantryApp () -> Spec + test name action = it name (runPantryApp action :: IO ()) shouldThrow' x y = withRunInIO $ \run -> run x `shouldThrow` y test "Hackage" $ do sha <- either throwIO pure @@ -30,23 +31,19 @@ size = FileSize 597 go `shouldThrow'` \e -> case e of - MismatchedPackageMetadata rpli' rpm _tree cabal ident -> + MismatchedPackageMetadata rpli' rpm _tree ident -> rpli == rpli' && rpm == RawPackageMetadata { rpmName = Just name , rpmVersion = Just version3 , rpmTreeKey = Nothing - , rpmCabal = Just $ BlobKey sha size } && - cabal == BlobKey sha size && ident == PackageIdentifier name version2 _ -> False test "tarball with wrong ident" $ do archiveHash' <- either throwIO pure $ SHA256.fromHexBytes "b5a582209c50e4a61e4b6c0fb91a6a7d65177a881225438b0144719bc3682c3a" - sha <- either throwIO pure - $ SHA256.fromHexBytes "71c2c685a932cd3a70ec52d7bd0ec96ecbfa5e31e22130099cd50fa073ad1a69" let rpli = RPLIArchive archive rpm archive = RawArchive @@ -59,7 +56,6 @@ RawPackageMetadata { rpmName = Just acmeMissiles , rpmVersion = Just version2 - , rpmCabal = Just $ BlobKey sha (FileSize 597) , rpmTreeKey = Nothing } go = loadCabalFileRawImmutable rpli @@ -67,20 +63,15 @@ version2 = mkVersion [0, 2] go `shouldThrow'` \e -> case e of - MismatchedPackageMetadata rpli' rpm' _treeKey cabal ident -> + MismatchedPackageMetadata rpli' rpm' _treeKey ident -> rpli == rpli' && rpm == rpm' && - cabal == BlobKey - (either impureThrow id $ SHA256.fromHexBytes "940d82426ad1db0fcc978c0f386ac5d06df019546071993cb7c6633f1ad17d50") - (FileSize 3038) && ident == PackageIdentifier (mkPackageName "yesod-auth") (mkVersion [1, 6, 4, 1]) _ -> False test "tarball with wrong cabal file" $ do - sha <- either throwIO pure - $ SHA256.fromHexBytes "71c2c685a932cd3a70ec52d7bd0ec96ecbfa5e31e22130099cd50fa073ad1a69" let rpli = RPLIArchive archive rpm archive = RawArchive @@ -93,20 +84,17 @@ rpm = RawPackageMetadata { rpmName = Just yesodAuth - , rpmVersion = Just version - , rpmCabal = Just $ BlobKey sha (FileSize 597) + , rpmVersion = Just badVersion , rpmTreeKey = Nothing } go = loadCabalFileRawImmutable rpli yesodAuth = mkPackageName "yesod-auth" version = mkVersion [1, 6, 4, 1] + badVersion = mkVersion [1, 6, 4, 0] go `shouldThrow'` \e -> case e of - MismatchedPackageMetadata rpli' rpm' _treeKey cabal ident -> + MismatchedPackageMetadata rpli' rpm' _treeKey ident -> rpli == rpli' && rpm == rpm' && - cabal == BlobKey - (either impureThrow id $ SHA256.fromHexBytes "940d82426ad1db0fcc978c0f386ac5d06df019546071993cb7c6633f1ad17d50") - (FileSize 3038) && ident == PackageIdentifier yesodAuth version _ -> False diff --git a/test/Pantry/TreeSpec.hs b/test/Pantry/TreeSpec.hs --- a/test/Pantry/TreeSpec.hs +++ b/test/Pantry/TreeSpec.hs @@ -5,6 +5,9 @@ import Test.Hspec import RIO import Pantry +import qualified Pantry.SHA256 as SHA256 +import Distribution.Types.PackageName (mkPackageName) +import Distribution.Types.Version (mkVersion) spec :: Spec spec = do @@ -14,7 +17,6 @@ { rpmName = Nothing , rpmVersion = Nothing , rpmTreeKey = Nothing - , rpmCabal = Nothing } mkArchive url = RPLIArchive @@ -58,3 +60,23 @@ pair1 <- loadPackageRaw tarPL pair2 <- loadPackageRaw hgPL liftIO $ pair2 `shouldBe` pair1 + + it "5045 no cabal file" $ asIO $ runPantryAppClean $ do + let rpli = RPLIArchive archive rpm + packageName = mkPackageName "yaml" + version = mkVersion [0, 11, 1, 2] + archive = + RawArchive + { raLocation = ALUrl "https://github.com/snoyberg/yaml/archive/yaml-0.11.1.2.tar.gz" + , raHash = either impureThrow Just + $ SHA256.fromHexBytes "b8564e99c555e670ee487bbf92d03800d955f0e6e16333610ef46534548e0a3d" + , raSize = Just $ FileSize 94198 + , raSubdir = "yaml" + } + rpm = + RawPackageMetadata + { rpmName = Just packageName + , rpmVersion = Just version + , rpmTreeKey = Nothing + } + void $ loadCabalFileRawImmutable rpli diff --git a/test/Pantry/TypesSpec.hs b/test/Pantry/TypesSpec.hs --- a/test/Pantry/TypesSpec.hs +++ b/test/Pantry/TypesSpec.hs @@ -49,6 +49,7 @@ [r| subdir: wai cabal-file: + # This is ignored, only included to make sure we get no warnings size: 1765 sha256: eea52c4967d8609c2f79213d6dffe6d6601034f1471776208404781de7051410 name: wai @@ -63,9 +64,6 @@ samplePLIRepo2 :: ByteString samplePLIRepo2 = [r| -cabal-file: - size: 1863 - sha256: 5ebffc39e75ea1016adcc8426dc31d2040d2cc8a5f4bbce228592ef35e233da2 name: merkle-log version: 0.1.0.0 git: https://github.com/kadena-io/merkle-log.git @@ -167,14 +165,11 @@ "d11d63f1a6a92db8c637a8d33e7953ce6194a3e0" , repoUrl = "https://github.com/yesodweb/wai.git" } - cabalSha = - SHA256.fromHexBytes - "eea52c4967d8609c2f79213d6dffe6d6601034f1471776208404781de7051410" pantrySha = SHA256.fromHexBytes "ecfd0b4b75f435a3f362394807b35e5ef0647b1a25005d44a3632c49db4833d2" - (csha, psha) <- case (cabalSha, pantrySha) of - (Right csha, Right psha) -> pure (csha, psha) + psha <- case pantrySha of + Right psha -> pure psha _ -> fail "Failed decoding sha256" let pkgValue = PackageMetadata @@ -183,7 +178,6 @@ (mkPackageName "wai") (mkVersion [3, 2, 1, 2]) , pmTreeKey = TreeKey (BlobKey psha (FileSize 714)) - , pmCabal = BlobKey csha (FileSize 1765) } pli `shouldBe` PLIRepo repoValue pkgValue