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
This commit is contained in:
Gil Mizrahi 2023-05-03 12:59:21 +03:00 committed by hasura-bot
parent ee59a220e1
commit 56e3bd182a
12 changed files with 176 additions and 197 deletions

View File

@ -745,6 +745,10 @@ library
, Hasura.Server.Auth.JWT , Hasura.Server.Auth.JWT
, Hasura.GC , Hasura.GC
, Hasura.LogicalModelResolver.Codec
, Hasura.LogicalModelResolver.Schema
, Hasura.LogicalModelResolver.Types
, Hasura.NativeQuery.IR , Hasura.NativeQuery.IR
, Hasura.NativeQuery.Cache , Hasura.NativeQuery.Cache
, Hasura.NativeQuery.Lenses , Hasura.NativeQuery.Lenses

View File

@ -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

View File

@ -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)

View File

@ -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

View File

@ -25,7 +25,7 @@ import Hasura.EncJSON
import Hasura.LogicalModel.API (getCustomTypes) import Hasura.LogicalModel.API (getCustomTypes)
import Hasura.LogicalModel.Metadata (LogicalModelName) import Hasura.LogicalModel.Metadata (LogicalModelName)
import Hasura.NativeQuery.Metadata (ArgumentName, NativeQueryMetadata (..), parseInterpolatedQuery) 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.Prelude
import Hasura.RQL.Types.Backend (Backend, SourceConnConfiguration) import Hasura.RQL.Types.Backend (Backend, SourceConnConfiguration)
import Hasura.RQL.Types.BackendTag import Hasura.RQL.Types.BackendTag
@ -70,7 +70,7 @@ instance (Backend b) => HasCodec (TrackNativeQuery b) where
AC..= tnqCode AC..= tnqCode
<*> AC.optionalFieldWithDefault "arguments" mempty argumentsDoc <*> AC.optionalFieldWithDefault "arguments" mempty argumentsDoc
AC..= tnqArguments AC..= tnqArguments
<*> AC.optionalFieldWithDefaultWith "array_relationships" nativeQueryArrayRelationshipsCodec mempty arrayRelationshipsDoc <*> AC.optionalFieldWithDefaultWith "array_relationships" arrayRelationshipsCodec mempty arrayRelationshipsDoc
AC..= tnqArrayRelationships AC..= tnqArrayRelationships
<*> AC.optionalField "description" descriptionDoc <*> AC.optionalField "description" descriptionDoc
AC..= tnqDescription AC..= tnqDescription

View File

@ -13,10 +13,11 @@ where
import Autodocodec import Autodocodec
import Autodocodec qualified as AC import Autodocodec qualified as AC
import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey) import Data.Aeson (FromJSON, ToJSON)
import Data.Bifunctor (first) import Data.Bifunctor (first)
import Data.Text qualified as T import Data.Text qualified as T
import Hasura.LogicalModel.NullableScalarType (NullableScalarType (..), nullableScalarTypeMapCodec) import Hasura.LogicalModel.NullableScalarType (NullableScalarType (..), nullableScalarTypeMapCodec)
import Hasura.LogicalModelResolver.Types (ArgumentName (..))
import Hasura.Prelude hiding (first) import Hasura.Prelude hiding (first)
import Language.Haskell.TH.Syntax (Lift) 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 -- | extract all of the `{{ variable }}` inside our query string
parseInterpolatedQuery :: parseInterpolatedQuery ::
Text -> Text ->

View File

