From 3f0544366f87f18aa5e4a536c0b334d0969bd1a5 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 30 Apr 2019 22:46:32 +0300 Subject: [PATCH] Fix some misplaced parse warnings #4789 Instead of FromJSON instances for Repo and PackageMetadata, use the Data.Aeson.Extended mechanisms to properly track which fields are used. --- subs/pantry/src/Pantry/Types.hs | 63 +++++++++++++--------------- subs/pantry/test/Pantry/TypesSpec.hs | 19 +++------ 2 files changed, 34 insertions(+), 48 deletions(-) diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 3dd8be058a..cdfab7b860 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 @@ -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..7f00e3c085 100644 --- a/subs/pantry/test/Pantry/TypesSpec.hs +++ b/subs/pantry/test/Pantry/TypesSpec.hs @@ -140,11 +140,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 +152,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 +170,7 @@ spec = do , pmTreeKey = TreeKey (BlobKey psha (FileSize 714)) , pmCabal = BlobKey csha (FileSize 1765) } - pkgMeta `shouldBe` pkgValue + pli `shouldBe` PLIRepo repoValue pkgValue it "parseHackageText parses" $ do let txt = "persistent-2.8.2@sha256:df118e99f0c46715e932fe82d787fc09689d87898f3a8b13f5954d25af6b46a1,5058"