mirror of
https://github.com/hasura/graphql-engine.git
synced 2024-12-15 01:12:56 +03:00
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:
parent
ee59a220e1
commit
56e3bd182a
@ -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
|
||||||
|
50
server/src-lib/Hasura/LogicalModelResolver/Codec.hs
Normal file
50
server/src-lib/Hasura/LogicalModelResolver/Codec.hs
Normal 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
|
69
server/src-lib/Hasura/LogicalModelResolver/Schema.hs
Normal file
69
server/src-lib/Hasura/LogicalModelResolver/Schema.hs
Normal 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)
|
32
server/src-lib/Hasura/LogicalModelResolver/Types.hs
Normal file
32
server/src-lib/Hasura/LogicalModelResolver/Types.hs
Normal 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
|
@ -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
|
||||||
|
@ -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 ->
|
||||||
|
@ -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)
|
|
||||||
|
@ -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
|
|
||||||
|
@ -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 ::
|
||||||
|
@ -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,
|
||||||
|
@ -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)
|
|
||||||
|
@ -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?
|
||||||
|
Loading…
Reference in New Issue
Block a user