@ -1,14 +1,10 @@
{-# LANGUAGE QuasiQuotes #-}
-- | Schema parsers for native queries. -- | Schema parsers for native queries.
module Hasura.NativeQuery.Schema (defaultBuildNativeQueryRootFields) where module Hasura.NativeQuery.Schema (defaultBuildNativeQueryRootFields) where
import Data.Has (Has (getter)) import Data.Has (Has (getter))
import Data.HashMap.Strict qualified as HashMap import Data.HashMap.Strict qualified as HashMap
import Data.Monoid (Ap (Ap, getAp))
import Hasura.GraphQL.Schema.Backend import Hasura.GraphQL.Schema.Backend
( BackendLogicalModelSelectSchema (..), ( BackendLogicalModelSelectSchema (..),
BackendSchema (columnParser),
MonadBuildSchema, MonadBuildSchema,
) )
import Hasura.GraphQL.Schema.Common import Hasura.GraphQL.Schema.Common
@ -17,6 +13,7 @@ import Hasura.GraphQL.Schema.Common
) )
import Hasura.GraphQL.Schema.Parser qualified as P import Hasura.GraphQL.Schema.Parser qualified as P
import Hasura.LogicalModel.Schema import Hasura.LogicalModel.Schema
import Hasura.LogicalModelResolver.Schema (argumentsSchema)
import Hasura.NativeQuery.Cache (NativeQueryInfo (..)) import Hasura.NativeQuery.Cache (NativeQueryInfo (..))
import Hasura.NativeQuery.IR (NativeQuery (..)) import Hasura.NativeQuery.IR (NativeQuery (..))
import Hasura.NativeQuery.Metadata (ArgumentName (..), InterpolatedQuery (..)) import Hasura.NativeQuery.Metadata (ArgumentName (..), InterpolatedQuery (..))
@ -25,7 +22,7 @@ import Hasura.Prelude
import Hasura.RQL.IR.Root (RemoteRelationshipField) import Hasura.RQL.IR.Root (RemoteRelationshipField)
import Hasura.RQL.IR.Select (QueryDB (QDBMultipleRows)) import Hasura.RQL.IR.Select (QueryDB (QDBMultipleRows))
import Hasura.RQL.IR.Select qualified as IR 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.Column qualified as Column
import Hasura.RQL.Types.Metadata.Object qualified as MO import Hasura.RQL.Types.Metadata.Object qualified as MO
import Hasura.RQL.Types.Schema.Options qualified as Options import Hasura.RQL.Types.Schema.Options qualified as Options
@ -37,7 +34,6 @@ import Hasura.RQL.Types.SourceCustomization
) )
import Hasura.SQL.AnyBackend (mkAnyBackend) import Hasura.SQL.AnyBackend (mkAnyBackend)
import Language.GraphQL.Draft.Syntax qualified as G import Language.GraphQL.Draft.Syntax qualified as G
import Language.GraphQL.Draft.Syntax.QQ qualified as G
defaultBuildNativeQueryRootFields :: defaultBuildNativeQueryRootFields ::
forall b r m n. forall b r m n.
@ -122,38 +118,4 @@ nativeQueryArgumentsSchema ::
G.Name -> G.Name ->
HashMap ArgumentName (NullableScalarType b) -> HashMap ArgumentName (NullableScalarType b) ->
MaybeT (SchemaT r m) (P.InputFieldsParser n (HashMap ArgumentName (Column.ColumnValue b))) MaybeT (SchemaT r m) (P.InputFieldsParser n (HashMap ArgumentName (Column.ColumnValue b)))
nativeQueryArgumentsSchema nativeQueryName argsSignature = do nativeQueryArgumentsSchema = argumentsSchema "Native Query"
-- 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)

View File

@ -3,20 +3,16 @@ module Hasura.NativeQuery.Types
( NativeQueryName (..), ( NativeQueryName (..),
NullableScalarType (..), NullableScalarType (..),
nullableScalarTypeMapCodec, nullableScalarTypeMapCodec,
nativeQueryArrayRelationshipsCodec, arrayRelationshipsCodec,
) )
where where
import Autodocodec (HasCodec (codec), HasObjectCodec (..), bimapCodec, dimapCodec) import Autodocodec (HasCodec (codec), dimapCodec)
import Autodocodec qualified as AC import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey)
import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey, Value)
import Data.HashMap.Strict.InsOrd qualified as InsOrdHashMap
import Data.Text.Extended (ToTxt) import Data.Text.Extended (ToTxt)
import Hasura.LogicalModel.NullableScalarType import Hasura.LogicalModel.NullableScalarType
import Hasura.LogicalModelResolver.Codec (arrayRelationshipsCodec)
import Hasura.Prelude hiding (first) 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.GraphQL.Draft.Syntax qualified as G
import Language.Haskell.TH.Syntax (Lift) import Language.Haskell.TH.Syntax (Lift)
@ -31,38 +27,3 @@ instance HasCodec NativeQueryName where
instance FromJSONKey NativeQueryName instance FromJSONKey NativeQueryName
instance ToJSONKey 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

