diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 3dd8be058a..641bbf5b7e 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -506,15 +506,6 @@ instance Display Repo where (if T.null subdir then mempty else " in subdirectory " <> display subdir) -instance FromJSON Repo where - parseJSON = - withObject "Repo" $ \o -> do - repoSubdir <- o .: "subdir" - repoCommit <- o .: "commit" - (repoType, repoUrl) <- - (o .: "git" >>= \url -> pure (RepoGit, url)) <|> - (o .: "hg" >>= \url -> pure (RepoHg, url)) - pure Repo {..} -- An unexported newtype wrapper to hang a 'FromJSON' instance off of. Contains @@ -1411,16 +1402,15 @@ instance Display PackageMetadata where , "cabal file == " <> display (pmCabal pm) ] -instance FromJSON PackageMetadata where - parseJSON = - withObject "PackageMetadata" $ \o -> do - pmCabal :: BlobKey <- o .: "cabal-file" - pantryTree :: BlobKey <- o .: "pantry-tree" - CabalString pkgName <- o .: "name" - CabalString pkgVersion <- o .: "version" - let pmTreeKey = TreeKey pantryTree - pmIdent = PackageIdentifier {..} - pure PackageMetadata {..} +parsePackageMetadata :: Object -> WarningParser PackageMetadata +parsePackageMetadata o = do + pmCabal :: BlobKey <- o ..: "cabal-file" + pantryTree :: BlobKey <- o ..: "pantry-tree" + CabalString pkgName <- o ..: "name" + CabalString pkgVersion <- o ..: "version" + let pmTreeKey = TreeKey pantryTree + pmIdent = PackageIdentifier {..} + pure PackageMetadata {..} -- | Conver package metadata to its "raw" equivalent. @@ -1540,14 +1530,18 @@ instance FromJSON (WithJSONWarnings (Unresolved PackageLocationImmutable)) where <|> fail ("Could not parse a UnresolvedPackageLocationImmutable from: " ++ show v) where repoObject :: Value -> Parser (WithJSONWarnings (Unresolved PackageLocationImmutable)) - repoObject value = do - pm <- parseJSON value - repo <- parseJSON value - pure $ noJSONWarnings $ pure $ PLIRepo repo pm - - archiveObject value = do - pm <- parseJSON value - withObjectWarnings "UnresolvedPackageLocationImmutable.PLIArchive" (\o -> do + repoObject = withObjectWarnings "UnresolvedPackageLocationImmutable.PLIRepo" $ \o -> do + pm <- parsePackageMetadata o + repoSubdir <- o ..:? "subdir" ..!= "" + repoCommit <- o ..: "commit" + (repoType, repoUrl) <- + (o ..: "git" >>= \url -> pure (RepoGit, url)) <|> + (o ..: "hg" >>= \url -> pure (RepoHg, url)) + pure $ pure $ PLIRepo Repo {..} pm + + archiveObject = + withObjectWarnings "UnresolvedPackageLocationImmutable.PLIArchive" $ \o -> do + pm <- parsePackageMetadata o Unresolved mkArchiveLocation <- parseArchiveLocationObject o archiveHash <- o ..: "sha256" archiveSize <- o ..: "size" @@ -1555,20 +1549,19 @@ instance FromJSON (WithJSONWarnings (Unresolved PackageLocationImmutable)) where pure $ Unresolved $ \mdir -> do archiveLocation <- mkArchiveLocation mdir pure $ PLIArchive Archive {..} pm - ) value - hackageObject value = - withObjectWarnings "UnresolvedPackagelocationimmutable.PLIHackage (Object)" (\o -> do + hackageObject = + withObjectWarnings "UnresolvedPackagelocationimmutable.PLIHackage (Object)" $ \o -> do treeKey <- o ..: "pantry-tree" htxt <- o ..: "hackage" case parseHackageText htxt of Left e -> fail $ show e Right (pkgIdentifier, blobKey) -> - pure $ pure $ PLIHackage pkgIdentifier blobKey (TreeKey treeKey)) value + pure $ pure $ PLIHackage pkgIdentifier blobKey (TreeKey treeKey) - github value = do - pm <- parseJSON value + github value = withObjectWarnings "UnresolvedPackagelocationimmutable.PLIArchive:github" (\o -> do + pm <- parsePackageMetadata o GitHubRepo ghRepo <- o ..: "github" commit <- o ..: "commit" let archiveLocation = ALUrl $ T.concat @@ -1580,7 +1573,7 @@ instance FromJSON (WithJSONWarnings (Unresolved PackageLocationImmutable)) where ] archiveHash <- o ..: "sha256" archiveSize <- o ..: "size" - archiveSubdir <- o ..: "subdir" + archiveSubdir <- o ..:? "subdir" ..!= "" pure $ pure $ PLIArchive Archive {..} pm) value instance FromJSON (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocationImmutable))) where @@ -1594,7 +1587,7 @@ instance FromJSON (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocationImmu <|> fail ("Could not parse a UnresolvedRawPackageLocationImmutable from: " ++ show v) where http :: Value -> Parser (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocationImmutable))) - http = withText "UnresolvedPackageLocationImmutable.UPLIArchive (Text)" $ \t -> + http = withText "UnresolvedPackageLocationImmutable.RPLIArchive (Text)" $ \t -> case parseArchiveLocationText t of Nothing -> fail $ "Invalid archive location: " ++ T.unpack t Just (Unresolved mkArchiveLocation) -> @@ -1640,7 +1633,7 @@ instance FromJSON (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocationImmu os <- optionalSubdirs o pure $ pure $ NE.map (\(repoSubdir, pm) -> RPLIRepo Repo {..} pm) (osToRpms os) - archiveObject = withObjectWarnings "UnresolvedPackageLocationImmutable.UPLIArchive" $ \o -> do + archiveObject = withObjectWarnings "UnresolvedPackageLocationImmutable.RPLIArchive" $ \o -> do Unresolved mkArchiveLocation <- parseArchiveLocationObject o raHash <- o ..:? "sha256" raSize <- o ..:? "size" diff --git a/subs/pantry/test/Pantry/TypesSpec.hs b/subs/pantry/test/Pantry/TypesSpec.hs index 2de9e75ee0..70fcba5865 100644 --- a/subs/pantry/test/Pantry/TypesSpec.hs +++ b/subs/pantry/test/Pantry/TypesSpec.hs @@ -60,6 +60,21 @@ pantry-tree: commit: d11d63f1a6a92db8c637a8d33e7953ce6194a3e0 |] +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 +pantry-tree: + size: 615 + sha256: 5a99e5e41ccd675a7721a733714ba2096f4204d9010f867c5fb7095b78e2959d +commit: a7ae61d7082afe3aa1a0fd0546fc1351a2f7c376 +|] + spec :: Spec spec = do describe "WantedCompiler" $ do @@ -140,11 +155,10 @@ spec = do liftIO $ Yaml.toJSON (nightlySnapshotLocation day) `shouldBe` Yaml.String (T.pack $ "nightly-" ++ show day) - it "FromJSON instance for Repo" $ do - repValue <- - case Yaml.decodeThrow samplePLIRepo of - Just x -> pure x - Nothing -> fail "Can't parse Repo" + it "FromJSON instance for PLIRepo" $ do + WithJSONWarnings unresolvedPli warnings <- Yaml.decodeThrow samplePLIRepo + warnings `shouldBe` [] + pli <- resolvePaths Nothing unresolvedPli let repoValue = Repo { repoSubdir = "wai" @@ -153,13 +167,7 @@ spec = do "d11d63f1a6a92db8c637a8d33e7953ce6194a3e0" , repoUrl = "https://github.com/yesodweb/wai.git" } - repValue `shouldBe` repoValue - it "FromJSON instance for PackageMetadata" $ do - pkgMeta <- - case Yaml.decodeThrow samplePLIRepo of - Just x -> pure x - Nothing -> fail "Can't parse Repo" - let cabalSha = + cabalSha = SHA256.fromHexBytes "eea52c4967d8609c2f79213d6dffe6d6601034f1471776208404781de7051410" pantrySha = @@ -177,7 +185,12 @@ spec = do , pmTreeKey = TreeKey (BlobKey psha (FileSize 714)) , pmCabal = BlobKey csha (FileSize 1765) } - pkgMeta `shouldBe` pkgValue + pli `shouldBe` PLIRepo repoValue pkgValue + + WithJSONWarnings reparsed warnings2 <- Yaml.decodeThrow $ Yaml.encode pli + warnings2 `shouldBe` [] + reparsed' <- resolvePaths Nothing reparsed + reparsed' `shouldBe` pli it "parseHackageText parses" $ do let txt = "persistent-2.8.2@sha256:df118e99f0c46715e932fe82d787fc09689d87898f3a8b13f5954d25af6b46a1,5058" @@ -193,3 +206,11 @@ spec = do PackageIdentifier (mkPackageName "persistent") (mkVersion [2, 8, 2]) + it "roundtripping a PLIRepo" $ do + WithJSONWarnings unresolvedPli warnings <- Yaml.decodeThrow samplePLIRepo2 + warnings `shouldBe` [] + pli <- resolvePaths Nothing unresolvedPli + WithJSONWarnings unresolvedPli2 warnings2 <- Yaml.decodeThrow $ Yaml.encode pli + warnings2 `shouldBe` [] + pli2 <- resolvePaths Nothing unresolvedPli2 + pli2 `shouldBe` (pli :: PackageLocationImmutable)