server: codecs for metrics, roles, allow list

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

metadata.openapi.json

@@ -220,6 +220,65 @@
                 },
                 "type": "object"
             },
+            "AllowlistEntry": {
+                "properties": {
+                    "collection": {
+                        "type": "string"
+                    },
+                    "scope": {
+                        "default": {
+                            "global": true
+                        },
+                        "oneOf": [
+                            {
+                                "$ref": "#/components/schemas/AllowlistScopeGlobal"
+                            },
+                            {
+                                "$ref": "#/components/schemas/AllowlistScopeRoles"
+                            }
+                        ]
+                    }
+                },
+                "required": [
+                    "collection"
+                ],
+                "type": "object"
+            },
+            "AllowlistScopeGlobal": {
+                "properties": {
+                    "global": {
+                        "enum": [
+                            true
+                        ],
+                        "type": "boolean"
+                    }
+                },
+                "required": [
+                    "global"
+                ],
+                "type": "object"
+            },
+            "AllowlistScopeRoles": {
+                "properties": {
+                    "global": {
+                        "enum": [
+                            false
+                        ],
+                        "type": "boolean"
+                    },
+                    "roles": {
+                        "items": {
+                            "type": "string"
+                        },
+                        "type": "array"
+                    }
+                },
+                "required": [
+                    "global",
+                    "roles"
+                ],
+                "type": "object"
+            },
             "ApolloFederationConfig": {
                 "nullable": true,
                 "properties": {
@@ -4205,9 +4264,10 @@
                         "type": "array"
                     },
                     "allowlist": {
-                        "description": "safe GraphQL operations - when allow lists are enabled only these operations are allowed\n\n\narray of values of unspecified type - this is a placeholder that will eventually be replaced with a more detailed description",
+                        "default": [],
+                        "description": "safe GraphQL operations - when allow lists are enabled only these operations are allowed",
                         "items": {
-                            "additionalProperties": true
+                            "$ref": "#/components/schemas/AllowlistEntry"
                         },
                         "type": "array"
                     },
@@ -4235,15 +4295,15 @@
                         "description": "TODO\n\n\nobject with unspecified properties - this is a placeholder that will eventually be replaced with a more detailed description"
                     },
                     "inherited_roles": {
-                        "description": "an inherited role is a way to create a new role which inherits permissions from two or more roles\n\n\narray of values of unspecified type - this is a placeholder that will eventually be replaced with a more detailed description",
+                        "default": [],
+                        "description": "an inherited role is a way to create a new role which inherits permissions from two or more roles",
                         "items": {
-                            "additionalProperties": true
+                            "$ref": "#/components/schemas/Role"
                         },
                         "type": "array"
                     },
                     "metrics_config": {
-                        "additionalProperties": true,
-                        "description": "TODO\n\n\nobject with unspecified properties - this is a placeholder that will eventually be replaced with a more detailed description"
+                        "$ref": "#/components/schemas/MetricsConfig"
                     },
                     "network": {
                         "additionalProperties": true,
@@ -4297,6 +4357,21 @@
                 ],
                 "type": "object"
             },