View File

@ -70,7 +70,7 @@ instance (Backend b) => HasCodec (TrackStoredProcedure b) where
AC..= tspConfig AC..= tspConfig
<*> AC.optionalFieldWithDefault "arguments" mempty argumentsDoc <*> AC.optionalFieldWithDefault "arguments" mempty argumentsDoc
AC..= tspArguments AC..= tspArguments
<*> AC.optionalFieldWithDefaultWith "array_relationships" storedProcedureArrayRelationshipsCodec mempty arrayRelationshipsDoc <*> AC.optionalFieldWithDefaultWith "array_relationships" arrayRelationshipsCodec mempty arrayRelationshipsDoc
AC..= tspArrayRelationships AC..= tspArrayRelationships
<*> AC.optionalField "description" descriptionDoc <*> AC.optionalField "description" descriptionDoc
AC..= tspDescription AC..= tspDescription
@ -170,7 +170,7 @@ runGetStoredProcedure q = do
pure (encJFromJValue (InsOrdHashMap.elems <$> storedProcedure)) 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' -- (appearing here in wrapped as 'BackendTrackStoredProcedure b' for 'AnyBackend'
-- compatibility) is defined in 'class StoredProcedureMetadata'. -- compatibility) is defined in 'class StoredProcedureMetadata'.
runTrackStoredProcedure :: runTrackStoredProcedure ::

View File

