server: codecs for remote schemas metadata

These codecs should fully cover the `remote_schemas` property of the Metadata type.

Ticket: [GDC-522](https://hasurahq.atlassian.net/browse/GDC-522)

PR-URL: https://github.com/hasura/graphql-engine-mono/pull/6812
GitOrigin-RevId: 1b256f6829486295957c232b92ff184bd9a86469

server/src-lib/Autodocodec/Extended.hs

@@ -1,6 +1,7 @@
 module Autodocodec.Extended
   ( graphQLFieldNameCodec,
     graphQLValueCodec,
+    graphQLSchemaDocumentCodec,
     hashSetCodec,
     hashSetCodecWith,
     integerCodec,
@@ -18,11 +19,14 @@ import Data.Text qualified as T
 import Data.Typeable (Typeable)
 import Hasura.Metadata.DTO.Utils (typeableName)
 import Hasura.Prelude
+import Language.GraphQL.Draft.Parser qualified as GParser
+import Language.GraphQL.Draft.Printer qualified as GPrinter
 import Language.GraphQL.Draft.Syntax qualified as G
+import Text.Builder qualified as TB
 
 -- | Codec for a GraphQL field name
 graphQLFieldNameCodec :: JSONCodec G.Name
-graphQLFieldNameCodec = bimapCodec dec enc codec
+graphQLFieldNameCodec = named "GraphQLName" $ bimapCodec dec enc codec
   where
     dec text =
       maybeToEither ("invalid GraphQL field name '" <> T.unpack text <> "'") $
@@ -70,6 +74,12 @@ graphQLValueCodec varCodec =
           enc _ = error msg -- encoding is supposed to be total so we need an exception here
        in bimapCodec dec enc nullCodec
 
+graphQLSchemaDocumentCodec :: JSONCodec G.SchemaDocument
+graphQLSchemaDocumentCodec = named "GraphQLSchema" $ bimapCodec dec enc $ codec @Text
+  where
+    dec = mapLeft T.unpack . GParser.parseSchemaDocument
+    enc = TB.run . GPrinter.schemaDocument
+
 -- | Serializes a hash set by converting it to a list. This matches the FromJSON
 -- and ToJSON instances in aeson.
 hashSetCodec :: (Hashable a, HasCodec a) => JSONCodec (HashSet a)

server/src-lib/Data/HashMap/Strict/InsOrd/Autodocodec.hs

@@ -1,5 +1,7 @@
 module Data.HashMap.Strict.InsOrd.Autodocodec
-  ( sortedElemsCodec,
+  ( insertionOrderedElemsCodec,
+    insertionOrderedElemsCodecWith,
+    sortedElemsCodec,
     sortedElemsCodecWith,
   )
 where
@@ -24,17 +26,40 @@ sortedElemsCodec = sortedElemsCodecWith codec
 -- This version is useful if there is no 'HasCodec' instance for the type of the
 -- hash map values. You supply a codec as an argument instead.
 sortedElemsCodecWith :: (Hashable k, Ord k, T.ToTxt k) => JSONCodec a -> (a -> k) -> JSONCodec (InsOrdHashMap k a)
-sortedElemsCodecWith valueCodec keyForElem = bimapCodec dec enc $ listCodec valueCodec
+sortedElemsCodecWith elemCodec keyForElem = bimapCodec dec enc $ listCodec elemCodec
   where
-    dec xs =
+    dec = fromListWithDuplicateCheck elemCodec keyForElem
-      let dupKeys = duplicates $ map keyForElem xs
-       in if null dupKeys
-            then Right $ oMapFromL keyForElem xs
-            else Left $ T.unpack $ errMsg <> T.commaSeparated dupKeys
-
     enc = sortOn keyForElem . elems
 
-    errMsg = case codecName valueCodec of
+-- | Codec for ordered hash maps that serializes to a list. Elements are ordered
+-- according to insertion order in the map. A function to map from elements to
+-- key is used on deserialization.
+--
+-- This version is useful if there is no 'HasCodec' instance for the type of the
+-- hash map values. You supply a codec as an argument instead.
+insertionOrderedElemsCodec :: (Hashable k, HasCodec a, T.ToTxt k) => (a -> k) -> JSONCodec (InsOrdHashMap k a)
+insertionOrderedElemsCodec = insertionOrderedElemsCodecWith codec
+
+-- | Codec for ordered hash maps that serializes to a list. Elements are ordered
+-- according to insertion order in the map. A function to map from elements to
+-- key is used on deserialization.
+--
+-- This version is useful if there is no 'HasCodec' instance for the type of the
+-- hash map values. You supply a codec as an argument instead.
+insertionOrderedElemsCodecWith :: (Hashable k, T.ToTxt k) => JSONCodec a -> (a -> k) -> JSONCodec (InsOrdHashMap k a)
+insertionOrderedElemsCodecWith elemCodec keyForElem = bimapCodec dec enc $ listCodec elemCodec
+  where
+    dec = fromListWithDuplicateCheck elemCodec keyForElem
+    enc = elems
+
+fromListWithDuplicateCheck :: (Hashable k, T.ToTxt k) => JSONCodec a -> (a -> k) -> [a] -> Either String (InsOrdHashMap k a)
+fromListWithDuplicateCheck elemCodec keyForElem xs =
+  let dupKeys = duplicates $ map keyForElem xs
+   in if null dupKeys
+        then Right $ oMapFromL keyForElem xs
+        else Left $ T.unpack $ errMsg <> T.commaSeparated dupKeys
+  where
+    errMsg = case codecName elemCodec of
       (Just t) -> "multiple " <> t <> " declarations exist: "
       Nothing -> "multiple declarations exist: "
 

server/src-lib/Hasura/Metadata/DTO/MetadataV3.hs

@@ -1,20 +1,32 @@
+{-# LANGUAGE OverloadedLists #-}
+
 module Hasura.Metadata.DTO.MetadataV3 (MetadataV3 (..)) where
 
-import Autodocodec (Autodocodec (Autodocodec), HasCodec (codec), object, optionalField, requiredFieldWith, (.=))
+import Autodocodec
+  ( Autodocodec (Autodocodec),
+    HasCodec (codec),
+    object,
+    optionalField,
+    optionalFieldWithOmittedDefaultWith,
+    requiredFieldWith,
+    (.=),
+  )
 import Autodocodec.OpenAPI ()
 import Data.Aeson (FromJSON, ToJSON)
+import Data.HashMap.Strict.InsOrd.Autodocodec (sortedElemsCodec)
 import Data.OpenApi qualified as OpenApi
 import Hasura.Metadata.DTO.Placeholder (PlaceholderArray, PlaceholderObject)
 import Hasura.Metadata.DTO.Utils (versionField)
 import Hasura.Prelude
-import Hasura.RQL.Types.Metadata.Common (Sources, sourcesCodec)
+import Hasura.RQL.Types.Metadata.Common (RemoteSchemas, Sources, sourcesCodec)
+import Hasura.RemoteSchema.Metadata.Core (RemoteSchemaMetadataG (_rsmName))
 
 -- | Revision 3 of the Metadata export format. Note that values of the types,
 -- 'PlaceholderArray' and 'PlaceholderObject' are placeholders that will
 -- eventually be expanded to represent more detail.
 data MetadataV3 = MetadataV3
   { metaV3Sources :: Sources,
-    metaV3RemoteSchemas :: Maybe PlaceholderArray,
+    metaV3RemoteSchemas :: RemoteSchemas,
     metaV3QueryCollections :: Maybe PlaceholderArray,
     metaV3Allowlist :: Maybe PlaceholderArray,
     metaV3Actions :: Maybe PlaceholderArray,
@@ -43,7 +55,7 @@ instance HasCodec MetadataV3 where
       MetadataV3
         <$ versionField 3
         <*> requiredFieldWith "sources" sourcesCodec "configured databases" .= metaV3Sources
-        <*> optionalField "remote_schemas" "merge remote GraphQL schemas and provide a unified GraphQL API" .= metaV3RemoteSchemas
+        <*> optionalFieldWithOmittedDefaultWith "remote_schemas" (sortedElemsCodec _rsmName) [] "merge remote GraphQL schemas and provide a unified GraphQL API" .= metaV3RemoteSchemas
         <*> optionalField "query_collections" "group queries using query collections" .= metaV3QueryCollections
         <*> optionalField "allowlist" "safe GraphQL operations - when allow lists are enabled only these operations are allowed" .= metaV3Allowlist
         <*> optionalField "actions" "action definitions which extend Hasura's schema with custom business logic using custom queries and mutations" .= metaV3Actions

server/src-lib/Hasura/RQL/DDL/Headers.hs

@@ -6,6 +6,8 @@ module Hasura.RQL.DDL.Headers
   )
 where
 
+import Autodocodec (HasCodec (codec), dimapCodec, disjointEitherCodec, requiredField')
+import Autodocodec qualified as AC
 import Data.Aeson
 import Data.CaseInsensitive qualified as CI
 import Data.Environment qualified as Env
@@ -31,6 +33,31 @@ instance NFData HeaderValue
 
 instance Hashable HeaderValue
 
+instance HasCodec HeaderConf where
+  codec =
+    dimapCodec
+      ( either
+          (\(name, value) -> HeaderConf name (HVValue value))
+          (\(name, value) -> HeaderConf name (HVEnv value))
+      )
+      ( \case
+          HeaderConf name (HVValue value) -> Left (name, value)
+          HeaderConf name (HVEnv value) -> Right (name, value)
+      )
+      $ disjointEitherCodec valueCodec fromEnvCodec
+    where
+      valueCodec =
+        AC.object "HeaderConfValue" $
+          (,)
+            <$> requiredField' "name" AC..= fst
+            <*> requiredField' "value" AC..= snd
+
+      fromEnvCodec =
+        AC.object "HeaderConfFromEnv" $
+          (,)
+            <$> requiredField' "name" AC..= fst
+            <*> requiredField' "value_from_env" AC..= snd
+
 instance FromJSON HeaderConf where
   parseJSON (Object o) = do
     name <- o .: "name"

server/src-lib/Hasura/RQL/Types/Common.hs

@@ -42,6 +42,7 @@ module Hasura.RQL.Types.Common
     ApolloFederationVersion (..),
     isApolloFedV1enabled,
     RemoteRelationshipG (..),
+    remoteRelationshipCodec,
     rrDefinition,
     rrName,
     TriggerOnReplication (..),
@@ -50,12 +51,14 @@ where
 
 import Autodocodec
   ( HasCodec (codec),
+    JSONCodec,
     bimapCodec,
     dimapCodec,
     disjointEitherCodec,
     optionalFieldOrNull',
     requiredField,
     requiredField',
+    requiredFieldWith',
     stringConstCodec,
   )
 import Autodocodec qualified as AC
@@ -71,6 +74,7 @@ import Data.Scientific (toBoundedInteger)
 import Data.Text qualified as T
 import Data.Text.Extended
 import Data.Text.NonEmpty
+import Data.Typeable (Typeable)
 import Data.URL.Template
 import Database.PG.Query qualified as PG
 import Hasura.Base.Error
@@ -78,7 +82,7 @@ import Hasura.Base.ErrorValue qualified as ErrorValue
 import Hasura.Base.ToErrorValue
 import Hasura.EncJSON
 import Hasura.GraphQL.Schema.Options qualified as Options
-import Hasura.Metadata.DTO.Utils (fromEnvCodec)
+import Hasura.Metadata.DTO.Utils (fromEnvCodec, typeableName)
 import Hasura.Prelude
 import Hasura.RQL.DDL.Headers ()
 import Language.GraphQL.Draft.Syntax qualified as G
@@ -666,5 +670,16 @@ data RemoteRelationshipG definition = RemoteRelationship
   }
   deriving (Show, Eq, Generic)
 
+remoteRelationshipCodec ::
+  forall definition.
+  (Typeable definition) =>
+  JSONCodec definition ->
+  JSONCodec (RemoteRelationshipG definition)
+remoteRelationshipCodec definitionCodec =
+  AC.object ("RemoteRelationship_" <> typeableName @definition) $
+    RemoteRelationship
+      <$> requiredField' "name" AC..= _rrName
+      <*> requiredFieldWith' "definition" definitionCodec AC..= _rrDefinition
+
 $(makeLenses ''RemoteRelationshipG)
 $(deriveToJSON hasuraJSON {J.omitNothingFields = False} ''RemoteRelationshipG)

server/src-lib/Hasura/RQL/Types/Metadata.hs

@@ -510,7 +510,7 @@ metadataToDTO
     ) =
     MetadataV3
       { metaV3Sources = sources,
-        metaV3RemoteSchemas = placeholder <$> remoteSchemasToOrdJSONList remoteSchemas,
+        metaV3RemoteSchemas = remoteSchemas,
         metaV3QueryCollections = placeholder <$> queryCollectionsToOrdJSONList queryCollections,
         metaV3Allowlist = placeholder <$> allowlistToOrdJSONList allowlist,
         metaV3Actions = placeholder <$> actionMetadataToOrdJSONList actions,

server/src-lib/Hasura/RQL/Types/Relationships/Remote.hs

@@ -48,14 +48,7 @@ import Hasura.SQL.Backend
 type RemoteRelationship = RemoteRelationshipG RemoteRelationshipDefinition
 
 instance HasCodec RemoteRelationship where
-  codec =
+  codec = remoteRelationshipCodec $ remoteRelationshipDefinitionCodec RRPLenient
-    AC.object "RemoteRelationship" $
-      RemoteRelationship
-        <$> requiredField' "name" AC..= _rrName
-        <*> requiredFieldWith'
-          "definition"
-          (remoteRelationshipDefinitionCodec RRPLenient)
-          AC..= _rrDefinition
 
 instance FromJSON RemoteRelationship where
   parseJSON = withObject "RemoteRelationship" $ \obj ->

server/src-lib/Hasura/RemoteSchema/Metadata/Core.hs

@@ -16,13 +16,18 @@ module Hasura.RemoteSchema.Metadata.Core
   )
 where
 
+import Autodocodec (object, optionalField', optionalFieldWithDefault', optionalFieldWithDefaultWith', requiredField', (.=))
+import Autodocodec.Class (HasCodec (codec))
 import Control.Lens (makeLenses)
 import Data.Aeson qualified as J
 import Data.Aeson.TH qualified as J
 import Data.Environment qualified as Env
+import Data.HashMap.Strict.InsOrd.Autodocodec (insertionOrderedElemsCodec)
 import Data.HashMap.Strict.InsOrd.Extended qualified as OM
 import Data.Text qualified as T
+import Data.Typeable (Typeable)
 import Hasura.Base.Error
+import Hasura.Metadata.DTO.Utils (typeableName)
 import Hasura.Prelude
 import Hasura.RQL.DDL.Headers (HeaderConf (..))
 import Hasura.RQL.Types.Common
@@ -53,6 +58,17 @@ data RemoteSchemaDef = RemoteSchemaDef
 
 instance NFData RemoteSchemaDef
 
+instance HasCodec RemoteSchemaDef where
+  codec =
+    object "RemoteSchemaDef" $
+      RemoteSchemaDef
+        <$> optionalField' "url" .= _rsdUrl
+        <*> optionalField' "url_from_env" .= _rsdUrlFromEnv
+        <*> optionalField' "headers" .= _rsdHeaders
+        <*> optionalFieldWithDefault' "forward_client_headers" False .= _rsdForwardClientHeaders
+        <*> optionalField' "timeout_seconds" .= _rsdTimeoutSeconds
+        <*> optionalField' "customization" .= _rsdCustomization
+
 $(J.deriveToJSON hasuraJSON {J.omitNothingFields = True} ''RemoteSchemaDef)
 
 instance J.FromJSON RemoteSchemaDef where
@@ -85,6 +101,20 @@ data RemoteSchemaMetadataG r = RemoteSchemaMetadata
   }
   deriving (Show, Eq, Generic)
 
+instance (HasCodec (RemoteRelationshipG r), Typeable r) => HasCodec (RemoteSchemaMetadataG r) where
+  codec =
+    object ("RemoteSchemaMetadata_" <> typeableName @r) $
+      RemoteSchemaMetadata
+        <$> requiredField' "name" .= _rsmName
+        <*> requiredField' "definition" .= _rsmDefinition
+        <*> optionalField' "comment" .= _rsmComment
+        <*> optionalFieldWithDefault' "permissions" mempty .= _rsmPermissions
+        <*> optionalFieldWithDefaultWith'
+          "remote_relationships"
+          (insertionOrderedElemsCodec _rstrsName)
+          mempty
+          .= _rsmRemoteRelationships
+
 instance J.FromJSON (RemoteRelationshipG r) => J.FromJSON (RemoteSchemaMetadataG r) where
   parseJSON = J.withObject "RemoteSchemaMetadata" \obj ->
     RemoteSchemaMetadata

server/src-lib/Hasura/RemoteSchema/Metadata/Customization.hs

@@ -7,6 +7,8 @@ module Hasura.RemoteSchema.Metadata.Customization
   )
 where
 
+import Autodocodec (HasCodec, codec, hashMapCodec, object, optionalField', optionalFieldWith', requiredFieldWith', (.=))
+import Autodocodec.Extended (graphQLFieldNameCodec)
 import Data.Aeson qualified as J
 import Data.Aeson.TH qualified as J
 import Hasura.Prelude
@@ -25,6 +27,14 @@ instance NFData RemoteTypeCustomization
 
 instance Hashable RemoteTypeCustomization
 
+instance HasCodec RemoteTypeCustomization where
+  codec =
+    object "RemoteTypeCustomization" $
+      RemoteTypeCustomization
+        <$> optionalFieldWith' "prefix" graphQLFieldNameCodec .= _rtcPrefix
+        <*> optionalFieldWith' "suffix" graphQLFieldNameCodec .= _rtcSuffix
+        <*> requiredFieldWith' "mapping" (hashMapCodec graphQLFieldNameCodec) .= _rtcMapping
+
 $(J.deriveToJSON hasuraJSON {J.omitNothingFields = True} ''RemoteTypeCustomization)
 
 instance J.FromJSON RemoteTypeCustomization where
@@ -46,6 +56,15 @@ instance NFData RemoteFieldCustomization
 
 instance Hashable RemoteFieldCustomization
 
+instance HasCodec RemoteFieldCustomization where
+  codec =
+    object "RemoteFieldCustomization" $
+      RemoteFieldCustomization
+        <$> requiredFieldWith' "parent_type" graphQLFieldNameCodec .= _rfcParentType
+        <*> optionalFieldWith' "prefix" graphQLFieldNameCodec .= _rfcPrefix
+        <*> optionalFieldWith' "suffix" graphQLFieldNameCodec .= _rfcSuffix
+        <*> requiredFieldWith' "mapping" (hashMapCodec graphQLFieldNameCodec) .= _rfcMapping
+
 $(J.deriveToJSON hasuraJSON {J.omitNothingFields = True} ''RemoteFieldCustomization)
 
 instance J.FromJSON RemoteFieldCustomization where
@@ -67,4 +86,12 @@ instance NFData RemoteSchemaCustomization
 
 instance Hashable RemoteSchemaCustomization
 
+instance HasCodec RemoteSchemaCustomization where
+  codec =
+    object "RemoteSchemaCustomization" $
+      RemoteSchemaCustomization
+        <$> optionalFieldWith' "root_fields_namespace" graphQLFieldNameCodec .= _rscRootFieldsNamespace
+        <*> optionalField' "type_names" .= _rscTypeNames
+        <*> optionalField' "field_names" .= _rscFieldNames
+
 $(J.deriveJSON hasuraJSON {J.omitNothingFields = True} ''RemoteSchemaCustomization)

server/src-lib/Hasura/RemoteSchema/Metadata/Permission.hs

@@ -6,6 +6,8 @@ module Hasura.RemoteSchema.Metadata.Permission
   )
 where
 
+import Autodocodec (HasCodec (codec), object, optionalField', requiredField', requiredFieldWith, (.=))
+import Autodocodec.Extended (graphQLSchemaDocumentCodec)
 import Data.Aeson qualified as J
 import Data.Aeson.TH qualified as J
 import Hasura.Prelude
@@ -23,6 +25,16 @@ instance NFData RemoteSchemaPermissionDefinition
 
 instance Hashable RemoteSchemaPermissionDefinition
 
+instance HasCodec RemoteSchemaPermissionDefinition where
+  codec =
+    object "RemoteSchemaPermissionDefinition" $
+      RemoteSchemaPermissionDefinition
+        <$> requiredFieldWith
+          "schema"
+          graphQLSchemaDocumentCodec
+          "GraphQL schema document, e.g. the content of schema.gql"
+          .= _rspdSchema
+
 instance J.FromJSON RemoteSchemaPermissionDefinition where
   parseJSON = J.withObject "RemoteSchemaPermissionDefinition" $ \obj -> do
     fmap RemoteSchemaPermissionDefinition $ obj J..: "schema"
@@ -38,4 +50,12 @@ data RemoteSchemaPermissionMetadata = RemoteSchemaPermissionMetadata
   }
   deriving (Show, Eq, Generic)
 