+            "MetricsConfig": {
+                "properties": {
+                    "analyze_query_variables": {
+                        "type": "boolean"
+                    },
+                    "analyze_response_body": {
+                        "type": "boolean"
+                    }
+                },
+                "required": [
+                    "analyze_query_variables",
+                    "analyze_response_body"
+                ],
+                "type": "object"
+            },
             "MssqlArrRelUsingFKeyOnMultipleColumns": {
                 "properties": {
                     "columns": {
@@ -8121,6 +8196,24 @@
                 ],
                 "type": "object"
             },
+            "Role": {
+                "properties": {
+                    "role_name": {
+                        "type": "string"
+                    },
+                    "role_set": {
+                        "items": {
+                            "type": "string"
+                        },
+                        "type": "array"
+                    }
+                },
+                "required": [
+                    "role_name",
+                    "role_set"
+                ],
+                "type": "object"
+            },
             "RootFieldsCustomization": {
                 "properties": {
                     "namespace": {

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

@@ -8,6 +8,7 @@ import Autodocodec
     object,
     optionalField,
     optionalFieldWithOmittedDefault,
+    optionalFieldWithOmittedDefault',
     optionalFieldWithOmittedDefaultWith,
     requiredFieldWith,
     (.=),
@@ -16,14 +17,17 @@ 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.Placeholder (PlaceholderObject)
 import Hasura.Metadata.DTO.Utils (versionField)
 import Hasura.Prelude
 import Hasura.RQL.Types.Action (ActionMetadata (_amName))
+import Hasura.RQL.Types.Allowlist (AllowlistEntry (aeCollection), MetadataAllowlist)
+import Hasura.RQL.Types.Common (MetricsConfig, emptyMetricsConfig)
 import Hasura.RQL.Types.CustomTypes (CustomTypes, emptyCustomTypes)
 import Hasura.RQL.Types.Endpoint (_ceName)
-import Hasura.RQL.Types.Metadata.Common (Actions, CronTriggers, Endpoints, QueryCollections, RemoteSchemas, Sources, sourcesCodec)
+import Hasura.RQL.Types.Metadata.Common (Actions, CronTriggers, Endpoints, InheritedRoles, QueryCollections, RemoteSchemas, Sources, sourcesCodec)
 import Hasura.RQL.Types.QueryCollection qualified as QC
+import Hasura.RQL.Types.Roles (Role (_rRoleName))
 import Hasura.RQL.Types.ScheduledTrigger (CronTriggerMetadata (ctName))
 import Hasura.RemoteSchema.Metadata.Core (RemoteSchemaMetadataG (_rsmName))
 
@@ -33,14 +37,14 @@ data MetadataV3 = MetadataV3
   { metaV3Sources :: Sources,
     metaV3RemoteSchemas :: RemoteSchemas,
     metaV3QueryCollections :: QueryCollections,
-    metaV3Allowlist :: Maybe PlaceholderArray,
+    metaV3Allowlist :: MetadataAllowlist,
     metaV3Actions :: Actions,
     metaV3CustomTypes :: CustomTypes,
     metaV3CronTriggers :: CronTriggers,
     metaV3RestEndpoints :: Endpoints,
     metaV3ApiLimits :: Maybe PlaceholderObject,
-    metaV3MetricsConfig :: Maybe PlaceholderObject,
-    metaV3InheritedRoles :: Maybe PlaceholderArray,
+    metaV3MetricsConfig :: MetricsConfig,
+    metaV3InheritedRoles :: InheritedRoles,
     metaV3GraphqlSchemaIntrospection :: Maybe PlaceholderObject,
     metaV3Network :: Maybe PlaceholderObject,
     metaV3BackendConfigs :: Maybe PlaceholderObject,
@@ -67,14 +71,14 @@ instance HasCodec MetadataV3 where
           mempty
           "group queries using query collections"
           .= metaV3QueryCollections
-        <*> optionalField "allowlist" "safe GraphQL operations - when allow lists are enabled only these operations are allowed" .= metaV3Allowlist
+        <*> optionalFieldWithOmittedDefaultWith "allowlist" (sortedElemsCodec aeCollection) [] "safe GraphQL operations - when allow lists are enabled only these operations are allowed" .= metaV3Allowlist
         <*> optionalFieldWithOmittedDefaultWith "actions" (sortedElemsCodec _amName) mempty "action definitions which extend Hasura's schema with custom business logic using custom queries and mutations" .= metaV3Actions
         <*> optionalFieldWithOmittedDefault "custom_types" emptyCustomTypes "custom type definitions" .= metaV3CustomTypes
         <*> optionalFieldWithOmittedDefaultWith "cron_triggers" (sortedElemsCodec ctName) [] "reliably trigger HTTP endpoints to run custom business logic periodically based on a cron schedule" .= metaV3CronTriggers
         <*> optionalFieldWithOmittedDefaultWith "rest_endpoints" (sortedElemsCodec _ceName) [] "REST interfaces to saved GraphQL queries and mutations" .= metaV3RestEndpoints
         <*> optionalField "api_limits" "limts to depth and/or rate of API requests" .= metaV3ApiLimits
-        <*> optionalField "metrics_config" "TODO" .= metaV3MetricsConfig
-        <*> optionalField "inherited_roles" "an inherited role is a way to create a new role which inherits permissions from two or more roles" .= metaV3InheritedRoles
+        <*> optionalFieldWithOmittedDefault' "metrics_config" emptyMetricsConfig .= metaV3MetricsConfig
+        <*> optionalFieldWithOmittedDefaultWith "inherited_roles" (sortedElemsCodec _rRoleName) [] "an inherited role is a way to create a new role which inherits permissions from two or more roles" .= metaV3InheritedRoles
         <*> optionalField "graphql_schema_introspection" "TODO" .= metaV3GraphqlSchemaIntrospection
         <*> optionalField "network" "TODO" .= metaV3Network
         <*> optionalField "backend_configs" "TODO" .= metaV3BackendConfigs

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

@@ -4,6 +4,7 @@ module Hasura.Metadata.DTO.Utils
     boundedEnumCodec,
     codecNamePrefix,
     discriminatorField,
+    discriminatorBoolField,
     fromEnvCodec,
     optionalVersionField,
     typeableName,
@@ -74,12 +75,21 @@ optionalVersionField v =
     n = fromInteger v
 
 -- | Useful in an object codec for a field that indicates the type of the
--- object within a union.
+-- object within a union. This version assumes that the type of the
+-- discriminator field is @Text@.
 discriminatorField :: Text -> Text -> ObjectCodec a ()
 discriminatorField name value =
   dimapCodec (const ()) (const value) $
     requiredFieldWith' name (literalTextCodec value)
 
+-- | Useful in an object codec for a field that indicates the type of the
+-- object within a union. This version assumes that the type of the
+-- discriminator field is @Bool@.
+discriminatorBoolField :: Text -> Bool -> ObjectCodec a ()
+discriminatorBoolField name value =
+  dimapCodec (const ()) (const value) $
+    requiredFieldWith' name (EqCodec value boolCodec)
+
 -- | Provides a title-cased name for a database kind, inferring the appropriate
 -- database kind from type context.
 codecNamePrefix :: forall b. (HasTag b) => Text

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

@@ -19,6 +19,8 @@ module Hasura.RQL.Types.Allowlist
   )
 where
 
+import Autodocodec (HasCodec, bimapCodec, disjointEitherCodec, optionalFieldWithDefault', requiredField')
+import Autodocodec qualified as AC
 import Data.Aeson
 import Data.Aeson.TH (deriveJSON, deriveToJSON)
 import Data.HashMap.Strict.Extended qualified as M
@@ -26,6 +28,7 @@ import Data.HashMap.Strict.InsOrd.Extended qualified as OM
 import Data.HashSet qualified as S
 import Data.Text.Extended ((<<>))
 import Hasura.GraphQL.Parser.Name qualified as GName
+import Hasura.Metadata.DTO.Utils (discriminatorBoolField)
 import Hasura.Prelude
 import Hasura.RQL.Types.QueryCollection
 import Hasura.Session (RoleName)
@@ -43,6 +46,24 @@ data AllowlistScope
   | AllowlistScopeRoles (NonEmpty RoleName)
   deriving (Show, Eq, Generic)
 
+instance HasCodec AllowlistScope where
+  codec = bimapCodec dec enc $ disjointEitherCodec global scopeRoles
+    where
+      global = AC.object "AllowlistScopeGlobal" $ discriminatorBoolField "global" True
+      scopeRoles =
+        AC.object "AllowlistScopeRoles" $
+          void (discriminatorBoolField "global" False)
+            *> requiredField' "roles"
+
+      dec (Left _) = Right AllowlistScopeGlobal
+      dec (Right roles)
+        | hasDups roles = Left "duplicate roles are not allowed"
+        | otherwise = Right $ AllowlistScopeRoles roles
+      enc AllowlistScopeGlobal = Left ()
+      enc (AllowlistScopeRoles roles) = Right roles
+
+      hasDups xs = length xs /= length (S.fromList (toList xs))
+
 instance FromJSON AllowlistScope where
   parseJSON = withObject "AllowlistScope" $ \o -> do
     global <- o .: "global"
@@ -69,6 +90,13 @@ data AllowlistEntry = AllowlistEntry
   }
   deriving (Show, Eq, Generic)
 
+instance HasCodec AllowlistEntry where
+  codec =
+    AC.object "AllowlistEntry" $
+      AllowlistEntry
+        <$> requiredField' "collection" AC..= aeCollection
+        <*> optionalFieldWithDefault' "scope" AllowlistScopeGlobal AC..= aeScope
+
 $(deriveToJSON hasuraJSON ''AllowlistEntry)
 
 instance FromJSON AllowlistEntry where

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

@@ -560,6 +560,13 @@ data MetricsConfig = MetricsConfig
   }
   deriving (Show, Eq, Generic)
 
+instance HasCodec MetricsConfig where
+  codec =
+    AC.object "MetricsConfig" $
+      MetricsConfig
+        <$> requiredField' "analyze_query_variables" AC..= _mcAnalyzeQueryVariables
+        <*> requiredField' "analyze_response_body" AC..= _mcAnalyzeResponseBody
+
 instance FromJSON MetricsConfig where
   parseJSON = J.withObject "MetricsConfig" $ \o -> do
     _mcAnalyzeQueryVariables <- o .: "analyze_query_variables"

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

@@ -533,14 +533,14 @@ metadataToDTO
       { metaV3Sources = sources,
         metaV3RemoteSchemas = remoteSchemas,
         metaV3QueryCollections = queryCollections,
-        metaV3Allowlist = placeholder <$> allowlistToOrdJSONList allowlist,
+        metaV3Allowlist = allowlist,
         metaV3Actions = actions,
         metaV3CustomTypes = customTypes,
         metaV3CronTriggers = cronTriggers,
         metaV3RestEndpoints = endpoints,
         metaV3ApiLimits = placeholder . objectFromOrdJSON <$> apiLimitsToOrdJSON apiLimits,
-        metaV3MetricsConfig = placeholder . objectFromOrdJSON <$> metricsConfigToOrdJSON metricsConfig,
-        metaV3InheritedRoles = placeholder <$> inheritedRolesToOrdJSONList inheritedRoles,
+        metaV3MetricsConfig = metricsConfig,
+        metaV3InheritedRoles = inheritedRoles,
         metaV3GraphqlSchemaIntrospection = placeholder . objectFromOrdJSON <$> introspectionDisabledRolesToOrdJSON introspectionDisabledRoles,
         metaV3Network = placeholder . objectFromOrdJSON <$> networkConfigToOrdJSON networkConfig,
         metaV3BackendConfigs = placeholder . objectFromOrdJSON <$> backendConfigsToOrdJSON backendConfigs,

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

@@ -8,6 +8,9 @@ module Hasura.RQL.Types.Roles
   )
 where
 
+import Autodocodec (HasCodec (codec), dimapCodec, requiredField')
+import Autodocodec qualified as AC
+import Autodocodec.Extended (hashSetCodec)
 import Data.Aeson
 import Data.Aeson.Casing
 import Data.Aeson.TH
@@ -19,6 +22,9 @@ newtype ParentRoles = ParentRoles {_unParentRoles :: HashSet RoleName}
 
 instance Hashable ParentRoles
 
+instance HasCodec ParentRoles where
+  codec = dimapCodec ParentRoles _unParentRoles hashSetCodec
+
 -- | The `Role` type represents a role by
 --   containing its name and the names of its parent roles.
 --   This type is used externally in the `add_inherited_role`
@@ -35,6 +41,13 @@ data Role = Role
 
 instance Hashable Role
 
+instance HasCodec Role where
+  codec =
+    AC.object "Role" $
+      Role
+        <$> requiredField' "role_name" AC..= _rRoleName
+        <*> requiredField' "role_set" AC..= _rParentRoles
+
 instance ToJSON Role where
   toJSON (Role roleName parentRoles) =
     object

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

@@ -21,6 +21,7 @@ import Hasura.Metadata.DTO.MetadataV2 (MetadataV2 (..))
 import Hasura.Metadata.DTO.MetadataV3 (MetadataV3 (..))
 import Hasura.Metadata.DTO.Placeholder (PlaceholderArray (PlaceholderArray))
 import Hasura.Prelude
+import Hasura.RQL.Types.Common (emptyMetricsConfig)
 import Hasura.RQL.Types.CustomTypes (emptyCustomTypes)
 import Hasura.RQL.Types.Metadata (Metadata, MetadataDefaults, metadataToDTO, overrideMetadataDefaults)
 import Test.Hspec
@@ -103,14 +104,14 @@ emptyMetadataV3 =
     { metaV3Sources = mempty,
       metaV3RemoteSchemas = mempty,
       metaV3QueryCollections = mempty,
-      metaV3Allowlist = Nothing,
+      metaV3Allowlist = mempty,
       metaV3Actions = mempty,
       metaV3CustomTypes = emptyCustomTypes,
       metaV3CronTriggers = mempty,
       metaV3RestEndpoints = mempty,
       metaV3ApiLimits = Nothing,
-      metaV3MetricsConfig = Nothing,
-      metaV3InheritedRoles = Nothing,
+      metaV3MetricsConfig = emptyMetricsConfig,
+      metaV3InheritedRoles = mempty,
       metaV3GraphqlSchemaIntrospection = Nothing,
       metaV3Network = Nothing,
       metaV3BackendConfigs = Nothing,

server/src-test/Hasura/RQL/Types/AllowlistSpec.hs

@@ -1,6 +1,10 @@
+{-# LANGUAGE OverloadedLists #-}
+
 module Hasura.RQL.Types.AllowlistSpec (spec) where
 
+import Autodocodec (parseJSONViaCodec, toJSONViaCodec)
 import Data.Aeson qualified as Aeson
+import Data.Aeson.Types (parseEither)
 import Data.Aeson.Types qualified as Aeson
 import Data.HashMap.Strict.InsOrd.Extended qualified as OM
 import Data.HashSet qualified as S
@@ -110,6 +114,14 @@ spec = do
             ("role_4", "query_2")
           ]
 
+    it "round-trips roles when serializing via codecs" do
+      let expected =
+            maybeToEither "nonempty" $
+              AllowlistScopeRoles <$> traverse mkRoleName ["viewer", "admin"]
+      let json = toJSONViaCodec <$> expected
+      let actual = parseEither parseJSONViaCodec =<< json
+      actual `shouldBe` expected
+
 mustJSON :: Aeson.FromJSON a => Aeson.Value -> a
 mustJSON v = case Aeson.parseEither Aeson.parseJSON v of
   Left err -> error err