@ -13,9 +13,6 @@ module Hasura.StoredProcedure.Metadata
spmReturns, spmReturns,
spmArrayRelationships, spmArrayRelationships,
ArgumentName (..), ArgumentName (..),
InterpolatedItem (..),
InterpolatedQuery (..),
parseInterpolatedQuery,
module Hasura.StoredProcedure.Types, module Hasura.StoredProcedure.Types,
) )
where where
@ -27,7 +24,7 @@ import Data.Aeson (FromJSON, ToJSON)
import Data.HashMap.Strict.InsOrd.Autodocodec (sortedElemsCodec) import Data.HashMap.Strict.InsOrd.Autodocodec (sortedElemsCodec)
import Data.Text.Extended qualified as T import Data.Text.Extended qualified as T
import Hasura.LogicalModel.Types import Hasura.LogicalModel.Types
import Hasura.NativeQuery.InterpolatedQuery import Hasura.LogicalModelResolver.Types (ArgumentName (..))
import Hasura.Prelude hiding (first) import Hasura.Prelude hiding (first)
import Hasura.RQL.Types.Backend import Hasura.RQL.Types.Backend
import Hasura.RQL.Types.BackendTag (backendPrefix) 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 data StoredProcedureMetadata (b :: BackendType) = StoredProcedureMetadata
{ _spmStoredProcedure :: FunctionName b, { _spmStoredProcedure :: FunctionName b,
_spmConfig :: StoredProcedureConfig, _spmConfig :: StoredProcedureConfig,

View File

@ -1,14 +1,10 @@
{-# LANGUAGE QuasiQuotes #-}
-- | Schema parsers for stored procedures. -- | Schema parsers for stored procedures.
module Hasura.StoredProcedure.Schema (defaultBuildStoredProcedureRootFields) where module Hasura.StoredProcedure.Schema (defaultBuildStoredProcedureRootFields) where
import Data.Has (Has (getter)) import Data.Has (Has (getter))
import Data.HashMap.Strict qualified as HashMap import Data.HashMap.Strict qualified as HashMap
import Data.Monoid (Ap (Ap, getAp))
import Hasura.GraphQL.Schema.Backend import Hasura.GraphQL.Schema.Backend
( BackendLogicalModelSelectSchema (..), ( BackendLogicalModelSelectSchema (..),
BackendSchema (columnParser),
MonadBuildSchema, MonadBuildSchema,
) )
import Hasura.GraphQL.Schema.Common import Hasura.GraphQL.Schema.Common
@ -17,11 +13,12 @@ import Hasura.GraphQL.Schema.Common
) )
import Hasura.GraphQL.Schema.Parser qualified as P import Hasura.GraphQL.Schema.Parser qualified as P
import Hasura.LogicalModel.Schema import Hasura.LogicalModel.Schema
import Hasura.LogicalModelResolver.Schema (argumentsSchema)
import Hasura.Prelude import Hasura.Prelude
import Hasura.RQL.IR.Root (RemoteRelationshipField) import Hasura.RQL.IR.Root (RemoteRelationshipField)
import Hasura.RQL.IR.Select (QueryDB (QDBMultipleRows)) import Hasura.RQL.IR.Select (QueryDB (QDBMultipleRows))
import Hasura.RQL.IR.Select qualified as IR 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.Column qualified as Column
import Hasura.RQL.Types.Metadata.Object qualified as MO import Hasura.RQL.Types.Metadata.Object qualified as MO
import Hasura.RQL.Types.Schema.Options qualified as Options 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.Metadata (ArgumentName (..))
import Hasura.StoredProcedure.Types (NullableScalarType (..)) import Hasura.StoredProcedure.Types (NullableScalarType (..))
import Language.GraphQL.Draft.Syntax qualified as G import Language.GraphQL.Draft.Syntax qualified as G
import Language.GraphQL.Draft.Syntax.QQ qualified as G
defaultBuildStoredProcedureRootFields :: defaultBuildStoredProcedureRootFields ::
forall b r m n. forall b r m n.
@ -121,38 +117,4 @@ storedProcedureArgumentsSchema ::
G.Name -> G.Name ->
HashMap ArgumentName (NullableScalarType b) -> HashMap ArgumentName (NullableScalarType b) ->
MaybeT (SchemaT r m) (P.InputFieldsParser n (HashMap ArgumentName (Column.ColumnValue b))) MaybeT (SchemaT r m) (P.InputFieldsParser n (HashMap ArgumentName (Column.ColumnValue b)))
storedProcedureArgumentsSchema storedProcedureName argsSignature = do storedProcedureArgumentsSchema = argumentsSchema "Stored Procedure"
-- 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)

View File

@ -4,62 +4,22 @@
module Hasura.StoredProcedure.Types module Hasura.StoredProcedure.Types
( NullableScalarType (..), ( NullableScalarType (..),
nullableScalarTypeMapCodec, nullableScalarTypeMapCodec,
storedProcedureArrayRelationshipsCodec, arrayRelationshipsCodec,
StoredProcedureConfig (..), StoredProcedureConfig (..),
StoredProcedureExposedAs (..), StoredProcedureExposedAs (..),
) )
where where
import Autodocodec (HasCodec (codec), HasObjectCodec (..), bimapCodec) import Autodocodec (HasCodec (codec))
import Autodocodec qualified as AC import Autodocodec qualified as AC
import Autodocodec.Extended (graphQLFieldNameCodec) import Autodocodec.Extended (graphQLFieldNameCodec)
import Data.Aeson import Data.Aeson
import Data.Char (toLower) import Data.Char (toLower)
import Data.HashMap.Strict.InsOrd qualified as InsOrdHashMap
import Hasura.LogicalModel.NullableScalarType import Hasura.LogicalModel.NullableScalarType
import Hasura.LogicalModelResolver.Codec (arrayRelationshipsCodec)
import Hasura.Prelude hiding (first) 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.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'. -- | Tracked stored procedure configuration, and payload of the 'pg_track_stored procedure'.
data StoredProcedureConfig = StoredProcedureConfig data StoredProcedureConfig = StoredProcedureConfig
{ -- | In which top-level field should we expose this stored procedure? { -- | In which top-level field should we expose this stored procedure?