+instance HasCodec RemoteSchemaPermissionMetadata where
+  codec =
+    object "RemoteSchemaPermissionMetadata" $
+      RemoteSchemaPermissionMetadata
+        <$> requiredField' "role" .= _rspmRole
+        <*> requiredField' "definition" .= _rspmDefinition
+        <*> optionalField' "comment" .= _rspmComment
+
 $(J.deriveJSON hasuraJSON {J.omitNothingFields = True} ''RemoteSchemaPermissionMetadata)

server/src-lib/Hasura/RemoteSchema/Metadata/RemoteRelationship.hs

@@ -18,7 +18,9 @@ module Hasura.RemoteSchema.Metadata.RemoteRelationship
 where
 
 import Autodocodec
-import Autodocodec.Extended (graphQLValueCodec, hashSetCodec)
+import Autodocodec qualified as AC
+import Autodocodec.Extended (graphQLFieldNameCodec, graphQLValueCodec, hashSetCodec)
+import Control.Exception.Safe (Typeable)
 import Control.Lens (makeLenses)
 import Data.Aeson qualified as J
 import Data.Aeson.Key qualified as K
@@ -27,9 +29,11 @@ import Data.Aeson.TH qualified as J
 import Data.Aeson.Types (prependFailure)
 import Data.Bifunctor (bimap)
 import Data.HashMap.Strict qualified as HM
