From 2ee5152d54124bd9afae7c12cac91f653fabe85b Mon Sep 17 00:00:00 2001
From: prescientmoon <git@moonythm.dev>
Date: Wed, 9 Oct 2024 20:51:29 +0200
Subject: [PATCH] Implement querying by PK
- I realised by PK querying doesn't need arguments like filter, limit or
offset, so I removed the argument name collision logic I added in the
last commit
- I implemented the actual logic for querying by PK. The code is a lot
shorter due to the new introspection system
- I moved the normal queries to the new introspection system for
consistency.
- I moved the logic of "coerce columns without a datatype" away from the
resolver and into the "sql -> gql" converter as to be able to reuse the
default introspection resolver which simply looks up fields into the
parent resolver's result.
- I added some comments documenting the Introspection.Resolver stuff and
it's behaviour
---
source/AirGQL/GraphQL.hs | 374 +++++++++++-------------
source/AirGQL/Introspection.hs | 85 +++---
source/AirGQL/Introspection/Resolver.hs | 36 ++-
3 files changed, 244 insertions(+), 251 deletions(-)
diff --git a/source/AirGQL/GraphQL.hs b/source/AirGQL/GraphQL.hs
index d678437..22927a0 100644
--- a/source/AirGQL/GraphQL.hs
+++ b/source/AirGQL/GraphQL.hs
@@ -75,7 +75,7 @@ import Language.GraphQL.Type as GQL (
EnumValue (EnumValue),
InputField (InputField),
Resolver (EventStreamResolver, ValueResolver),
- ScalarType,
+ ScalarType (ScalarType),
Schema,
Value (Boolean, Enum, Float, Int, List, Null, Object, String),
boolean,
@@ -101,12 +101,15 @@ import AirGQL.GQLWrapper (
inArgumentToArgument,
outFieldToField,
)
+
import AirGQL.Introspection (getSchemaResolver, typeNameResolver)
+import AirGQL.Introspection qualified as Introspection
+import AirGQL.Introspection.Resolver qualified as Introspection
import AirGQL.Lib (
AccessMode (ReadAndWrite, ReadOnly, WriteOnly),
ColumnEntry (column_name, datatype, datatype_gql),
GqlTypeName (root),
- TableEntry (name),
+ TableEntry (columns, name),
column_name_gql,
getColumns,
)
@@ -120,10 +123,14 @@ import AirGQL.Types.SchemaConf (
)
import AirGQL.Types.Utils (encodeToText)
import AirGQL.Utils (colToFileUrl, collectErrorList, quoteKeyword, quoteText)
+import Data.Either.Extra qualified as Either
typeNameToScalarType :: Maybe GqlTypeName -> ScalarType
-typeNameToScalarType Nothing = string
+typeNameToScalarType Nothing =
+ ScalarType
+ "any"
+ (Just "A type that could result to any kind of GQL scalar")
typeNameToScalarType (Just typeName) =
case typeName.root of
"Int" -> int
@@ -195,13 +202,7 @@ colNamesWithValResolver columnEntries =
Object obj ->
case obj & HashMap.lookup colEntry.column_name_gql of
Nothing -> String "Error: Field does not exist"
- Just val ->
- case colEntry.datatype of
- -- Coerce value to nullable String
- -- if no datatype is set.
- -- This happens for columns in views.
- "" -> gqlValueToNullableString val
- _ -> val
+ Just val -> val
_ -> String "Error: Value could not be retrieved"
in
( colEntry.column_name_gql
@@ -441,141 +442,15 @@ queryType connection accessMode dbId tables = do
documentation =
"Available queries for database \"" <> dbId <> "\""
- getOutField :: Text -> IO (Out.Field IO)
- getOutField tableName = do
- columnEntries <- liftIO $ getColumns dbId connection tableName
+ getOutField :: TableEntry -> IO (Out.Field IO)
+ getOutField table =
+ case Introspection.makeField $ Introspection.tableQueryField table of
+ Left err -> P.throwIO $ userError $ T.unpack err
+ Right result -> pure result
- let
- colNamesWithOrderingTerm :: [(Text, InputField)]
- colNamesWithOrderingTerm =
- columnEntries <&> \colEntry ->
- ( colEntry.column_name_gql
- , InputField
- (Just $ "Ordering term for " <> colEntry.column_name_gql)
- ( In.NamedEnumType $
- EnumType
- "OrderingTerm"
- (Just "Ordering object for the column")
- ( HashMap.fromList
- [ ("ASC", EnumValue (Just "ASC"))
- , ("asc", EnumValue (Just "ASC"))
- , ("DESC", EnumValue (Just "DESC"))
- , ("desc", EnumValue (Just "DESC"))
- ]
- )
- )
- Nothing -- Default value
- )
-
- typeNameField :: Text -> [(Text, Resolver IO)]
- typeNameField nameOfTable =
- let
- typeNameOutField =
- outFieldToField $
- OutField
- { descriptionMb = Just $ "The type name of " <> nameOfTable
- , fieldType = Out.NonNullScalarType string
- , arguments = HashMap.empty
- }
- in
- [
- ( "__typename"
- , ValueResolver typeNameOutField $
- pure $
- String $
- doubleXEncodeGql nameOfTable <> "_row"
- )
- ]
-
- pure $
- outFieldToField $
- OutField
- { descriptionMb = Just $ "Provides entries from " <> tableName
- , fieldType =
- Out.ListType $
- Out.NamedObjectType $
- Out.ObjectType
- tableName
- (Just "short desc")
- []
- ( HashMap.fromList $
- colNamesWithValResolver columnEntries
- <> typeNameField tableName
- )
- , arguments =
- HashMap.fromList
- [
- ( "filter"
- , inArgumentToArgument $
- InArgument
- { argDescMb = Just "Filter objects"
- , argType =
- NamedInputObjectType $
- InputObjectType
- (doubleXEncodeGql tableName <> "_filter")
- ( Just
- "Filter objects for the specified columns"
- )
- (HashMap.fromList (colNamesWithFilterField tableName columnEntries))
- , valueMb = Nothing
- }
- )
- ,
- ( "order_by"
- , inArgumentToArgument $
- InArgument
- { argDescMb = Just "Order by the specified columns"
- , argType =
- In.ListType $
- In.NamedInputObjectType $
- InputObjectType
- (doubleXEncodeGql tableName <> "_order_by")
- (Just "Options for ordering by columns")
- (HashMap.fromList colNamesWithOrderingTerm)
- , valueMb = Nothing
- }
- )
- ,
- ( "limit"
- , inArgumentToArgument $
- InArgument
- { argDescMb =
- Just "Limit the number of returned rows."
- , argType = In.NamedScalarType int
- , valueMb = Nothing
- }
- )
- ,
- ( "offset"
- , inArgumentToArgument $
- InArgument
- { argDescMb =
- Just
- "Change the index rows \
- \start being returned from"
- , argType = In.NamedScalarType int
- , valueMb = Nothing
- }
- )
- ]
- }
- -- -- TODO: Use for retrieving record by primary key
- -- , arguments = HashMap.fromList $ columnEntries
- -- <&> (\colEntry ->
- -- ( colEntry.column_name_gql :: Text
- -- , inArgumentToArgument $ InArgument
- -- { argDescMb = Just "Retrieve object by primary key"
- -- , argType = In.NamedScalarType $
- -- typeNameToScalarType $ colEntry.datatype
- -- , valueMb = Nothing
- -- }
- -- )
- -- )
-
- getDbEntries :: Text -> Out.Resolve IO
- getDbEntries tableName = do
+ getDbEntries :: TableEntry -> Out.Resolve IO
+ getDbEntries table = do
context <- ask
- colEntries <- liftIO $ getColumns dbId connection tableName
rows :: [[SQLData]] <- case context.arguments of
Arguments args -> do
@@ -647,7 +522,7 @@ queryType connection accessMode dbId tables = do
Query $
P.fold
[ "SELECT COUNT() FROM"
- , quoteKeyword tableName
+ , quoteKeyword table.name
, "\n"
, getWhereClause filterElements
]
@@ -682,68 +557,105 @@ queryType connection accessMode dbId tables = do
, show numRows
, " rows. "
, "Consider setting the `limit` argument on your query: `{ "
- , T.unpack tableName
+ , T.unpack table.name
, " (limit: 50) { ... } }`"
]
liftIO $
executeSqlQuery
connection
- tableName
- colEntries
+ table.name
+ table.columns
filterElements
orderElements
paginationMb
- rowsToList dbId tableName colEntries rows
+ colErrorsToUserError $ rowsToGraphQL dbId table.name table.columns rows
+
+ getOutByPKField :: TableEntry -> IO (Maybe (Out.Field IO))
+ getOutByPKField tableEntry = do
+ let fieldMb = Introspection.tableQueryByPKField tableEntry
+ P.for fieldMb $ \field -> do
+ let fieldEither = Introspection.makeField field
+
+ case fieldEither of
+ Left err -> P.throwIO $ userError $ T.unpack err
+ Right result -> pure result
+
+ getDbEntriesByPK :: TableEntry -> Out.Resolve IO
+ getDbEntriesByPK tableEntry = do
+ context <- ask
+
+ let
+ Arguments args = context.arguments
+ filterElements = do
+ (key, value) <- HashMap.toList args
+ pure (key, Object $ HashMap.singleton "eq" value)
+
+ -- This query can return at most one row, so we don't worry checking for
+ -- COUNT() and asserting it's within the set limits.
+ queryResult <-
+ liftIO $
+ executeSqlQuery
+ connection
+ tableEntry.name
+ tableEntry.columns
+ filterElements
+ []
+ Nothing
+
+ case P.head queryResult of
+ Nothing -> pure Null
+ Just row ->
+ colErrorsToUserError $
+ rowToGraphQL
+ dbId
+ tableEntry.name
+ tableEntry.columns
+ row
getResolvers :: IO (HashMap.HashMap Text (Resolver IO))
getResolvers = do
let
+ -- Exceptions must be converted to ResolverExceptions
+ -- to be picked up by GQL query executor
+ wrapResolver :: Out.Resolve IO -> Out.Resolve IO
+ wrapResolver resolver =
+ catchAll
+ resolver
+ (throw . ResolverException)
+
getTableTuple :: TableEntry -> IO (Text, Resolver IO)
getTableTuple table = do
- outField <- getOutField table.name
+ outField <- getOutField table
pure
( doubleXEncodeGql table.name
, ValueResolver
outField
- ( -- Exceptions must be converted to ResolverExceptions
- -- to be picked up by GQL query executor
- catchAll
- (getDbEntries table.name)
- (throw . ResolverException)
- )
+ $ wrapResolver
+ $ getDbEntries table
)
- getTableTuples :: IO [(Text, Resolver IO)]
- getTableTuples =
- P.for tables getTableTuple
+ getTableByPKTuple :: TableEntry -> IO (Maybe (Text, Resolver IO))
+ getTableByPKTuple table = do
+ fieldMb <- getOutByPKField table
+ P.for fieldMb $ \outField -> do
+ pure
+ ( doubleXEncodeGql $ table.name <> "_by_pk"
+ , ValueResolver
+ outField
+ $ wrapResolver
+ $ getDbEntriesByPK table
+ )
- getTableTuples <&> HashMap.fromList
-
- -- -- TODO: Add support for retriving record by ID
- -- getResolversPrimaryKey :: IO (HashMap.HashMap Text (Resolver IO))
- -- getResolversPrimaryKey = do
- -- let
- -- getTableTuple table = do
- -- outField <- getOutField $ table.name
- -- pure
- -- ( table.name) <> "_by_pk"
- -- , ValueResolver
- -- outField
- -- (getDbEntries $ table.name)
- -- )
-
- -- getTableTuples :: IO [(Text, Resolver IO)]
- -- getTableTuples =
- -- sequence $ tables <&> getTableTuple
-
- -- getTableTuples <&> HashMap.fromList
+ queryMany <- P.for tables getTableTuple
+ queryByPKMbs <- P.for tables getTableByPKTuple
+ let queryByPK = P.catMaybes queryByPKMbs
+ pure $ HashMap.fromList $ queryMany <> queryByPK
resolvers <- getResolvers
schemaResolver <- getSchemaResolver accessMode tables
- -- resolversPrimaryKey <- getResolversPrimaryKey
let
-- Resolve = ReaderT Context m Value
wrapResolve resolve = do
@@ -923,8 +835,64 @@ getMutationResponse accessMode tableName columnEntries =
}
-rowsToList :: (MonadIO m) => Text -> Text -> [ColumnEntry] -> [[SQLData]] -> m Value
-rowsToList dbId tableName columnEntries updatedRows =
+rowToGraphQL :: Text -> Text -> [ColumnEntry] -> [SQLData] -> Either [(Text, Text)] Value
+rowToGraphQL dbId tableName columnEntries row =
+ let
+ buildMetadataJson :: Text -> Text -> Text
+ buildMetadataJson colName rowid =
+ object ["url" .= colToFileUrl dbId tableName colName rowid]
+ & encodeToText
+
+ parseSqlData :: (ColumnEntry, SQLData) -> Either (Text, Text) (Text, Value)
+ parseSqlData (colEntry, colVal) =
+ if "BLOB" `T.isPrefixOf` colEntry.datatype
+ then
+ pure
+ ( colEntry.column_name_gql
+ , case colVal of
+ SQLNull -> Null
+ SQLInteger id ->
+ String $
+ buildMetadataJson colEntry.column_name (show id)
+ SQLText id ->
+ String $
+ buildMetadataJson colEntry.column_name id
+ _ -> Null
+ )
+ else case sqlDataToGQLValue colEntry.datatype colVal of
+ Left err ->
+ Left
+ (colEntry.column_name_gql, err)
+ Right gqlData ->
+ Right
+ ( colEntry.column_name_gql
+ , case colEntry.datatype of
+ -- Coerce value to nullable String
+ -- if no datatype is set.
+ -- This happens for columns in views.
+ "" -> gqlValueToNullableString gqlData
+ _ -> gqlData
+ )
+ in
+ -- => [(ColumnEntry, SQLData)]
+ P.zip columnEntries row
+ -- => [Either (Text, Text) (Text, Value)]
+ <&> parseSqlData
+ -- => Either [(Text, Text)] (Text, Value)
+ & collectErrorList
+ -- => Either [(Text, Text)] (HashMap Text Value)
+ <&> HashMap.fromList
+ -- => Either [(Text, Text)] Value
+ <&> Object
+
+
+rowsToGraphQL
+ :: Text
+ -> Text
+ -> [ColumnEntry]
+ -> [[SQLData]]
+ -> Either [(Text, Text)] Value
+rowsToGraphQL dbId tableName columnEntries updatedRows =
let
buildMetadataJson :: Text -> Text -> Text
buildMetadataJson colName rowid =
@@ -970,18 +938,26 @@ rowsToList dbId tableName columnEntries updatedRows =
)
-- => Either [[(Text, Text)]] [Value]
& collectErrorList
- & \case
- Right values -> pure $ List values
- Left errors ->
- let
- errorLines =
- P.join errors
- <&> \(column, err) -> "On column " <> show column <> ": " <> err
- in
- P.throwIO $
- userError $
- T.unpack $
- "Multiple errors occurred:\n" <> P.unlines errorLines
+ -- => Either [(Text, Text)] [Value]
+ & Either.mapLeft P.join
+ -- => Either [(Text, Text)] Value
+ <&> List
+
+
+-- | Formats errors from `row(s)ToGraphQL` and throws them.
+colErrorsToUserError :: forall m a. (MonadIO m) => Either [(Text, Text)] a -> m a
+colErrorsToUserError = \case
+ Right v -> pure v
+ Left errors ->
+ let
+ errorLines =
+ errors
+ <&> \(column, err) -> "On column " <> show column <> ": " <> err
+ in
+ P.throwIO $
+ userError $
+ T.unpack $
+ "Multiple errors occurred:\n" <> P.unlines errorLines
executeSqlMutation
@@ -1403,7 +1379,9 @@ mutationType connection maxRowsPerTable accessMode dbId tables = do
pure (P.length sqlDataRows, returnedRows & P.concat)
(numOfChanges, returnedRows) <- insertInDb context.arguments
- returning <- rowsToList dbId tableName columnEntries returnedRows
+ returning <-
+ colErrorsToUserError $
+ rowsToGraphQL dbId tableName columnEntries returnedRows
pure $
Object $
@@ -1434,7 +1412,9 @@ mutationType connection maxRowsPerTable accessMode dbId tables = do
filterElements
_ -> pure (0, [])
- returning <- rowsToList dbId tableName columnEntries updatedRows
+ returning <-
+ colErrorsToUserError $
+ rowsToGraphQL dbId tableName columnEntries updatedRows
pure $
Object $
@@ -1491,7 +1471,9 @@ mutationType connection maxRowsPerTable accessMode dbId tables = do
_ -> pure (0, [])
Nothing -> pure (0, [])
- returning <- rowsToList dbId tableName columnEntries deletedRows
+ returning <-
+ colErrorsToUserError $
+ rowsToGraphQL dbId tableName columnEntries deletedRows
pure $
Object $
diff --git a/source/AirGQL/Introspection.hs b/source/AirGQL/Introspection.hs
index abac643..084eaff 100644
--- a/source/AirGQL/Introspection.hs
+++ b/source/AirGQL/Introspection.hs
@@ -1,6 +1,8 @@
module AirGQL.Introspection (
typeNameResolver,
getSchemaResolver,
+ tableQueryField,
+ tableQueryByPKField,
)
where
@@ -131,8 +133,8 @@ tableRowType table = do
Type.object (doubleXEncodeGql table.name <> "_row") fields
-tableQueryCommonArgs :: TableEntry -> [Type.InputValue]
-tableQueryCommonArgs table =
+tableQueryField :: TableEntry -> Type.Field
+tableQueryField table =
let
fieldsWithOrderingTerm =
table.columns <&> \columnEntry -> do
@@ -149,62 +151,47 @@ tableQueryCommonArgs table =
<> "\"."
)
in
- [ Type.inputValue "filter" (filterType table)
- & Type.inputValueWithDescription "Filter to select specific rows"
- , Type.inputValue "order_by" (Type.list orderType)
- & Type.inputValueWithDescription "Columns used to sort the data"
- , Type.inputValue "limit" Type.typeInt
- & Type.inputValueWithDescription "Limit the number of returned rows"
- , Type.inputValue "offset" Type.typeInt
- & Type.inputValueWithDescription "The index to start returning rows from"
- ]
+ Type.field
+ (doubleXEncodeGql table.name)
+ (Type.nonNull $ Type.list $ Type.nonNull $ tableRowType table)
+ & Type.fieldWithDescription ("Rows from the table \"" <> table.name <> "\"")
+ & Type.withArguments
+ [ Type.inputValue "filter" (filterType table)
+ & Type.inputValueWithDescription "Filter to select specific rows"
+ , Type.inputValue "order_by" (Type.list orderType)
+ & Type.inputValueWithDescription "Columns used to sort the data"
+ , Type.inputValue "limit" Type.typeInt
+ & Type.inputValueWithDescription "Limit the number of returned rows"
+ , Type.inputValue "offset" Type.typeInt
+ & Type.inputValueWithDescription "The index to start returning rows from"
+ ]
-tableQueryField :: TableEntry -> Type.Field
-tableQueryField table =
- Type.field
- (doubleXEncodeGql table.name)
- (Type.nonNull $ Type.list $ Type.nonNull $ tableRowType table)
- & Type.fieldWithDescription ("Rows from the table \"" <> table.name <> "\"")
- & Type.withArguments (tableQueryCommonArgs table)
-
-
-restrictedArgNames :: [Text]
-restrictedArgNames = ["limit", "offset", "order_by", "filter"]
-
-
-mkArgName :: Text -> Text
-mkArgName name = do
- let encoded = doubleXEncodeGql name
- if P.elem encoded restrictedArgNames
- then encoded <> "_"
- else encoded
-
-
-tableQueryByPk :: TableEntry -> Type.Field
-tableQueryByPk table = do
+tableQueryByPKField :: TableEntry -> Maybe Type.Field
+tableQueryByPKField table = do
let pks = List.filter (\col -> col.primary_key) table.columns
-- We filter out the rowid column, unless it is the only one
- let withoutRowid = case pks of
- [first] | first.isRowid -> [first]
- _ -> List.filter (\col -> P.not col.isRowid) pks
+ withoutRowid <- case pks of
+ [] -> Nothing
+ [first] | first.isRowid -> Just [first]
+ _ -> Just $ List.filter (\col -> P.not col.isRowid) pks
let pkArguments =
withoutRowid <&> \column -> do
- let name = mkArgName column.column_name_gql
+ let name = doubleXEncodeGql column.column_name_gql
Type.inputValue name $ Type.nonNull $ columnType column
- Type.field
- (doubleXEncodeGql table.name <> "_by_pk")
- (tableRowType table)
- & Type.fieldWithDescription
- ( "Rows from the table \""
- <> table.name
- <> "\", accessible by their primary key"
- )
- & Type.withArguments (tableQueryCommonArgs table)
- & Type.withArguments pkArguments
+ pure $
+ Type.field
+ (doubleXEncodeGql table.name <> "_by_pk")
+ (tableRowType table)
+ & Type.fieldWithDescription
+ ( "Rows from the table \""
+ <> table.name
+ <> "\", accessible by their primary key"
+ )
+ & Type.withArguments pkArguments
mutationResponseType :: AccessMode -> TableEntry -> Type.IntrospectionType
@@ -363,7 +350,7 @@ getSchema accessMode tables = do
then
P.fold
[ tables <&> tableQueryField
- , tables <&> tableQueryByPk
+ , tables & P.mapMaybe tableQueryByPKField
]
else []
diff --git a/source/AirGQL/Introspection/Resolver.hs b/source/AirGQL/Introspection/Resolver.hs
index ff90ac5..571a703 100644
--- a/source/AirGQL/Introspection/Resolver.hs
+++ b/source/AirGQL/Introspection/Resolver.hs
@@ -1,4 +1,8 @@
-module AirGQL.Introspection.Resolver (makeType, makeConstField) where
+module AirGQL.Introspection.Resolver (
+ makeType,
+ makeConstField,
+ makeField,
+) where
import Protolude (
Either (Left),
@@ -7,7 +11,6 @@ import Protolude (
MonadReader (ask),
Text,
fromMaybe,
- mempty,
pure,
show,
($),
@@ -29,6 +32,12 @@ import Language.GraphQL.Type.Out qualified as Out
type Result = Either Text
+{-| Turns a type descriptor into a graphql output type, erroring out on input
+types. Child resolvers look up their respective fields in the value produced by
+their parent.
+
+Lookups for `__Type` objects are memoized, and a maximum depth of 30 is enforced.
+-}
makeType :: IType.IntrospectionType -> Result (Out.Type IO)
makeType =
let
@@ -91,8 +100,7 @@ makeType =
$ Out.NamedObjectType
$ Type.ObjectType
name
- -- ty.description
- P.Nothing
+ ty.description
[]
$ HashMap.fromList
$ ("__typename", typenameResolver) : resolvers
@@ -131,13 +139,29 @@ makeType =
makeTypeWithDepth 0
+{-| Turns a field descriptor into a graphql field. See the documentation
+for `makeType` for details about the behaviour of child resolvers.
+-}
+makeField :: IType.Field -> Result (Out.Field IO)
+makeField field = do
+ args <- P.for field.args $ \arg -> do
+ ty <- makeInType arg.type_
+ pure (arg.name, In.Argument arg.description ty arg.defaultValue)
+ ty <- makeType field.type_
+ pure $ Out.Field field.description ty $ HashMap.fromList args
+
+
+-- | Create a resolver by calling which always returns a constant value.
makeConstField :: IType.Field -> Type.Value -> Result (Out.Resolver IO)
makeConstField field value = do
- ty <- makeType field.type_
- let gqlField = Out.Field field.description ty mempty
+ gqlField <- makeField field
pure $ Out.ValueResolver gqlField $ pure value
+{-| The input-type version of `makeOutType`. No maximum depth is enforced, nor
+is any memoization used. This is the case because input types are usually pretty
+shallow.
+-}
makeInType :: IType.IntrospectionType -> Result In.Type
makeInType ty = do
case ty.kind of