From 56e3bd182a0c1b2c2eb26d2e4d22eb58e2aa3a84 Mon Sep 17 00:00:00 2001 From: Gil Mizrahi Date: Wed, 3 May 2023 12:59:21 +0300 Subject: [PATCH] chore(refactor): extract common functionality between stored procedures and native queries PR-URL: https://github.com/hasura/graphql-engine-mono/pull/9028 GitOrigin-RevId: ab5c1ca9c08600a758f07aa81370930c305d6b40 --- server/graphql-engine.cabal | 4 ++ .../Hasura/LogicalModelResolver/Codec.hs | 50 ++++++++++++++ .../Hasura/LogicalModelResolver/Schema.hs | 69 +++++++++++++++++++ .../Hasura/LogicalModelResolver/Types.hs | 32 +++++++++ server/src-lib/Hasura/NativeQuery/API.hs | 4 +- .../Hasura/NativeQuery/InterpolatedQuery.hs | 22 +----- server/src-lib/Hasura/NativeQuery/Schema.hs | 44 +----------- server/src-lib/Hasura/NativeQuery/Types.hs | 47 ++----------- server/src-lib/Hasura/StoredProcedure/API.hs | 4 +- .../Hasura/StoredProcedure/Metadata.hs | 7 +- .../src-lib/Hasura/StoredProcedure/Schema.hs | 44 +----------- .../src-lib/Hasura/StoredProcedure/Types.hs | 46 +------------ 12 files changed, 176 insertions(+), 197 deletions(-) create mode 100644 server/src-lib/Hasura/LogicalModelResolver/Codec.hs create mode 100644 server/src-lib/Hasura/LogicalModelResolver/Schema.hs create mode 100644 server/src-lib/Hasura/LogicalModelResolver/Types.hs diff --git a/server/graphql-engine.cabal b/server/graphql-engine.cabal index 7aee3cba1b8..826de2a550d 100644 --- a/server/graphql-engine.cabal +++ b/server/graphql-engine.cabal @@ -745,6 +745,10 @@ library , Hasura.Server.Auth.JWT , Hasura.GC + , Hasura.LogicalModelResolver.Codec + , Hasura.LogicalModelResolver.Schema + , Hasura.LogicalModelResolver.Types + , Hasura.NativeQuery.IR , Hasura.NativeQuery.Cache , Hasura.NativeQuery.Lenses diff --git a/server/src-lib/Hasura/LogicalModelResolver/Codec.hs b/server/src-lib/Hasura/LogicalModelResolver/Codec.hs new file mode 100644 index 00000000000..73b818b77d7 --- /dev/null +++ b/server/src-lib/Hasura/LogicalModelResolver/Codec.hs @@ -0,0 +1,50 @@ +-- | Common codecs shared between similar logical model resolvers. +module Hasura.LogicalModelResolver.Codec + ( arrayRelationshipsCodec, + ) +where + +import Autodocodec (HasCodec (), HasObjectCodec (..), bimapCodec) +import Autodocodec qualified as AC +import Data.Aeson (Value) +import Data.HashMap.Strict.InsOrd qualified as InsOrdHashMap +import Hasura.Prelude hiding (first) +import Hasura.RQL.Types.Backend (Backend (..)) +import Hasura.RQL.Types.Common (RelName) +import Hasura.RQL.Types.Relationships.Local (RelDef, RelManualConfig) + +-- | Codec of array relationships +arrayRelationshipsCodec :: + forall b. + (Backend b) => + AC.Codec + Value + (InsOrdHashMap.InsOrdHashMap RelName (RelDef (RelManualConfig b))) + (InsOrdHashMap.InsOrdHashMap RelName (RelDef (RelManualConfig b))) +arrayRelationshipsCodec = + AC.dimapCodec + ( InsOrdHashMap.fromList + . fmap + ( \(MergedObject (NameField name) nst) -> + (name, nst) + ) + ) + ( fmap (\(fld, nst) -> MergedObject (NameField fld) nst) . InsOrdHashMap.toList + ) + ( AC.listCodec $ + AC.object "RelDefRelManualConfig" $ + AC.objectCodec @(MergedObject (NameField RelName) (RelDef (RelManualConfig b))) + ) + +data MergedObject a b = MergedObject + { moFst :: a, + moSnd :: b + } + +instance (HasObjectCodec a, HasObjectCodec b) => HasObjectCodec (MergedObject a b) where + objectCodec = MergedObject <$> bimapCodec Right moFst objectCodec <*> bimapCodec Right moSnd objectCodec + +newtype NameField a = NameField {nameField :: a} + +instance (HasCodec a) => HasObjectCodec (NameField a) where + objectCodec = NameField <$> AC.requiredField "name" "name" AC..= nameField diff --git a/server/src-lib/Hasura/LogicalModelResolver/Schema.hs b/server/src-lib/Hasura/LogicalModelResolver/Schema.hs new file mode 100644 index 00000000000..52984272fce --- /dev/null +++ b/server/src-lib/Hasura/LogicalModelResolver/Schema.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE QuasiQuotes #-} + +-- | Schema parsers for common functionality of logical model resolvers. +module Hasura.LogicalModelResolver.Schema (argumentsSchema) where + +import Data.HashMap.Strict qualified as HashMap +import Data.Monoid (Ap (Ap, getAp)) +import Hasura.GraphQL.Schema.Backend + ( BackendSchema (columnParser), + MonadBuildSchema, + ) +import Hasura.GraphQL.Schema.Common + ( SchemaT, + ) +import Hasura.GraphQL.Schema.Parser qualified as P +import Hasura.Prelude +import Hasura.RQL.IR.Value (openValueOrigin) +import Hasura.RQL.Types.Column qualified as Column +import Hasura.StoredProcedure.Metadata (ArgumentName (..)) +import Hasura.StoredProcedure.Types (NullableScalarType (..)) +import Language.GraphQL.Draft.Syntax qualified as G +import Language.GraphQL.Draft.Syntax.QQ qualified as G + +-- | Schema parser for native query or stored procedure arguments. +argumentsSchema :: + forall b r m n. + MonadBuildSchema b r m n => + -- | The resolver description, such as "Stored Procedure" or "Native Query". + Text -> + -- | The resolver name. + G.Name -> + -- | Arguments + HashMap ArgumentName (NullableScalarType b) -> + MaybeT (SchemaT r m) (P.InputFieldsParser n (HashMap ArgumentName (Column.ColumnValue b))) +argumentsSchema resolverDesc resolverName argsSignature = do + -- Lift 'SchemaT r m (InputFieldsParser ..)' into a monoid using Applicative. + -- This lets us use 'foldMap' + monoid structure of hashmaps to avoid awkwardly + -- traversing the arguments and building the resulting parser. + argsParser <- + getAp $ + foldMap + ( \(name, NullableScalarType {nstType, nstNullable, nstDescription}) -> Ap do + argValueParser <- + fmap (HashMap.singleton name . openValueOrigin) + <$> lift (columnParser (Column.ColumnScalar nstType) (G.Nullability nstNullable)) + -- TODO: Naming conventions? + -- TODO: Custom fields? (Probably not) + argName <- hoistMaybe (G.mkName (getArgumentName name)) + let description = case nstDescription of + Just desc -> G.Description desc + Nothing -> G.Description (resolverDesc <> " argument " <> getArgumentName name) + pure $ + P.field + argName + (Just description) + argValueParser + ) + (HashMap.toList argsSignature) + + let desc = Just $ G.Description $ G.unName resolverName <> resolverDesc <> " Arguments" + + pure $ + if null argsSignature + then mempty + else + P.field + [G.name|args|] + desc + (P.object (resolverName <> [G.name|_arguments|]) desc argsParser) diff --git a/server/src-lib/Hasura/LogicalModelResolver/Types.hs b/server/src-lib/Hasura/LogicalModelResolver/Types.hs new file mode 100644 index 00000000000..8cc86fb53a2 --- /dev/null +++ b/server/src-lib/Hasura/LogicalModelResolver/Types.hs @@ -0,0 +1,32 @@ +-- | Common types shared between similar logical model resolvers. +module Hasura.LogicalModelResolver.Types + ( ArgumentName (..), + NullableScalarType (..), + nullableScalarTypeMapCodec, + ) +where + +import Autodocodec (HasCodec (codec), dimapCodec) +import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey) +import Hasura.LogicalModel.NullableScalarType +import Hasura.Prelude hiding (first) + +-- | A name of an argument to a native query or stored procedure. +newtype ArgumentName = ArgumentName + { getArgumentName :: Text + } + deriving newtype (Eq, Ord, Show, Hashable) + deriving stock (Generic) + +instance HasCodec ArgumentName where + codec = dimapCodec ArgumentName getArgumentName codec + +deriving newtype instance ToJSON ArgumentName + +deriving newtype instance FromJSON ArgumentName + +deriving newtype instance ToJSONKey ArgumentName + +deriving newtype instance FromJSONKey ArgumentName + +instance NFData ArgumentName diff --git a/server/src-lib/Hasura/NativeQuery/API.hs b/server/src-lib/Hasura/NativeQuery/API.hs index 60c8bd46c42..7e218816555 100644 --- a/server/src-lib/Hasura/NativeQuery/API.hs +++ b/server/src-lib/Hasura/NativeQuery/API.hs @@ -25,7 +25,7 @@ import Hasura.EncJSON import Hasura.LogicalModel.API (getCustomTypes) import Hasura.LogicalModel.Metadata (LogicalModelName) import Hasura.NativeQuery.Metadata (ArgumentName, NativeQueryMetadata (..), parseInterpolatedQuery) -import Hasura.NativeQuery.Types (NativeQueryName, NullableScalarType, nativeQueryArrayRelationshipsCodec) +import Hasura.NativeQuery.Types (NativeQueryName, NullableScalarType, arrayRelationshipsCodec) import Hasura.Prelude import Hasura.RQL.Types.Backend (Backend, SourceConnConfiguration) import Hasura.RQL.Types.BackendTag @@ -70,7 +70,7 @@ instance (Backend b) => HasCodec (TrackNativeQuery b) where AC..= tnqCode <*> AC.optionalFieldWithDefault "arguments" mempty argumentsDoc AC..= tnqArguments - <*> AC.optionalFieldWithDefaultWith "array_relationships" nativeQueryArrayRelationshipsCodec mempty arrayRelationshipsDoc + <*> AC.optionalFieldWithDefaultWith "array_relationships" arrayRelationshipsCodec mempty arrayRelationshipsDoc AC..= tnqArrayRelationships <*> AC.optionalField "description" descriptionDoc AC..= tnqDescription diff --git a/server/src-lib/Hasura/NativeQuery/InterpolatedQuery.hs b/server/src-lib/Hasura/NativeQuery/InterpolatedQuery.hs index 4be1bb2f137..d7bd8ab9846 100644 --- a/server/src-lib/Hasura/NativeQuery/InterpolatedQuery.hs +++ b/server/src-lib/Hasura/NativeQuery/InterpolatedQuery.hs @@ -13,10 +13,11 @@ where import Autodocodec import Autodocodec qualified as AC -import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey) +import Data.Aeson (FromJSON, ToJSON) import Data.Bifunctor (first) import Data.Text qualified as T import Hasura.LogicalModel.NullableScalarType (NullableScalarType (..), nullableScalarTypeMapCodec) +import Hasura.LogicalModelResolver.Types (ArgumentName (..)) import Hasura.Prelude hiding (first) import Language.Haskell.TH.Syntax (Lift) @@ -82,25 +83,6 @@ deriving via --------------------------------------- -newtype ArgumentName = ArgumentName - { getArgumentName :: Text - } - deriving newtype (Eq, Ord, Show, Hashable) - deriving stock (Generic) - -instance HasCodec ArgumentName where - codec = dimapCodec ArgumentName getArgumentName codec - -deriving newtype instance ToJSON ArgumentName - -deriving newtype instance FromJSON ArgumentName - -deriving newtype instance ToJSONKey ArgumentName - -deriving newtype instance FromJSONKey ArgumentName - -instance NFData ArgumentName - -- | extract all of the `{{ variable }}` inside our query string parseInterpolatedQuery :: Text -> diff --git a/server/src-lib/Hasura/NativeQuery/Schema.hs b/server/src-lib/Hasura/NativeQuery/Schema.hs index acb879798c4..8da8c4d7810 100644 --- a/server/src-lib/Hasura/NativeQuery/Schema.hs +++ b/server/src-lib/Hasura/NativeQuery/Schema.hs @@ -1,14 +1,10 @@ -{-# LANGUAGE QuasiQuotes #-} - -- | Schema parsers for native queries. module Hasura.NativeQuery.Schema (defaultBuildNativeQueryRootFields) where import Data.Has (Has (getter)) import Data.HashMap.Strict qualified as HashMap -import Data.Monoid (Ap (Ap, getAp)) import Hasura.GraphQL.Schema.Backend ( BackendLogicalModelSelectSchema (..), - BackendSchema (columnParser), MonadBuildSchema, ) import Hasura.GraphQL.Schema.Common @@ -17,6 +13,7 @@ import Hasura.GraphQL.Schema.Common ) import Hasura.GraphQL.Schema.Parser qualified as P import Hasura.LogicalModel.Schema +import Hasura.LogicalModelResolver.Schema (argumentsSchema) import Hasura.NativeQuery.Cache (NativeQueryInfo (..)) import Hasura.NativeQuery.IR (NativeQuery (..)) import Hasura.NativeQuery.Metadata (ArgumentName (..), InterpolatedQuery (..)) @@ -25,7 +22,7 @@ import Hasura.Prelude import Hasura.RQL.IR.Root (RemoteRelationshipField) import Hasura.RQL.IR.Select (QueryDB (QDBMultipleRows)) import Hasura.RQL.IR.Select qualified as IR -import Hasura.RQL.IR.Value (Provenance (FromInternal), UnpreparedValue (UVParameter), openValueOrigin) +import Hasura.RQL.IR.Value (Provenance (FromInternal), UnpreparedValue (UVParameter)) import Hasura.RQL.Types.Column qualified as Column import Hasura.RQL.Types.Metadata.Object qualified as MO import Hasura.RQL.Types.Schema.Options qualified as Options @@ -37,7 +34,6 @@ import Hasura.RQL.Types.SourceCustomization ) import Hasura.SQL.AnyBackend (mkAnyBackend) import Language.GraphQL.Draft.Syntax qualified as G -import Language.GraphQL.Draft.Syntax.QQ qualified as G defaultBuildNativeQueryRootFields :: forall b r m n. @@ -122,38 +118,4 @@ nativeQueryArgumentsSchema :: G.Name -> HashMap ArgumentName (NullableScalarType b) -> MaybeT (SchemaT r m) (P.InputFieldsParser n (HashMap ArgumentName (Column.ColumnValue b))) -nativeQueryArgumentsSchema nativeQueryName argsSignature = do - -- Lift 'SchemaT r m (InputFieldsParser ..)' into a monoid using Applicative. - -- This lets us use 'foldMap' + monoid structure of hashmaps to avoid awkwardly - -- traversing the arguments and building the resulting parser. - argsParser <- - getAp $ - foldMap - ( \(name, NullableScalarType {nstType, nstNullable, nstDescription}) -> Ap do - argValueParser <- - fmap (HashMap.singleton name . openValueOrigin) - <$> lift (columnParser (Column.ColumnScalar nstType) (G.Nullability nstNullable)) - -- TODO: Naming conventions? - -- TODO: Custom fields? (Probably not) - argName <- hoistMaybe (G.mkName (getArgumentName name)) - let description = case nstDescription of - Just desc -> G.Description desc - Nothing -> G.Description ("Native query argument " <> getArgumentName name) - pure $ - P.field - argName - (Just description) - argValueParser - ) - (HashMap.toList argsSignature) - - let desc = Just $ G.Description $ G.unName nativeQueryName <> " Native Query Arguments" - - pure $ - if null argsSignature - then mempty - else - P.field - [G.name|args|] - desc - (P.object (nativeQueryName <> [G.name|_arguments|]) desc argsParser) +nativeQueryArgumentsSchema = argumentsSchema "Native Query" diff --git a/server/src-lib/Hasura/NativeQuery/Types.hs b/server/src-lib/Hasura/NativeQuery/Types.hs index b0fb5343904..052c7b29caa 100644 --- a/server/src-lib/Hasura/NativeQuery/Types.hs +++ b/server/src-lib/Hasura/NativeQuery/Types.hs @@ -3,20 +3,16 @@ module Hasura.NativeQuery.Types ( NativeQueryName (..), NullableScalarType (..), nullableScalarTypeMapCodec, - nativeQueryArrayRelationshipsCodec, + arrayRelationshipsCodec, ) where -import Autodocodec (HasCodec (codec), HasObjectCodec (..), bimapCodec, dimapCodec) -import Autodocodec qualified as AC -import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey, Value) -import Data.HashMap.Strict.InsOrd qualified as InsOrdHashMap +import Autodocodec (HasCodec (codec), dimapCodec) +import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey) import Data.Text.Extended (ToTxt) import Hasura.LogicalModel.NullableScalarType +import Hasura.LogicalModelResolver.Codec (arrayRelationshipsCodec) import Hasura.Prelude hiding (first) -import Hasura.RQL.Types.Backend (Backend (..)) -import Hasura.RQL.Types.Common (RelName) -import Hasura.RQL.Types.Relationships.Local (RelDef, RelManualConfig) import Language.GraphQL.Draft.Syntax qualified as G import Language.Haskell.TH.Syntax (Lift) @@ -31,38 +27,3 @@ instance HasCodec NativeQueryName where instance FromJSONKey NativeQueryName instance ToJSONKey NativeQueryName - -nativeQueryArrayRelationshipsCodec :: - forall b. - (Backend b) => - AC.Codec - Value - (InsOrdHashMap.InsOrdHashMap RelName (RelDef (RelManualConfig b))) - (InsOrdHashMap.InsOrdHashMap RelName (RelDef (RelManualConfig b))) -nativeQueryArrayRelationshipsCodec = - AC.dimapCodec - ( InsOrdHashMap.fromList - . fmap - ( \(MergedObject (NameField name) nst) -> - (name, nst) - ) - ) - ( fmap (\(fld, nst) -> MergedObject (NameField fld) nst) . InsOrdHashMap.toList - ) - ( AC.listCodec $ - AC.object "RelDefRelManualConfig" $ - AC.objectCodec @(MergedObject (NameField RelName) (RelDef (RelManualConfig b))) - ) - -data MergedObject a b = MergedObject - { moFst :: a, - moSnd :: b - } - -instance (HasObjectCodec a, HasObjectCodec b) => HasObjectCodec (MergedObject a b) where - objectCodec = MergedObject <$> bimapCodec Right moFst objectCodec <*> bimapCodec Right moSnd objectCodec - -newtype NameField a = NameField {nameField :: a} - -instance (HasCodec a) => HasObjectCodec (NameField a) where - objectCodec = NameField <$> AC.requiredField "name" "name" AC..= nameField diff --git a/server/src-lib/Hasura/StoredProcedure/API.hs b/server/src-lib/Hasura/StoredProcedure/API.hs index 015467c607f..1fb41dbdd3c 100644 --- a/server/src-lib/Hasura/StoredProcedure/API.hs +++ b/server/src-lib/Hasura/StoredProcedure/API.hs @@ -70,7 +70,7 @@ instance (Backend b) => HasCodec (TrackStoredProcedure b) where AC..= tspConfig <*> AC.optionalFieldWithDefault "arguments" mempty argumentsDoc AC..= tspArguments - <*> AC.optionalFieldWithDefaultWith "array_relationships" storedProcedureArrayRelationshipsCodec mempty arrayRelationshipsDoc + <*> AC.optionalFieldWithDefaultWith "array_relationships" arrayRelationshipsCodec mempty arrayRelationshipsDoc AC..= tspArrayRelationships <*> AC.optionalField "description" descriptionDoc AC..= tspDescription @@ -170,7 +170,7 @@ runGetStoredProcedure q = do pure (encJFromJValue (InsOrdHashMap.elems <$> storedProcedure)) --- | Handler for the 'track_native_query' endpoint. The type 'TrackStoredProcedure b' +-- | Handler for the 'track_stored_procedure' endpoint. The type 'TrackStoredProcedure b' -- (appearing here in wrapped as 'BackendTrackStoredProcedure b' for 'AnyBackend' -- compatibility) is defined in 'class StoredProcedureMetadata'. runTrackStoredProcedure :: diff --git a/server/src-lib/Hasura/StoredProcedure/Metadata.hs b/server/src-lib/Hasura/StoredProcedure/Metadata.hs index ecab0ef072e..e54aa3a31b9 100644 --- a/server/src-lib/Hasura/StoredProcedure/Metadata.hs +++ b/server/src-lib/Hasura/StoredProcedure/Metadata.hs @@ -13,9 +13,6 @@ module Hasura.StoredProcedure.Metadata spmReturns, spmArrayRelationships, ArgumentName (..), - InterpolatedItem (..), - InterpolatedQuery (..), - parseInterpolatedQuery, module Hasura.StoredProcedure.Types, ) where @@ -27,7 +24,7 @@ import Data.Aeson (FromJSON, ToJSON) import Data.HashMap.Strict.InsOrd.Autodocodec (sortedElemsCodec) import Data.Text.Extended qualified as T import Hasura.LogicalModel.Types -import Hasura.NativeQuery.InterpolatedQuery +import Hasura.LogicalModelResolver.Types (ArgumentName (..)) import Hasura.Prelude hiding (first) import Hasura.RQL.Types.Backend import Hasura.RQL.Types.BackendTag (backendPrefix) @@ -42,7 +39,7 @@ type Relationships = InsOrdHashMap RelName --------------------------------------- --- | The representation of native queries within the metadata structure. +-- | The representation of stored procedures within the metadata structure. data StoredProcedureMetadata (b :: BackendType) = StoredProcedureMetadata { _spmStoredProcedure :: FunctionName b, _spmConfig :: StoredProcedureConfig, diff --git a/server/src-lib/Hasura/StoredProcedure/Schema.hs b/server/src-lib/Hasura/StoredProcedure/Schema.hs index b2d68809057..350283e6eba 100644 --- a/server/src-lib/Hasura/StoredProcedure/Schema.hs +++ b/server/src-lib/Hasura/StoredProcedure/Schema.hs @@ -1,14 +1,10 @@ -{-# LANGUAGE QuasiQuotes #-} - -- | Schema parsers for stored procedures. module Hasura.StoredProcedure.Schema (defaultBuildStoredProcedureRootFields) where import Data.Has (Has (getter)) import Data.HashMap.Strict qualified as HashMap -import Data.Monoid (Ap (Ap, getAp)) import Hasura.GraphQL.Schema.Backend ( BackendLogicalModelSelectSchema (..), - BackendSchema (columnParser), MonadBuildSchema, ) import Hasura.GraphQL.Schema.Common @@ -17,11 +13,12 @@ import Hasura.GraphQL.Schema.Common ) import Hasura.GraphQL.Schema.Parser qualified as P import Hasura.LogicalModel.Schema +import Hasura.LogicalModelResolver.Schema (argumentsSchema) import Hasura.Prelude import Hasura.RQL.IR.Root (RemoteRelationshipField) import Hasura.RQL.IR.Select (QueryDB (QDBMultipleRows)) import Hasura.RQL.IR.Select qualified as IR -import Hasura.RQL.IR.Value (Provenance (FromInternal), UnpreparedValue (UVParameter), openValueOrigin) +import Hasura.RQL.IR.Value (Provenance (FromInternal), UnpreparedValue (UVParameter)) import Hasura.RQL.Types.Column qualified as Column import Hasura.RQL.Types.Metadata.Object qualified as MO import Hasura.RQL.Types.Schema.Options qualified as Options @@ -37,7 +34,6 @@ import Hasura.StoredProcedure.IR (StoredProcedure (..)) import Hasura.StoredProcedure.Metadata (ArgumentName (..)) import Hasura.StoredProcedure.Types (NullableScalarType (..)) import Language.GraphQL.Draft.Syntax qualified as G -import Language.GraphQL.Draft.Syntax.QQ qualified as G defaultBuildStoredProcedureRootFields :: forall b r m n. @@ -121,38 +117,4 @@ storedProcedureArgumentsSchema :: G.Name -> HashMap ArgumentName (NullableScalarType b) -> MaybeT (SchemaT r m) (P.InputFieldsParser n (HashMap ArgumentName (Column.ColumnValue b))) -storedProcedureArgumentsSchema storedProcedureName argsSignature = do - -- Lift 'SchemaT r m (InputFieldsParser ..)' into a monoid using Applicative. - -- This lets us use 'foldMap' + monoid structure of hashmaps to avoid awkwardly - -- traversing the arguments and building the resulting parser. - argsParser <- - getAp $ - foldMap - ( \(name, NullableScalarType {nstType, nstNullable, nstDescription}) -> Ap do - argValueParser <- - fmap (HashMap.singleton name . openValueOrigin) - <$> lift (columnParser (Column.ColumnScalar nstType) (G.Nullability nstNullable)) - -- TODO: Naming conventions? - -- TODO: Custom fields? (Probably not) - argName <- hoistMaybe (G.mkName (getArgumentName name)) - let description = case nstDescription of - Just desc -> G.Description desc - Nothing -> G.Description ("Stored procedure argument " <> getArgumentName name) - pure $ - P.field - argName - (Just description) - argValueParser - ) - (HashMap.toList argsSignature) - - let desc = Just $ G.Description $ G.unName storedProcedureName <> " Stored Procedure Arguments" - - pure $ - if null argsSignature - then mempty - else - P.field - [G.name|args|] - desc - (P.object (storedProcedureName <> [G.name|_arguments|]) desc argsParser) +storedProcedureArgumentsSchema = argumentsSchema "Stored Procedure" diff --git a/server/src-lib/Hasura/StoredProcedure/Types.hs b/server/src-lib/Hasura/StoredProcedure/Types.hs index 2e7324dadba..17a6ad61895 100644 --- a/server/src-lib/Hasura/StoredProcedure/Types.hs +++ b/server/src-lib/Hasura/StoredProcedure/Types.hs @@ -4,62 +4,22 @@ module Hasura.StoredProcedure.Types ( NullableScalarType (..), nullableScalarTypeMapCodec, - storedProcedureArrayRelationshipsCodec, + arrayRelationshipsCodec, StoredProcedureConfig (..), StoredProcedureExposedAs (..), ) where -import Autodocodec (HasCodec (codec), HasObjectCodec (..), bimapCodec) +import Autodocodec (HasCodec (codec)) import Autodocodec qualified as AC import Autodocodec.Extended (graphQLFieldNameCodec) import Data.Aeson import Data.Char (toLower) -import Data.HashMap.Strict.InsOrd qualified as InsOrdHashMap import Hasura.LogicalModel.NullableScalarType +import Hasura.LogicalModelResolver.Codec (arrayRelationshipsCodec) import Hasura.Prelude hiding (first) -import Hasura.RQL.Types.Backend (Backend (..)) -import Hasura.RQL.Types.Common (RelName) -import Hasura.RQL.Types.Relationships.Local (RelDef, RelManualConfig) import Language.GraphQL.Draft.Syntax qualified as G -data MergedObject a b = MergedObject - { moFst :: a, - moSnd :: b - } - -instance (HasObjectCodec a, HasObjectCodec b) => HasObjectCodec (MergedObject a b) where - objectCodec = MergedObject <$> bimapCodec Right moFst objectCodec <*> bimapCodec Right moSnd objectCodec - -newtype NameField a = NameField {nameField :: a} - -instance (HasCodec a) => HasObjectCodec (NameField a) where - objectCodec = NameField <$> AC.requiredField "name" "name" AC..= nameField - -storedProcedureArrayRelationshipsCodec :: - forall b. - (Backend b) => - AC.Codec - Value - (InsOrdHashMap.InsOrdHashMap RelName (RelDef (RelManualConfig b))) - (InsOrdHashMap.InsOrdHashMap RelName (RelDef (RelManualConfig b))) -storedProcedureArrayRelationshipsCodec = - AC.dimapCodec - ( InsOrdHashMap.fromList - . fmap - ( \(MergedObject (NameField name) nst) -> - (name, nst) - ) - ) - ( fmap (\(fld, nst) -> MergedObject (NameField fld) nst) . InsOrdHashMap.toList - ) - ( AC.listCodec $ - AC.object "RelDefRelManualConfig" $ - AC.objectCodec @(MergedObject (NameField RelName) (RelDef (RelManualConfig b))) - ) - --- * Configuration - -- | Tracked stored procedure configuration, and payload of the 'pg_track_stored procedure'. data StoredProcedureConfig = StoredProcedureConfig { -- | In which top-level field should we expose this stored procedure?