+import Data.HashMap.Strict.InsOrd.Autodocodec (insertionOrderedElemsCodec)
 import Data.HashMap.Strict.InsOrd.Extended qualified as OM
 import Data.Scientific (floatingOrInteger)
 import Data.Text qualified as T
+import Hasura.Metadata.DTO.Utils (typeableName)
 import Hasura.Prelude
 import Hasura.RQL.Types.Common
 import Hasura.RemoteSchema.Metadata.Base
@@ -229,6 +233,17 @@ data RemoteSchemaTypeRelationships r = RemoteSchemaTypeRelationships
   }
   deriving (Show, Eq, Generic)
 
+instance (HasCodec (RemoteRelationshipG r), Typeable r) => HasCodec (RemoteSchemaTypeRelationships r) where
+  codec =
+    AC.object ("RemoteSchemaMetadata_" <> typeableName @r) $
+      RemoteSchemaTypeRelationships
+        <$> requiredFieldWith' "type_name" graphQLFieldNameCodec AC..= _rstrsName
+        <*> optionalFieldWithDefaultWith'
+          "relationships"
+          (insertionOrderedElemsCodec _rrName)
+          mempty
+          AC..= _rstrsRelationships
+
 instance J.FromJSON (RemoteRelationshipG r) => J.FromJSON (RemoteSchemaTypeRelationships r) where
   parseJSON = J.withObject "RemoteSchemaMetadata" \obj ->
     RemoteSchemaTypeRelationships

server/src-test/Hasura/Metadata/DTO/MetadataDTOSpec.hs

@@ -100,7 +100,7 @@ emptyMetadataV3 :: MetadataV3
 emptyMetadataV3 =
   MetadataV3
     { metaV3Sources = mempty,
-      metaV3RemoteSchemas = Nothing,
+      metaV3RemoteSchemas = mempty,
       metaV3QueryCollections = Nothing,
       metaV3Allowlist = Nothing,
       metaV3Actions = Nothing,