diff --git a/source/AirGQL/GraphQL.hs b/source/AirGQL/GraphQL.hs
index f13696d..d678437 100644
--- a/source/AirGQL/GraphQL.hs
+++ b/source/AirGQL/GraphQL.hs
@@ -106,7 +106,7 @@ import AirGQL.Lib (
AccessMode (ReadAndWrite, ReadOnly, WriteOnly),
ColumnEntry (column_name, datatype, datatype_gql),
GqlTypeName (root),
- TableEntryRaw (name),
+ TableEntry (name),
column_name_gql,
getColumns,
)
@@ -433,7 +433,7 @@ queryType
:: Connection
-> AccessMode
-> Text
- -> [TableEntryRaw]
+ -> [TableEntry]
-> IO (Out.ObjectType IO)
queryType connection accessMode dbId tables = do
let
@@ -700,7 +700,7 @@ queryType connection accessMode dbId tables = do
getResolvers :: IO (HashMap.HashMap Text (Resolver IO))
getResolvers = do
let
- getTableTuple :: TableEntryRaw -> IO (Text, Resolver IO)
+ getTableTuple :: TableEntry -> IO (Text, Resolver IO)
getTableTuple table = do
outField <- getOutField table.name
pure
@@ -741,7 +741,7 @@ queryType connection accessMode dbId tables = do
-- getTableTuples <&> HashMap.fromList
resolvers <- getResolvers
- schemaResolver <- getSchemaResolver dbId connection accessMode tables
+ schemaResolver <- getSchemaResolver accessMode tables
-- resolversPrimaryKey <- getResolversPrimaryKey
let
@@ -1092,7 +1092,7 @@ mutationType
-> Integer
-> AccessMode
-> Text
- -> [TableEntryRaw]
+ -> [TableEntry]
-> IO (Maybe (Out.ObjectType IO))
mutationType connection maxRowsPerTable accessMode dbId tables = do
let
@@ -1229,7 +1229,6 @@ mutationType connection maxRowsPerTable accessMode dbId tables = do
columnEntries <- liftIO $ getColumns dbId connection tableName
context <- ask
-
let
columnNames :: [Text]
columnNames =
@@ -1602,7 +1601,7 @@ mutationType connection maxRowsPerTable accessMode dbId tables = do
getMutationResolvers :: IO (HashMap.HashMap Text (Resolver IO))
getMutationResolvers = do
let
- getInsertTableTuple :: TableEntryRaw -> IO (Text, Resolver IO)
+ getInsertTableTuple :: TableEntry -> IO (Text, Resolver IO)
getInsertTableTuple table = do
outFieldInsertion <- getOutField table.name
pure
@@ -1612,7 +1611,7 @@ mutationType connection maxRowsPerTable accessMode dbId tables = do
(executeDbInserts table.name)
)
- getUpdateTableTuple :: TableEntryRaw -> IO (Text, Resolver IO)
+ getUpdateTableTuple :: TableEntry -> IO (Text, Resolver IO)
getUpdateTableTuple table = do
outFieldUpdate <- getOutFieldUpdate table.name
pure
@@ -1622,7 +1621,7 @@ mutationType connection maxRowsPerTable accessMode dbId tables = do
(executeDbUpdates table.name)
)
- getDeleteTableTuple :: TableEntryRaw -> IO (Text, Resolver IO)
+ getDeleteTableTuple :: TableEntry -> IO (Text, Resolver IO)
getDeleteTableTuple table = do
outFieldDeletion <- getOutFieldDeletion table.name
pure
@@ -1654,7 +1653,7 @@ getDerivedSchema
:: SchemaConf
-> Connection
-> Text
- -> [TableEntryRaw]
+ -> [TableEntry]
-> IO (Schema IO)
getDerivedSchema schemaConf connection dbId tables = do
let sqlitePragmas = getSQLitePragmas schemaConf.pragmaConf
diff --git a/source/AirGQL/Introspection.hs b/source/AirGQL/Introspection.hs
index 54eb20c..280a275 100644
--- a/source/AirGQL/Introspection.hs
+++ b/source/AirGQL/Introspection.hs
@@ -1,2559 +1,360 @@
module AirGQL.Introspection (
- getSchemaResolver,
typeNameResolver,
- createType,
+ getSchemaResolver,
)
where
import Protolude (
Applicative (pure),
- Bool (False, True),
- Eq ((/=)),
- Foldable (null),
+ Either (Left, Right),
IO,
- Int,
- IsString,
Maybe (Just, Nothing),
- MonadReader (ask),
Monoid (mempty),
- Num ((+)),
- Ord ((<)),
Semigroup ((<>)),
Text,
- concat,
- filter,
- forM,
fromMaybe,
- not,
($),
(&),
(<&>),
- (>>=),
)
+import Protolude qualified as P
-import Data.HashMap.Strict as HashMap (
- HashMap,
- empty,
- fromList,
- lookup,
- singleton,
- )
-import Database.SQLite.Simple (Connection)
-import Language.GraphQL.Type (
- Value (Boolean, List, Null, Object, String),
- boolean,
- string,
- )
-import Language.GraphQL.Type.In as In (Type (NamedScalarType))
+import Data.HashMap.Strict as HashMap (HashMap, singleton)
import Language.GraphQL.Type.Out as Out (
- Context (values),
Field (Field),
Resolver (ValueResolver),
- Type (
- ListType,
- NamedObjectType,
- NamedScalarType,
- NonNullListType,
- NonNullObjectType,
- NonNullScalarType
- ),
+ Type (NonNullScalarType),
)
-import AirGQL.GQLWrapper (
- InArgument (InArgument, argDescMb, argType, valueMb),
- OutField (OutField, arguments, descriptionMb, fieldType),
- inArgumentToArgument,
- outFieldToField,
- )
+import AirGQL.Introspection.Resolver (makeType)
+import AirGQL.Introspection.Types (IntrospectionType)
+import AirGQL.Introspection.Types qualified as Type
import AirGQL.Lib (
- AccessMode (ReadAndWrite, ReadOnly, WriteOnly),
+ AccessMode,
ColumnEntry,
GqlTypeName (full),
- TableEntryRaw (name),
+ TableEntry (columns, name),
+ canRead,
+ canWrite,
column_name_gql,
datatype_gql,
- getColumns,
isOmittable,
notnull,
- select_options,
- )
-import AirGQL.Types.OutObjectType (
- OutObjectType (OutObjectType, descriptionMb, fields, interfaceTypes, name),
- outObjectTypeToObjectType,
)
+import Control.Monad (MonadFail (fail))
+import Data.Text qualified as T
import DoubleXEncoding (doubleXEncodeGql)
-
-
-emptyType :: Value
-emptyType =
- Object $ HashMap.singleton "kind" "OBJECT"
-
-
-intType :: Value
-intType =
- Object $
- HashMap.fromList
- [ ("__typename", "__Type")
- , ("kind", "SCALAR")
- , ("name", "Int")
- ,
- ( "description"
- , "The `Int` scalar type represents \
- \non-fractional signed whole numeric values. \
- \Int can represent values between -(2^31) and 2^31 - 1."
- )
- ]
-
-
-floatType :: Value
-floatType =
- Object $
- HashMap.fromList
- [ ("__typename", "__Type")
- , ("kind", "SCALAR")
- , ("name", "Float")
- ,
- ( "description"
- , "Signed double-precision floating-point value."
- )
- ]
-
-
-stringType :: Value
-stringType =
- Object $
- HashMap.fromList
- [ ("__typename", "__Type")
- , ("kind", "SCALAR")
- , ("name", "String")
- ,
- ( "description"
- , "The `String` scalar type represents textual data, \
- \represented as UTF-8 character sequences. \
- \The String type is most often used by GraphQL \
- \to represent free-form human-readable text."
- )
- ]
-
-
-booleanType :: Value
-booleanType =
- Object $
- HashMap.fromList
- [ ("__typename", "__Type")
- , ("kind", "SCALAR")
- , ("name", "Boolean")
- ,
- ( "description"
- , "The `Boolean` scalar type represents `true` or `false`."
- )
- ]
-
-
-nonNullString :: Out.Field IO
-nonNullString =
- outFieldToField $
- OutField
- { descriptionMb = Just "nonNullString description"
- , fieldType = Out.NonNullScalarType string
- , arguments = HashMap.empty
- }
-
-
-nullableString :: Out.Field IO
-nullableString =
- Out.Field
- (Just "nullableString")
- (Out.NamedScalarType string)
- HashMap.empty
-
-
-nonNullBoolean :: Out.Field IO
-nonNullBoolean =
- outFieldToField $
- OutField
- { descriptionMb = Just "nonNullBoolean description"
- , fieldType = Out.NonNullScalarType boolean
- , arguments = HashMap.empty
- }
-
-
-getTypeTuple :: (IsString a) => Value -> Value -> (a, Value)
-getTypeTuple theKind theType =
- ( "type"
- , Object $
- HashMap.fromList
- [ ("kind", theKind)
- , ("name", theType)
- ]
- )
-
-
-nonNullType :: Value -> Value
-nonNullType inner =
- Object $
- HashMap.fromList
- [ ("kind", "NON_NULL")
- , ("ofType", inner)
- ]
-
-
-listType :: Value -> Value
-listType inner =
- Object $
- HashMap.fromList
- [ ("kind", "LIST")
- , ("ofType", inner)
- ]
-
-
-createType :: Text -> Text -> [Value] -> [Text] -> Text -> Value
-createType rootName description args nestedTypes name =
- let
- createChildType :: [Text] -> Text -> Value
- createChildType nestedChildTypes childName =
- case nestedChildTypes of
- [] -> Null
- (childHeadKind : childRestKinds) ->
- if not $ null childRestKinds
- then
- Object $
- HashMap.fromList
- [ ("kind", String childHeadKind)
- , ("ofType", createChildType childRestKinds childName)
- ]
- else
- Object $
- HashMap.fromList
- [ ("kind", String childHeadKind)
- , ("name", String name)
- ]
- in
- case nestedTypes of
- [] -> Null
- kinds ->
- Object $
- HashMap.fromList
- ( [ ("name", String rootName)
- , ("description", String description)
- , ("type", createChildType kinds name)
- ]
- <> if null args then [] else [("args", List args)]
- )
-
-
-createField :: Text -> Maybe Text -> Value -> Value
-createField name descriptionMb type_ =
- Object $
- HashMap.fromList
- [ ("name", String name)
- , ("type", type_)
- ]
- <> case descriptionMb of
- Nothing -> mempty
- Just description ->
- HashMap.singleton
- "description"
- (String description)
-
-
-nameField :: Value
-nameField =
- Object $
- HashMap.fromList
- [ ("name", "name")
- ,
- ( "type"
- , nonNullType $
- Object $
- HashMap.fromList
- [ ("kind", "SCALAR")
- , ("name", "String")
- ]
- )
- ]
-
-
-descriptionField :: Value
-descriptionField =
- Object $
- HashMap.fromList
- [ ("name", "description")
- , getTypeTuple "SCALAR" "String"
- ]
-
-
-argsFieldValue :: Value
-argsFieldValue =
- Object $
- HashMap.fromList
- [ ("name", "args")
- ,
- ( "type"
- , nonNullType $
- listType $
- nonNullType $
- Object $
- HashMap.fromList
- [ ("kind", "OBJECT")
- , ("name", "__InputValue")
- ]
- )
- ]
-
-
-locationsFieldValue :: Value
-locationsFieldValue =
- Object $
- HashMap.fromList
- [ ("name", "locations")
- ,
- ( "type"
- , nonNullType $
- listType $
- nonNullType $
- Object $
- HashMap.fromList
- [ ("kind", "ENUM")
- , ("name", "__DirectiveLocation")
- ]
- )
- ]
-
-
-typeFieldValue :: Value
-typeFieldValue =
- Object $
- HashMap.fromList
- [ ("name", "type")
- ,
- ( "type"
- , nonNullType $
- Object $
- HashMap.fromList
- [ ("kind", "OBJECT")
- , ("name", "__Type")
- ]
- )
- ]
-
-
-isDeprecatedFieldValue :: Value
-isDeprecatedFieldValue =
- Object $
- HashMap.fromList
- [ ("name", "isDeprecated")
- ,
- ( "type"
- , nonNullType $
- Object $
- HashMap.fromList
- [ ("kind", "SCALAR")
- , ("name", "Boolean")
- ]
- )
- ]
-
-
-typeType :: Int -> Out.Type IO
-typeType level =
- Out.NamedObjectType $
- outObjectTypeToObjectType $
- OutObjectType
- { name = "__Type"
- , descriptionMb = Just "__Type description"
- , interfaceTypes = []
- , fields =
- HashMap.fromList $
- [
- ( "__typename"
- , ValueResolver nonNullString $ pure "__Type"
- )
- ,
- ( "kind"
- , ValueResolver nonNullString $ do
- context <- ask
- case context & Out.values of
- Object obj ->
- pure $
- fromMaybe "ERROR: kind" $
- HashMap.lookup "kind" obj
- _ -> pure "ERROR: kind"
- )
- ,
- ( "name"
- , ValueResolver nullableString $ do
- context <- ask
- case context & Out.values of
- Object obj ->
- pure $
- fromMaybe Null $
- HashMap.lookup "name" obj
- _ -> pure Null
- )
- ,
- ( "description"
- , ValueResolver nullableString $ do
- context <- ask
- case context & Out.values of
- Object obj ->
- pure $
- fromMaybe Null $
- HashMap.lookup "description" obj
- _ -> pure Null
- )
- ,
- ( "fields"
- , ValueResolver fieldsField $ do
- context <- ask
- case context & Out.values of
- Object obj ->
- pure $
- fromMaybe Null $
- HashMap.lookup "fields" obj
- _ -> pure Null
- )
- ,
- ( "possibleTypes"
- , ValueResolver typesField $ do
- context <- ask
- case context & Out.values of
- Object obj ->
- pure $
- fromMaybe Null $
- HashMap.lookup "possibleTypes" obj
- _ -> pure Null
- )
- ,
- ( "interfaces"
- , ValueResolver typesField $ do
- context <- ask
- case context & Out.values of
- Object obj ->
- pure $
- fromMaybe (List []) $
- HashMap.lookup "interfaces" obj
- _ -> pure $ List []
- )
- ,
- ( "inputFields"
- , ValueResolver inputsFieldsField $ do
- context <- ask
- case context & Out.values of
- Object obj ->
- pure $
- fromMaybe Null $
- HashMap.lookup "inputFields" obj
- _ -> pure Null
- )
- ,
- ( "enumValues"
- , ValueResolver enumValuesField $ do
- context <- ask
- case context & Out.values of
- Object obj ->
- pure $
- fromMaybe Null $
- HashMap.lookup "enumValues" obj
- _ -> pure Null
- )
- ]
- <> ( if level < 7
- then
- [
- ( "ofType"
- , ValueResolver (typeField $ level + 1) $ do
- context <- ask
- case context & Out.values of
- Object obj ->
- pure $
- fromMaybe Null $
- HashMap.lookup "ofType" obj
- _ -> pure Null
- )
- ]
- else []
- )
- }
-
-
-typeField :: Int -> Field IO
-typeField level =
- outFieldToField $
- OutField
- { descriptionMb = Just "typeField description"
- , fieldType = typeType level
- , arguments = HashMap.empty
- }
-
-
-typesField :: Field IO
-typesField =
- outFieldToField $
- OutField
- { descriptionMb = Just "typesField description"
- , fieldType = Out.ListType $ typeType 0
- , arguments = HashMap.empty
- }
-
-
-inputValueType :: Out.Type IO
-inputValueType =
- Out.NonNullObjectType $
- outObjectTypeToObjectType $
- OutObjectType
- { name = "__InputValue"
- , descriptionMb = Just "__InputValue description"
- , interfaceTypes = []
- , fields =
- HashMap.fromList
- [
- ( "__typename"
- , ValueResolver nonNullString $ pure "__InputValue"
- )
- ,
- ( "name"
- , ValueResolver nonNullString $ do
- context <- ask
- case context & Out.values of
- Object obj ->
- pure $
- fromMaybe "ERROR: name" $
- HashMap.lookup "name" obj
- _ -> pure "ERROR: name"
- )
- ,
- ( "description"
- , ValueResolver nullableString $ do
- context <- ask
- case context & Out.values of
- Object obj ->
- pure $
- fromMaybe Null $
- HashMap.lookup "description" obj
- _ -> pure Null
- )
- ,
- ( "defaultValue"
- , ValueResolver nullableString $ do
- context <- ask
- case context & Out.values of
- Object obj ->
- pure $
- fromMaybe Null $
- HashMap.lookup "defaultValue" obj
- _ -> pure Null
- )
- ,
- ( "type"
- , ValueResolver (typeField 0) $ do
- context <- ask
- case context & Out.values of
- Object obj ->
- pure $
- fromMaybe emptyType $
- HashMap.lookup "type" obj
- _ -> pure emptyType
- )
- ]
- }
-
-
-argsField :: Field IO
-argsField =
- outFieldToField $
- OutField
- { descriptionMb = Just "argsField description"
- , fieldType = Out.NonNullListType inputValueType
- , arguments = HashMap.empty
- }
-
-
-inputsFieldsField :: Field IO
-inputsFieldsField =
- outFieldToField $
- OutField
- { descriptionMb = Just "inputsFieldsField description"
- , fieldType = Out.ListType inputValueType
- , arguments = HashMap.empty
- }
-
-
-enumValuesType :: Out.Type IO
-enumValuesType =
- Out.ListType $
- Out.NonNullObjectType $
- outObjectTypeToObjectType $
- OutObjectType
- { name = "__EnumValue"
- , descriptionMb = Just "__EnumValue description"
- , interfaceTypes = []
- , fields =
- HashMap.fromList
- [
- ( "__typename"
- , ValueResolver nonNullString $ pure "__EnumValue"
- )
- ,
- ( "name"
- , ValueResolver nonNullString $ do
- context <- ask
- case context & Out.values of
- Object obj ->
- pure $
- fromMaybe "ERROR: name" $
- HashMap.lookup "name" obj
- _ -> pure "ERROR: name"
- )
- ,
- ( "description"
- , ValueResolver nullableString $ do
- context <- ask
- case context & Out.values of
- Object obj ->
- pure $
- fromMaybe Null $
- HashMap.lookup "description" obj
- _ -> pure Null
- )
- ,
- ( "isDeprecated"
- , ValueResolver nonNullBoolean $ do
- context <- ask
- case context & Out.values of
- Object obj ->
- pure $
- fromMaybe (Boolean False) $
- HashMap.lookup "isDeprecated" obj
- _ -> pure $ Boolean False
- )
- ,
- ( "deprecationReason"
- , ValueResolver nullableString $ do
- context <- ask
- case context & Out.values of
- Object obj ->
- pure $
- fromMaybe Null $
- HashMap.lookup "deprecationReason" obj
- _ -> pure Null
- )
- ]
- }
-
-
-enumValuesField :: Field IO
-enumValuesField =
- outFieldToField $
- OutField
- { descriptionMb = Just "enumValuesField description"
- , fieldType = enumValuesType
- , arguments =
- HashMap.fromList
- [
- ( "includeDeprecated"
- , inArgumentToArgument $
- InArgument
- { argDescMb = Just "includeDeprecated description"
- , argType = In.NamedScalarType boolean
- , valueMb = Just $ Boolean True
- }
- )
- ]
- }
-
-
-queryTypeType :: Field IO
-queryTypeType =
- outFieldToField $
- OutField
- { descriptionMb = Just "Provides the queryType"
- , fieldType = typeType 0
- , arguments = HashMap.empty
- }
-
-
-mutationTypeType :: Field IO
-mutationTypeType =
- outFieldToField $
- OutField
- { descriptionMb = Just "Provides the mutationType"
- , fieldType = typeType 0
- , arguments = HashMap.empty
- }
-
-
-subscriptionTypeType :: Field IO
-subscriptionTypeType =
- outFieldToField $
- OutField
- { descriptionMb = Just "Provides the subscriptionType"
- , fieldType = typeType 0
- , arguments = HashMap.empty
- }
-
-
-fieldsTypeOutput :: Out.Type IO
-fieldsTypeOutput =
- Out.ListType $
- Out.NonNullObjectType $
- outObjectTypeToObjectType $
- OutObjectType
- { name = "__Field"
- , descriptionMb = Just "__Field description"
- , interfaceTypes = []
- , fields =
- HashMap.fromList
- [
- ( "__typename"
- , ValueResolver nonNullString $ pure "__Field"
- )
- ,
- ( "name"
- , ValueResolver nonNullString $ do
- context <- ask
- case context & Out.values of
- Object obj ->
- pure $
- fromMaybe "ERROR: name" $
- HashMap.lookup "name" obj
- _ -> pure "ERROR: name"
- )
- ,
- ( "description"
- , ValueResolver nullableString $ do
- context <- ask
- case context & Out.values of
- Object obj ->
- pure $
- fromMaybe Null $
- HashMap.lookup "description" obj
- _ -> pure Null
- )
- ,
- ( "args"
- , ValueResolver argsField $ do
- context <- ask
- case context & Out.values of
- Object obj ->
- pure $
- fromMaybe (List []) $
- HashMap.lookup "args" obj
- _ -> pure $ List []
- )
- ,
- ( "type"
- , ValueResolver (typeField 0) $ do
- context <- ask
- case context & Out.values of
- Object obj ->
- pure $
- fromMaybe emptyType $
- HashMap.lookup "type" obj
- _ -> pure emptyType
- )
- ,
- ( "isDeprecated"
- , ValueResolver nonNullBoolean $ do
- context <- ask
- case context & Out.values of
- Object obj ->
- pure $
- fromMaybe (Boolean False) $
- HashMap.lookup "isDeprecated" obj
- _ -> pure $ Boolean False
- )
- ,
- ( "deprecationReason"
- , ValueResolver nullableString $ do
- context <- ask
- case context & Out.values of
- Object obj ->
- pure $
- fromMaybe Null $
- HashMap.lookup "deprecationReason" obj
- _ -> pure Null
- )
- ]
- }
-
-
-fieldsField :: Field IO
-fieldsField =
- outFieldToField $
- OutField
- { descriptionMb = Just "The fields type"
- , fieldType = fieldsTypeOutput
- , arguments =
- HashMap.fromList
- [
- ( "includeDeprecated"
- , inArgumentToArgument $
- InArgument
- { argDescMb = Just "includeDeprecated description"
- , argType = In.NamedScalarType boolean
- , valueMb = Just $ Boolean True
- }
- )
- ]
- }
-
-
-directivesType :: Field IO
-directivesType =
- let
- directivesTypeOutput :: Out.Type IO
- directivesTypeOutput =
- Out.ListType $
- Out.NonNullObjectType $
- outObjectTypeToObjectType $
- OutObjectType
- { name = "__Directive"
- , descriptionMb = Just "__Directive description"
- , interfaceTypes = []
- , fields =
- HashMap.fromList
- [
- ( "__typename"
- , ValueResolver nullableString $ pure "__Directive"
- )
- ,
- ( "name"
- , ValueResolver nonNullString $ do
- context <- ask
- case context & Out.values of
- Object obj ->
- pure $
- fromMaybe "ERROR: name" $
- HashMap.lookup "name" obj
- _ -> pure "ERROR: name"
- )
- ,
- ( "description"
- , ValueResolver nullableString $ do
- context <- ask
- case context & Out.values of
- Object obj ->
- pure $
- fromMaybe Null $
- HashMap.lookup "description" obj
- _ -> pure Null
- )
- ,
- ( "locations"
- , let
- locationsTypeName :: Field m
- locationsTypeName =
- Out.Field
- (Just "locationsTypeName name")
- (Out.ListType $ Out.NonNullScalarType string)
- HashMap.empty
- in
- ValueResolver locationsTypeName $ do
- context <- ask
- case context & Out.values of
- Object obj ->
- pure $
- fromMaybe (List []) $
- HashMap.lookup "locations" obj
- _ -> pure $ List []
- )
- ,
- ( "args"
- , ValueResolver argsField $ do
- context <- ask
- case context & Out.values of
- Object obj ->
- pure $
- fromMaybe (List []) $
- HashMap.lookup "args" obj
- _ -> pure $ List []
- )
- ]
- }
- in
- outFieldToField $
- OutField
- { descriptionMb = Just "Provides the directivesType"
- , fieldType = directivesTypeOutput
- , arguments = HashMap.empty
- }
-
-
-filterType :: Bool -> Text -> Value
-filterType isRequired tableName =
- let
- filterObj =
- Object $
- HashMap.fromList
- [ ("kind", "INPUT_OBJECT")
- , ("name", String $ doubleXEncodeGql tableName <> "_filter")
- ,
- ( "description"
- , "Select rows matching the provided filter object"
- )
- ]
- in
- if isRequired
- then nonNullType filterObj
- else filterObj
-
-
-getFieldsForQuery :: Text -> Value
-getFieldsForQuery tableName =
- createType
- (doubleXEncodeGql tableName)
- ("Rows from the table \"" <> tableName <> "\"")
- [ Object $
- HashMap.fromList
- [ ("name", "filter")
- , ("description", "Filter to select specific rows")
- , ("type", filterType False tableName)
- ]
- , Object $
- HashMap.fromList
- [ ("name", "order_by")
- , ("description", "Columns used to sort the data")
- ,
- ( "type"
- , listType $
- Object $
- HashMap.fromList
- [ ("kind", "INPUT_OBJECT")
- ,
- ( "name"
- , String $
- doubleXEncodeGql tableName
- <> "_order_by"
- )
- ]
- )
- ]
- , Object $
- HashMap.fromList
- [ ("name", "limit")
- , ("description", "Limit the number of returned rows")
- , ("type", intType)
- ]
- , Object $
- HashMap.fromList
- [ ("name", "offset")
- , ("description", "The index to start returning rows from")
- , ("type", intType)
- ]
- ]
- ["NON_NULL", "LIST", "NON_NULL", "OBJECT"]
- (doubleXEncodeGql tableName <> "_row")
-
-
-getFieldsForMutation :: Text -> [Value]
-getFieldsForMutation tableName =
- [ Object $
- HashMap.fromList
- [ ("name", String $ "insert_" <> doubleXEncodeGql tableName)
- ,
- ( "description"
- , String $
- "Insert new rows in table \"" <> tableName <> "\""
- )
- ,
- ( "args"
- , List
- [ createField
- "objects"
- (Just "Rows to be inserted")
- $ nonNullType
- $ listType
- $ nonNullType
- $ Object
- $ HashMap.fromList
- [ ("kind", "INPUT_OBJECT")
- ,
- ( "name"
- , String $
- doubleXEncodeGql
- tableName
- <> "_insert_input"
- )
- ]
- , createField
- "on_conflict"
- (Just "Specifies how to handle broken UNIQUE constraints")
- $ listType
- $ nonNullType
- $ Object
- $ HashMap.fromList
- [ ("kind", "INPUT_OBJECT")
- ,
- ( "name"
- , String $
- doubleXEncodeGql
- tableName
- <> "_upsert_on_conflict"
- )
- ]
- ]
- )
- ,
- ( "type"
- , nonNullType $
- Object $
- HashMap.fromList
- [ ("kind", "OBJECT")
- ,
- ( "name"
- , String $
- doubleXEncodeGql tableName
- <> "_mutation_response"
- )
- ]
- )
- ]
- , Object $
- HashMap.fromList
- [ ("name", String $ "update_" <> doubleXEncodeGql tableName)
- ,
- ( "description"
- , String $
- "Update rows in table \"" <> tableName <> "\""
- )
- ,
- ( "args"
- , List
- [ Object $
- HashMap.fromList
- [ ("name", "filter")
- , ("description", "Filter to select rows to be updated")
- , ("type", filterType True tableName)
- ]
- , Object $
- HashMap.fromList
- [ ("name", "set")
- , ("description", "Fields to be updated")
- ,
- ( "type"
- , nonNullType $
- Object $
- HashMap.fromList
- [ ("kind", "INPUT_OBJECT")
- ,
- ( "name"
- , String $
- doubleXEncodeGql tableName
- <> "_set_input"
- )
- ]
- )
- ]
- ]
- )
- ,
- ( "type"
- , nonNullType $
- Object $
- HashMap.fromList
- [ ("kind", "OBJECT")
- ,
- ( "name"
- , String $
- doubleXEncodeGql tableName
- <> "_mutation_response"
- )
- ]
- )
- ]
- , Object $
- HashMap.fromList
- [ ("name", String $ "delete_" <> doubleXEncodeGql tableName)
- ,
- ( "description"
- , String $ "Delete rows in table \"" <> tableName <> "\""
- )
- ,
- ( "args"
- , List
- [ Object $
- HashMap.fromList
- [ ("name", "filter")
- , ("description", "Filter to select rows to be deleted")
- , ("type", filterType True tableName)
- ]
- ]
- )
- ,
- ( "type"
- , nonNullType $
- Object $
- HashMap.fromList
- [ ("kind", "OBJECT")
- ,
- ( "name"
- , String $
- doubleXEncodeGql tableName
- <> "_mutation_response"
- )
- ]
- )
- ]
- ]
-
-
-makeComparisonType :: Text -> Text -> Value -> Value
-makeComparisonType typeName description type_ =
- let field fieldName = createField fieldName Nothing type_
- in Object $
- HashMap.fromList
- [ ("__typename", "__Type")
- , ("kind", "INPUT_OBJECT")
- , ("name", String typeName)
- ,
- ( "description"
- , String description
- )
- ,
- ( "inputFields"
- , List
- [ field "eq"
- , field "neq"
- , field "gt"
- , field "gte"
- , field "lt"
- , field "lte"
- , field "like"
- , field "ilike"
- , createField
- "in"
- Nothing
- (listType type_)
- , createField
- "nin"
- Nothing
- (listType type_)
- ]
- )
- ]
-
-
-comparisonTypes :: AccessMode -> [Value]
-comparisonTypes accessMode =
- case accessMode of
- ReadOnly -> []
- _ ->
- [ makeComparisonType "IntComparison" "Compare to an Int" intType
- , makeComparisonType "FloatComparison" "Compare to a Float" floatType
- , makeComparisonType "StringComparison" "Compare to a String" stringType
- , makeComparisonType "BooleanComparison" "Compare to a Boolean" booleanType
- ]
-
-
-orderingTermType :: Value
-orderingTermType =
- Object $
- HashMap.fromList
- [ ("__typename", "__Type")
- , ("kind", "ENUM")
- , ("name", String "OrderingTerm")
- ,
- ( "description"
- , String "Ordering options when ordering by a column"
- )
- ,
- ( "enumValues"
- , List
- [ Object $
- HashMap.fromList
- [ ("name", "ASC")
- , ("description", "In ascending order")
- ]
- , Object $
- HashMap.fromList
- [ ("name", "asc")
- , ("description", "In ascending order")
- , ("isDeprecated", Boolean True)
- ,
- ( "deprecationReason"
- , String "GraphQL spec recommends all caps for enums"
- )
- ]
- , Object $
- HashMap.fromList
- [ ("name", "DESC")
- , ("description", "In descending order")
- ]
- , Object $
- HashMap.fromList
- [ ("name", "desc")
- , ("description", "In descending order")
- , ("isDeprecated", Boolean True)
- ,
- ( "deprecationReason"
- , String "GraphQL spec recommends all caps for enums"
- )
- ]
- ]
- )
- ]
-
-
-getFullDatatype :: ColumnEntry -> Text
-getFullDatatype entry = case entry.datatype_gql of
- -- TODO: Should be "Any", but that's not a valid GraphQL type
- Nothing -> "String"
- Just type_ -> type_.full
-
-
-getSchemaFieldOutput
- :: Text
- -> Connection
- -> AccessMode
- -> [TableEntryRaw]
- -> IO (Out.Type IO)
-getSchemaFieldOutput dbId conn accessMode tables = do
- typesForTables <- forM tables $ \table -> do
- columns <- getColumns dbId conn table.name
- fieldsIn <- forM columns $ \columnEntry -> do
- let colName = columnEntry.column_name_gql
- pure $
- createType
- colName
- "" -- TODO: Reactivate description when user can specify it
- [] -- No arguments
- ( if columnEntry.isOmittable
- then ["SCALAR"]
- else ["NON_NULL", "SCALAR"]
- )
- (getFullDatatype columnEntry)
-
- fieldsOut <- forM columns $ \columnEntry -> do
- let colName = columnEntry.column_name_gql
- pure $
- createType
- colName
- "" -- TODO: Reactivate description when user can specify it
- [] -- No arguments
- ( if columnEntry.notnull
- then ["NON_NULL", "SCALAR"]
- else ["SCALAR"]
- )
- (getFullDatatype columnEntry)
-
- fieldsNullable <- forM columns $ \columnEntry -> do
- let colName = columnEntry.column_name_gql
- pure $
- createType
- colName
- "" -- TODO: Reactivate description when user can specify it
- [] -- No arguments
- ["SCALAR"]
- (getFullDatatype columnEntry)
-
- fieldsWithComparisonExp <- forM columns $ \columnEntry -> do
- let colName = columnEntry.column_name_gql
- pure $
- createType
- colName
- "" -- TODO: Reactivate description when user can specify it
- [] -- No arguments
- ["INPUT_OBJECT"]
- (getFullDatatype columnEntry <> "Comparison")
-
- fieldsWithOrderingTerm <- forM columns $ \columnEntry -> do
- let colName = columnEntry.column_name_gql
- pure $
- createType
- colName
- "" -- TODO: Reactivate description when user can specify it
- [] -- No arguments
- ["INPUT_OBJECT"]
- "OrderingTerm"
-
- let
- customRowTypes =
- columns
- >>= \columnEntry ->
- case (columnEntry.select_options, columnEntry.datatype_gql) of
- (Just _, Just name) ->
- let
- colName = columnEntry.column_name_gql
- typeName = name.full
- description = "Data type for column " <> colName
- rowType =
- Object $
- HashMap.fromList
- [ ("__typename", "__Type")
- , ("kind", "SCALAR")
- , ("name", String typeName)
- , ("description", String description)
- ]
-
- comparisonType =
- makeComparisonType
- (typeName <> "Comparison")
- ("Compare with values for column" <> colName)
- ( Object $
- HashMap.fromList
- [ ("kind", "SCALAR")
- , ("name", String typeName)
- , ("description", String description)
- ]
- )
- in
- [rowType, comparisonType]
- _ -> []
-
- fieldEnumVariants =
- columns
- <&> \columnEntry ->
- Object $
- HashMap.singleton "name" $
- String $
- column_name_gql columnEntry
-
- fieldEnumDescription =
- "This enum contains a variant for each column in the table" :: Value
-
- fieldEnumType =
- Object $
- HashMap.fromList
- [ ("__typename", "__Type")
- , ("kind", "ENUM")
- , ("name", String $ doubleXEncodeGql table.name <> "_column")
- ,
- ( "description"
- , fieldEnumDescription
- )
- , ("enumValues", List fieldEnumVariants)
- ]
-
- fieldEnumTypeReference =
- Object $
- HashMap.fromList
- [ ("kind", "INPUT_OBJECT")
- , ("name", String $ doubleXEncodeGql table.name <> "_column")
- ,
- ( "description"
- , fieldEnumDescription
- )
- ]
-
- requiresWrite obj = case accessMode of
- ReadOnly -> Null
- WriteOnly -> obj
- ReadAndWrite -> obj
- requiresRead obj = case accessMode of
- ReadOnly -> Null
- WriteOnly -> obj
- ReadAndWrite -> obj
-
- pure $
- customRowTypes
- <> [ Object $
- HashMap.fromList
- [ ("__typename", "__Type")
- , ("kind", "OBJECT")
- , ("name", String $ doubleXEncodeGql table.name <> "_row")
- ,
- ( "description"
- , String $
- "Available columns for table \""
- <> table.name
- <> "\""
- )
- , ("fields", List fieldsOut)
- ]
- , requiresWrite $
- Object $
- HashMap.fromList
- [ ("__typename", "__Type")
- , ("kind", "OBJECT")
- ,
- ( "name"
- , String $
- doubleXEncodeGql table.name <> "_mutation_response"
- )
- ,
- ( "description"
- , String $ "Mutation response for " <> table.name
- )
- ,
- ( "fields"
- , List
- [ Object $
- HashMap.fromList
- [ ("name", "affected_rows")
- ,
- ( "type"
- , Object $
- HashMap.fromList
- [ ("kind", "NON_NULL")
- ,
- ( "ofType"
- , Object $
- HashMap.fromList
- [ ("kind", "SCALAR")
- , ("name", "Int")
- ]
- )
- ]
- )
- ]
- , requiresRead $
- Object $
- HashMap.fromList
- [ ("name", "returning")
- ,
- ( "type"
- , Object $
- HashMap.fromList
- [ ("kind", "NON_NULL")
- ,
- ( "ofType"
- , Object $
- HashMap.fromList
- [ ("kind", "LIST")
- ,
- ( "ofType"
- , Object $
- HashMap.fromList
- [ ("kind", "NON_NULL")
- ,
- ( "ofType"
- , Object $
- HashMap.fromList
- [ ("kind", "OBJECT")
- ,
- ( "name"
- , String $ doubleXEncodeGql table.name <> "_row"
- )
- ]
- )
- ]
- )
- ]
- )
- ]
- )
- ]
- ]
- )
- ]
- , requiresWrite $
- Object $
- HashMap.fromList
- [ ("__typename", "__Type")
- , ("kind", "INPUT_OBJECT")
- ,
- ( "name"
- , String $ doubleXEncodeGql table.name <> "_insert_input"
- )
- ,
- ( "description"
- , String $ "Input object for " <> table.name
- )
- , ("inputFields", List fieldsIn)
- ]
- , fieldEnumType
- , requiresWrite $
- Object $
- HashMap.fromList
- [ ("__typename", "__Type")
- , ("kind", "INPUT_OBJECT")
- ,
- ( "name"
- , String $ doubleXEncodeGql table.name <> "_upsert_on_conflict"
- )
- ,
- ( "description"
- , String $ "Specifies how broken UNIQUE constraints for " <> table.name <> " should be handled"
- )
- ,
- ( "inputFields"
- , List
- [ createField
- "constraint"
- (Just "columns to handle conflicts of")
- $ nonNullType
- $ listType
- $ nonNullType fieldEnumTypeReference
- , createField
- "update_columns"
- (Just "columns to override on conflict")
- $ nonNullType
- $ listType
- $ nonNullType fieldEnumTypeReference
- , createField
- "where"
- (Just "filter specifying which conflicting columns to update")
- (filterType False table.name)
- ]
- )
- ]
- , requiresWrite $
- Object $
- HashMap.fromList
- [ ("__typename", "__Type")
- , ("kind", "INPUT_OBJECT")
- ,
- ( "name"
- , String $ doubleXEncodeGql table.name <> "_set_input"
- )
- ,
- ( "description"
- , String $ "Fields to set for " <> table.name
- )
- , ("inputFields", List fieldsNullable)
- ]
- , requiresWrite $
- Object $
- HashMap.fromList
- [ ("__typename", "__Type")
- , ("kind", "INPUT_OBJECT")
- ,
- ( "name"
- , String $ doubleXEncodeGql table.name <> "_filter"
- )
- ,
- ( "description"
- , String "Filter object to select rows"
- )
- , ("inputFields", List fieldsWithComparisonExp)
- ]
- , requiresWrite $
- Object $
- HashMap.fromList
- [ ("__typename", "__Type")
- , ("kind", "INPUT_OBJECT")
- ,
- ( "name"
- , String $ doubleXEncodeGql table.name <> "_order_by"
- )
- ,
- ( "description"
- , String $
- "Ordering options when selecting data from \""
- <> table.name
- <> "\"."
- )
- , ("inputFields", List fieldsWithOrderingTerm)
- ]
- ]
-
- let
- queryTypeObj =
- Object $
- HashMap.fromList
- [ ("__typename", "__Type")
- , ("kind", "OBJECT")
- , ("name", "Query")
- ,
- ( "fields"
- , List $
- tables
- <&> AirGQL.Lib.name
- <&> getFieldsForQuery
- )
- ]
- mutationTypeObj =
- Object $
- HashMap.fromList
- [ ("__typename", "__Type")
- , ("kind", "OBJECT")
- , ("name", "Mutation")
- ,
- ( "fields"
- , List $
- tables
- <&> AirGQL.Lib.name
- <&> getFieldsForMutation
- & concat
- )
- ]
-
- pure $
- Out.NonNullObjectType $
- outObjectTypeToObjectType $
- OutObjectType
- { name = "__Schema"
- , descriptionMb = Just "__Schema description"
- , interfaceTypes = []
- , fields =
- HashMap.fromList
- [
- ( "__typename"
- , ValueResolver nonNullString $ pure "__Schema"
- )
- ,
- ( "queryType"
- , ValueResolver queryTypeType $ pure queryTypeObj
- )
- ,
- ( "mutationType"
- , case accessMode of
- ReadOnly -> ValueResolver mutationTypeType $ pure Null
- WriteOnly ->
- ValueResolver mutationTypeType $ pure mutationTypeObj
- ReadAndWrite ->
- ValueResolver mutationTypeType $ pure mutationTypeObj
- )
- ,
- ( "subscriptionType"
- , -- AirGQL doesn't support Subscriptions yet
- ValueResolver subscriptionTypeType $ pure Null
- )
- ,
- ( "types"
- , ValueResolver typesField $
- pure $
- List $
- concat typesForTables
- <> comparisonTypes accessMode
- <> [orderingTermType]
- <> [ queryTypeObj
- , case accessMode of
- ReadOnly -> Null
- WriteOnly -> mutationTypeObj
- ReadAndWrite -> mutationTypeObj
- , booleanType
- , intType
- , floatType
- , stringType
- , Object $
- HashMap.fromList
- [ ("__typename", "__Type")
- , ("kind", "SCALAR")
- , ("name", "ID")
- ,
- ( "description"
- , "The `ID` scalar type represents a unique identifier, \
- \often used to refetch an object or as key for a cache. \
- \The ID type appears in a JSON response as a String; \
- \however, it is not intended to be human-readable. \
- \When expected as an input type, any string \
- \(such as `\"4\"`) or integer (such as `4`) input value \
- \will be accepted as an ID."
- )
- ]
- , Object $
- HashMap.fromList
- [ ("__typename", "__Type")
- , ("kind", "SCALAR")
- , ("name", "Upload")
- ,
- ( "description"
- , "The `Upload` scalar type represents a file upload."
- )
- ]
- , Object $
- HashMap.fromList
- [ ("__typename", "__Type")
- , ("kind", "OBJECT")
- , ("name", "__Schema")
- ,
- ( "description"
- , "A GraphQL Schema defines the capabilities of a GraphQL server. \
- \It exposes all available types and directives on the server, \
- \as well as the entry points for \
- \query, mutation, and subscription operations."
- )
- ,
- ( "fields"
- , List
- [ Object $
- HashMap.fromList
- [ ("name", "types")
- ,
- ( "description"
- , "A list of all types supported by this server."
- )
- ,
- ( "type"
- , Object $
- HashMap.fromList
- [ ("kind", "NON_NULL")
- ,
- ( "ofType"
- , Object $
- HashMap.fromList
- [ ("kind", "LIST")
- ,
- ( "ofType"
- , Object $
- HashMap.fromList
- [ ("kind", "NON_NULL")
- ,
- ( "ofType"
- , Object $
- HashMap.fromList
- [ ("kind", "OBJECT")
- , ("name", "__Type")
- ]
- )
- ]
- )
- ]
- )
- ]
- )
- ]
- , Object $
- HashMap.fromList
- [ ("name", "queryType")
- ,
- ( "description"
- , "The type that query operations will be rooted at."
- )
- ,
- ( "type"
- , Object $
- HashMap.fromList
- [ ("kind", "NON_NULL")
- ,
- ( "ofType"
- , Object $
- HashMap.fromList
- [ ("kind", "OBJECT")
- , ("name", "__Type")
- ]
- )
- ]
- )
- ]
- , Object $
- HashMap.fromList
- [ ("name", "mutationType")
- ,
- ( "description"
- , "If this server supports mutation, the type \
- \that mutation operations will be rooted at."
- )
- , getTypeTuple "OBJECT" "__Type"
- ]
- , Object $
- HashMap.fromList
- [ ("name", "subscriptionType")
- ,
- ( "description"
- , "If this server support subscription, the type \
- \that subscription operations will be rooted at."
- )
- , getTypeTuple "OBJECT" "__Type"
- ]
- , Object $
- HashMap.fromList
- [ ("name", "directives")
- ,
- ( "description"
- , "A list of all directives supported by this server."
- )
- ,
- ( "type"
- , Object $
- HashMap.fromList
- [ ("kind", "NON_NULL")
- ,
- ( "ofType"
- , Object $
- HashMap.fromList
- [ ("kind", "LIST")
- ,
- ( "ofType"
- , Object $
- HashMap.fromList
- [ ("kind", "NON_NULL")
- ,
- ( "ofType"
- , Object $
- HashMap.fromList
- [ ("kind", "OBJECT")
- , ("name", "__Directive")
- ]
- )
- ]
- )
- ]
- )
- ]
- )
- ]
- ]
- )
- ]
- , Object $
- HashMap.fromList
- [ ("__typename", "__Type")
- , ("kind", "OBJECT")
- , ("name", "__Type")
- ,
- ( "description"
- , "The fundamental unit of any GraphQL Schema is the type. \
- \There are many kinds of types in GraphQL as represented by the `__TypeKind` enum.\n\n\
- \Depending on the kind of a type, certain fields describe information about that type. \
- \Scalar types provide no information beyond a name and description, while Enum types provide their values. \
- \Object and Interface types provide the fields they describe. \
- \Abstract types, Union and Interface, provide the Object types possible at runtime. \
- \List and NonNull types compose other types."
- )
- ,
- ( "fields"
- , List
- [ Object $
- HashMap.fromList
- [ ("name", "kind")
- ,
- ( "type"
- , Object $
- HashMap.fromList
- [ ("kind", "NON_NULL")
- ,
- ( "ofType"
- , Object $
- HashMap.fromList
- [ ("kind", "ENUM")
- , ("name", "__TypeKind")
- ]
- )
- ]
- )
- ]
- , Object $
- HashMap.fromList
- [ ("name", "name")
- , -- Don't know why not "NON_NULL"
- getTypeTuple "SCALAR" "String"
- ]
- , descriptionField
- , Object $
- HashMap.fromList
- [ ("name", "fields")
- ,
- ( "type"
- , Object $
- HashMap.fromList
- [ ("kind", "LIST")
- ,
- ( "ofType"
- , Object $
- HashMap.fromList
- [ ("kind", "NON_NULL")
- ,
- ( "ofType"
- , Object $
- HashMap.fromList
- [ ("kind", "OBJECT")
- , ("name", "__Field")
- ]
- )
- ]
- )
- ]
- )
- ,
- ( "args"
- , List
- [ Object $
- HashMap.fromList
- [ ("name", "includeDeprecated")
- , getTypeTuple "SCALAR" "Boolean"
- , -- Don't know why this has to be a string
- ("defaultValue", "false")
- ]
- ]
- )
- ]
- , Object $
- HashMap.fromList
- [ ("name", "interfaces")
- ,
- ( "type"
- , Object $
- HashMap.fromList
- [ ("kind", "LIST")
- ,
- ( "ofType"
- , Object $
- HashMap.fromList
- [ ("kind", "NON_NULL")
- ,
- ( "ofType"
- , Object $
- HashMap.fromList
- [ ("kind", "OBJECT")
- , ("name", "__Type")
- ]
- )
- ]
- )
- ]
- )
- ]
- , Object $
- HashMap.fromList
- [ ("name", "possibleTypes")
- ,
- ( "type"
- , Object $
- HashMap.fromList
- [ ("kind", "LIST")
- ,
- ( "ofType"
- , Object $
- HashMap.fromList
- [ ("kind", "NON_NULL")
- ,
- ( "ofType"
- , Object $
- HashMap.fromList
- [ ("kind", "OBJECT")
- , ("name", "__Type")
- ]
- )
- ]
- )
- ]
- )
- ]
- , Object $
- HashMap.fromList
- [ ("name", "enumValues")
- ,
- ( "type"
- , Object $
- HashMap.fromList
- [ ("kind", "LIST")
- ,
- ( "ofType"
- , Object $
- HashMap.fromList
- [ ("kind", "NON_NULL")
- ,
- ( "ofType"
- , Object $
- HashMap.fromList
- [ ("kind", "OBJECT")
- , ("name", "__EnumValue")
- ]
- )
- ]
- )
- ]
- )
- ,
- ( "args"
- , List
- [ Object $
- HashMap.fromList
- [ ("name", "includeDeprecated")
- , getTypeTuple "SCALAR" "Boolean"
- , -- Don't know why this has to be a string
- ("defaultValue", "false")
- ]
- ]
- )
- ]
- , Object $
- HashMap.fromList
- [ ("name", "inputFields")
- ,
- ( "type"
- , Object $
- HashMap.fromList
- [ ("kind", "LIST")
- ,
- ( "ofType"
- , Object $
- HashMap.fromList
- [ ("kind", "NON_NULL")
- ,
- ( "ofType"
- , Object $
- HashMap.fromList
- [ ("kind", "OBJECT")
- , ("name", "__InputValue")
- ]
- )
- ]
- )
- ]
- )
- ]
- , Object $
- HashMap.fromList
- [ ("name", "ofType")
- , getTypeTuple "OBJECT" "__Type"
- ]
- ]
- )
- ]
- , Object $
- HashMap.fromList
- [ ("__typename", "__Type")
- , ("kind", "ENUM")
- , ("name", "__TypeKind")
- ,
- ( "description"
- , "An enum describing what kind of type a given `__Type` is."
- )
- ,
- ( "enumValues"
- , List
- [ Object $
- HashMap.fromList
- [ ("name", "SCALAR")
- ,
- ( "description"
- , "Indicates this type is a scalar."
- )
- , ("isDeprecated", Boolean False)
- , ("deprecationReason", Null)
- ]
- , Object $
- HashMap.fromList
- [ ("name", "OBJECT")
- ,
- ( "description"
- , "Indicates this type is an object. `fields` and `interfaces` are valid fields."
- )
- , ("isDeprecated", Boolean False)
- , ("deprecationReason", Null)
- ]
- , Object $
- HashMap.fromList
- [ ("name", "INTERFACE")
- ,
- ( "description"
- , "Indicates this type is an interface. `fields` and `possibleTypes` are valid fields."
- )
- , ("isDeprecated", Boolean False)
- , ("deprecationReason", Null)
- ]
- , Object $
- HashMap.fromList
- [ ("name", "UNION")
- ,
- ( "description"
- , "Indicates this type is a union. `possibleTypes` is a valid field."
- )
- , ("isDeprecated", Boolean False)
- , ("deprecationReason", Null)
- ]
- , Object $
- HashMap.fromList
- [ ("name", "ENUM")
- ,
- ( "description"
- , "Indicates this type is an enum. `enumValues` is a valid field."
- )
- , ("isDeprecated", Boolean False)
- , ("deprecationReason", Null)
- ]
- , Object $
- HashMap.fromList
- [ ("name", "INPUT_OBJECT")
- ,
- ( "description"
- , "Indicates this type is an input object. `inputFields` is a valid field."
- )
- , ("isDeprecated", Boolean False)
- , ("deprecationReason", Null)
- ]
- , Object $
- HashMap.fromList
- [ ("name", "LIST")
- ,
- ( "description"
- , "Indicates this type is a list. `ofType` is a valid field."
- )
- , ("isDeprecated", Boolean False)
- , ("deprecationReason", Null)
- ]
- , Object $
- HashMap.fromList
- [ ("name", "NON_NULL")
- ,
- ( "description"
- , "Indicates this type is a non-null. `ofType` is a valid field."
- )
- , ("isDeprecated", Boolean False)
- , ("deprecationReason", Null)
- ]
- ]
- )
- ]
- , Object $
- HashMap.fromList
- [ ("__typename", "__Type")
- , ("kind", "OBJECT")
- , ("name", "__Field")
- ,
- ( "description"
- , "Object and Interface types are described by a list of Fields, each of which has a name, potentially a list of arguments, and a return type."
- )
- ,
- ( "fields"
- , List
- [ nameField
- , descriptionField
- , argsFieldValue
- , typeFieldValue
- , isDeprecatedFieldValue
- , Object $
- HashMap.fromList
- [ ("name", "deprecationReason")
- , getTypeTuple "SCALAR" "String"
- ]
- ]
- )
- ]
- , Object $
- HashMap.fromList
- [ ("__typename", "__Type")
- , ("kind", "OBJECT")
- , ("name", "__InputValue")
- ,
- ( "description"
- , "Arguments provided to Fields or Directives and the input fields of an InputObject are represented as Input Values which describe their type and optionally a default value."
- )
- ,
- ( "fields"
- , List
- [ nameField
- , descriptionField
- , typeFieldValue
- , Object $
- HashMap.fromList
- [ ("name", "defaultValue")
- ,
- ( "description"
- , "A GraphQL-formatted string representing \
- \the default value for this input value."
- )
- , getTypeTuple "SCALAR" "String"
- ]
- ]
- )
- ]
- , Object $
- HashMap.fromList
- [ ("__typename", "__Type")
- , ("kind", "OBJECT")
- , ("name", "__EnumValue")
- ,
- ( "description"
- , "One possible value for a given Enum. Enum values are unique values, not a placeholder for a string or numeric value. However an Enum value is returned in a JSON response as a string."
- )
- ,
- ( "fields"
- , List
- [ nameField
- , descriptionField
- , isDeprecatedFieldValue
- , Object $
- HashMap.fromList
- [ ("name", "deprecationReason")
- , getTypeTuple "SCALAR" "String"
- ]
- ]
- )
- ]
- , Object $
- HashMap.fromList
- [ ("__typename", "__Type")
- , ("kind", "OBJECT")
- , ("name", "__Directive")
- ,
- ( "description"
- , "A Directive provides a way to describe alternate runtime execution and type validation behavior in a GraphQL document.\n\nIn some cases, you need to provide options to alter GraphQL's execution behavior in ways field arguments will not suffice, such as conditionally including or skipping a field. Directives provide this by describing additional information to the executor."
- )
- ,
- ( "fields"
- , List
- [ nameField
- , descriptionField
- , locationsFieldValue
- , argsFieldValue
- ]
- )
- ]
- , Object $
- HashMap.fromList
- [ ("__typename", "__Type")
- , ("kind", "ENUM")
- , ("name", "__DirectiveLocation")
- ,
- ( "description"
- , "A Directive can be adjacent to many parts of the GraphQL language, a __DirectiveLocation describes one such possible adjacencies."
- )
- ,
- ( "enumValues"
- , List
- [ Object $
- HashMap.fromList
- [ ("name", "QUERY")
- ,
- ( "description"
- , "Location adjacent to a query operation."
- )
- , ("isDeprecated", Boolean False)
- , ("deprecationReason", Null)
- ]
- , Object $
- HashMap.fromList
- [ ("name", "MUTATION")
- ,
- ( "description"
- , "Location adjacent to a mutation operation."
- )
- , ("isDeprecated", Boolean False)
- , ("deprecationReason", Null)
- ]
- , Object $
- HashMap.fromList
- [ ("name", "SUBSCRIPTION")
- ,
- ( "description"
- , "Location adjacent to a subscription operation."
- )
- , ("isDeprecated", Boolean False)
- , ("deprecationReason", Null)
- ]
- , Object $
- HashMap.fromList
- [ ("name", "FIELD")
- ,
- ( "description"
- , "Location adjacent to a field."
- )
- , ("isDeprecated", Boolean False)
- , ("deprecationReason", Null)
- ]
- , Object $
- HashMap.fromList
- [ ("name", "FRAGMENT_DEFINITION")
- ,
- ( "description"
- , "Location adjacent to a fragment definition."
- )
- , ("isDeprecated", Boolean False)
- , ("deprecationReason", Null)
- ]
- , Object $
- HashMap.fromList
- [ ("name", "FRAGMENT_SPREAD")
- ,
- ( "description"
- , "Location adjacent to a fragment spread."
- )
- , ("isDeprecated", Boolean False)
- , ("deprecationReason", Null)
- ]
- , Object $
- HashMap.fromList
- [ ("name", "INLINE_FRAGMENT")
- ,
- ( "description"
- , "Location adjacent to an inline fragment."
- )
- , ("isDeprecated", Boolean False)
- , ("deprecationReason", Null)
- ]
- , Object $
- HashMap.fromList
- [ ("name", "VARIABLE_DEFINITION")
- ,
- ( "description"
- , "Location adjacent to a variable definition."
- )
- , ("isDeprecated", Boolean False)
- , ("deprecationReason", Null)
- ]
- , Object $
- HashMap.fromList
- [ ("name", "SCHEMA")
- ,
- ( "description"
- , "Location adjacent to a schema definition."
- )
- , ("isDeprecated", Boolean False)
- , ("deprecationReason", Null)
- ]
- , Object $
- HashMap.fromList
- [ ("name", "SCALAR")
- ,
- ( "description"
- , "Location adjacent to a scalar definition."
- )
- , ("isDeprecated", Boolean False)
- , ("deprecationReason", Null)
- ]
- , Object $
- HashMap.fromList
- [ ("name", "OBJECT")
- ,
- ( "description"
- , "Location adjacent to an object type definition."
- )
- , ("isDeprecated", Boolean False)
- , ("deprecationReason", Null)
- ]
- , Object $
- HashMap.fromList
- [ ("name", "FIELD_DEFINITION")
- ,
- ( "description"
- , "Location adjacent to a field definition."
- )
- , ("isDeprecated", Boolean False)
- , ("deprecationReason", Null)
- ]
- , Object $
- HashMap.fromList
- [ ("name", "ARGUMENT_DEFINITION")
- ,
- ( "description"
- , "Location adjacent to an argument definition."
- )
- , ("isDeprecated", Boolean False)
- , ("deprecationReason", Null)
- ]
- , Object $
- HashMap.fromList
- [ ("name", "INTERFACE")
- ,
- ( "description"
- , "Location adjacent to an interface definition."
- )
- , ("isDeprecated", Boolean False)
- , ("deprecationReason", Null)
- ]
- , Object $
- HashMap.fromList
- [ ("name", "UNION")
- ,
- ( "description"
- , "Location adjacent to a union definition."
- )
- , ("isDeprecated", Boolean False)
- , ("deprecationReason", Null)
- ]
- , Object $
- HashMap.fromList
- [ ("name", "ENUM")
- ,
- ( "description"
- , "Location adjacent to an enum definition."
- )
- , ("isDeprecated", Boolean False)
- , ("deprecationReason", Null)
- ]
- , Object $
- HashMap.fromList
- [ ("name", "ENUM_VALUE")
- ,
- ( "description"
- , "Location adjacent to an enum value definition."
- )
- , ("isDeprecated", Boolean False)
- , ("deprecationReason", Null)
- ]
- , Object $
- HashMap.fromList
- [ ("name", "INPUT_OBJECT")
- ,
- ( "description"
- , "Location adjacent to an input object \
- \type definition."
- )
- , ("isDeprecated", Boolean False)
- , ("deprecationReason", Null)
- ]
- , Object $
- HashMap.fromList
- [ ("name", "INPUT_FIELD_DEFINITION")
- ,
- ( "description"
- , "Location adjacent to an input object \
- \field definition."
- )
- , ("isDeprecated", Boolean False)
- , ("deprecationReason", Null)
- ]
- ]
- )
- ]
- ]
- & filter (/= Null)
- )
- ,
- ( "directives"
- , ValueResolver directivesType $
- pure $
- List
- [ Object $
- HashMap.fromList
- [ ("__typename", "__Directive")
- , ("name", "skip")
- ,
- ( "description"
- , "Directs the executor to skip this field or fragment \
- \when the `if` argument is true."
- )
- ,
- ( "locations"
- , List ["INLINE_FRAGMENT", "FRAGMENT_SPREAD", "FIELD"]
- )
- ,
- ( "args"
- , List
- [ Object $
- HashMap.fromList
- [ ("name", "if")
- , ("description", "Skipped when true.")
- , ("defaultValue", Null)
- ,
- ( "type"
- , Object $
- HashMap.fromList
- [ ("kind", "NON_NULL")
- ,
- ( "ofType"
- , Object $
- HashMap.fromList
- [ ("kind", "SCALAR")
- , ("name", "Boolean")
- ]
- )
- ]
- )
- ]
- ]
- )
- ]
- , Object $
- HashMap.fromList
- [ ("__typename", "__Directive")
- , ("name", "include")
- ,
- ( "description"
- , "Directs the executor to include this field or fragment \
- \only when the `if` argument is true."
- )
- ,
- ( "locations"
- , List ["INLINE_FRAGMENT", "FRAGMENT_SPREAD", "FIELD"]
- )
- ,
- ( "args"
- , List
- [ Object $
- HashMap.fromList
- [ ("name", "if")
- , ("description", "Included when true.")
- , ("defaultValue", Null)
- ,
- ( "type"
- , Object $
- HashMap.fromList
- [ ("kind", "NON_NULL")
- ,
- ( "ofType"
- , Object $
- HashMap.fromList
- [ ("kind", "SCALAR")
- , ("name", "Boolean")
- ]
- )
- ]
- )
- ]
- ]
- )
- ]
- , Object $
- HashMap.fromList
- [ ("__typename", "__Directive")
- , ("name", "deprecated")
- ,
- ( "description"
- , "Marks an element of a GraphQL schema \
- \as no longer supported."
- )
- ,
- ( "locations"
- , List ["ENUM_VALUE", "FIELD_DEFINITION"]
- )
- ,
- ( "args"
- , List
- [ Object $
- HashMap.fromList
- [ ("name", "reason")
- ,
- ( "description"
- , "Explains why this element was deprecated, \
- \usually also including a suggestion \
- \for how to access supported similar data. \
- \Formatted using the Markdown syntax \
- \(as specified by \
- \[CommonMark](https://commonmark.org/)."
- )
- , ("defaultValue", "\"No longer supported\"")
- , getTypeTuple "SCALAR" "String"
- ]
- ]
- )
- ]
- ]
- )
- ]
- }
-
-
-getSchemaField
- :: Text
- -> Connection
- -> AccessMode
- -> [TableEntryRaw]
- -> IO (Field IO)
-getSchemaField dbId conn accessMode tables = do
- schemaFieldOutput <- getSchemaFieldOutput dbId conn accessMode tables
-
- pure $
- outFieldToField $
- OutField
- { descriptionMb = Just "The schema"
- , fieldType = schemaFieldOutput
- , arguments = HashMap.empty
- }
-
-
-getSchemaResolver
- :: Text
- -> Connection
- -> AccessMode
- -> [TableEntryRaw]
- -> IO (HashMap Text (Resolver IO))
-getSchemaResolver dbId conn accessMode tables = do
- schemaField <- getSchemaField dbId conn accessMode tables
-
- pure $
- HashMap.singleton
- "__schema"
- (ValueResolver schemaField (pure Null))
-
-
-typeNameOutField :: Field m
-typeNameOutField =
- outFieldToField $
- OutField
- { descriptionMb = Just "The type name"
- , fieldType = Out.NonNullScalarType string
- , arguments = HashMap.empty
- }
+import Language.GraphQL.Class (ToGraphQL (toGraphQL))
+import Language.GraphQL.Type (string)
typeNameResolver :: HashMap Text (Resolver IO)
typeNameResolver =
HashMap.singleton
"__typename"
- (ValueResolver typeNameOutField $ pure "Query")
+ $ ValueResolver
+ (Out.Field Nothing (Out.NonNullScalarType string) mempty)
+ $ pure "Query"
+
+
+columnTypeName :: ColumnEntry -> Text
+columnTypeName entry = fromMaybe "String" (columnType entry).name
+
+
+columnType :: ColumnEntry -> IntrospectionType
+columnType entry = case entry.datatype_gql of
+ Nothing -> Type.typeString
+ Just type_ ->
+ Type.scalar type_.full
+ & Type.withDescription
+ ("Data type for column" <> entry.column_name_gql)
+
+
+orderingTermType :: Type.IntrospectionType
+orderingTermType =
+ Type.enum
+ "OrderingTerm"
+ [ Type.enumValue "ASC" & Type.enumValueWithDescription "In ascending order"
+ , Type.enumValue "asc"
+ & Type.enumValueWithDescription "In ascending order"
+ & Type.deprecatedEnumValue "GraphQL spec recommends all caps for enums"
+ , Type.enumValue "DESC" & Type.enumValueWithDescription "In descending order"
+ , Type.enumValue "desc"
+ & Type.enumValueWithDescription "In descending order"
+ & Type.deprecatedEnumValue "GraphQL spec recommends all caps for enums"
+ ]
+
+
+filterType :: TableEntry -> IntrospectionType
+filterType table = do
+ let
+ fieldsWithComparisonExp =
+ table.columns <&> \columnEntry -> do
+ let colName = columnEntry.column_name_gql
+ let typeName = columnTypeName columnEntry
+ let type_ = columnType columnEntry
+ Type.inputValue colName $
+ Type.inputObject
+ (typeName <> "Comparison")
+ [ Type.inputValue "eq" type_
+ , Type.inputValue "neq" type_
+ , Type.inputValue "gt" type_
+ , Type.inputValue "gte" type_
+ , Type.inputValue "lt" type_
+ , Type.inputValue "lte" type_
+ , Type.inputValue "like" type_
+ , Type.inputValue "ilike" type_
+ , Type.inputValue "in" $ Type.list type_
+ , Type.inputValue "nin" $ Type.list type_
+ ]
+
+ Type.inputObject
+ (doubleXEncodeGql table.name <> "_filter")
+ fieldsWithComparisonExp
+ & Type.withDescription "Select rows matching the provided filter object"
+
+
+tableRowType :: TableEntry -> Type.IntrospectionType
+tableRowType table = do
+ let fields =
+ table.columns <&> \columnEntry -> do
+ let colName = columnEntry.column_name_gql
+ let base = columnType columnEntry
+ let type_ =
+ if columnEntry.notnull
+ then Type.nonNull base
+ else base
+ Type.field colName type_
+ Type.object (doubleXEncodeGql table.name <> "_row") fields
+
+
+tableQueryField :: TableEntry -> Type.Field
+tableQueryField table = do
+ let tableName = table.name
+
+ let fieldsWithOrderingTerm =
+ table.columns <&> \columnEntry -> do
+ let colName = columnEntry.column_name_gql
+ Type.inputValue colName orderingTermType
+
+ let orderType =
+ Type.inputObject
+ (doubleXEncodeGql tableName <> "_order_by")
+ fieldsWithOrderingTerm
+ & Type.withDescription
+ ( "Ordering options when selecting data from \""
+ <> table.name
+ <> "\"."
+ )
+
+ Type.field
+ (doubleXEncodeGql tableName)
+ (Type.nonNull $ Type.list $ Type.nonNull $ tableRowType table)
+ & Type.fieldWithDescription ("Rows from the table \"" <> tableName <> "\"")
+ & 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"
+ ]
+
+
+mutationResponseType :: AccessMode -> TableEntry -> Type.IntrospectionType
+mutationResponseType accessMode table = do
+ let tableName = doubleXEncodeGql table.name
+ let readFields =
+ if canRead accessMode
+ then
+ pure
+ $ Type.field
+ "returning"
+ $ Type.nonNull
+ $ Type.list
+ $ Type.nonNull
+ $ tableRowType table
+ else []
+
+ Type.object
+ (tableName <> "_mutation_response")
+ ( [ Type.field "affected_rows" (Type.nonNull Type.typeInt)
+ ]
+ <> readFields
+ )
+ & Type.withDescription ("Mutation response for " <> table.name)
+
+
+tableInsertField :: AccessMode -> TableEntry -> Type.Field
+tableInsertField accessMode table = do
+ let
+ tableName = doubleXEncodeGql table.name
+ fields =
+ table.columns <&> \columnEntry -> do
+ let colName = columnEntry.column_name_gql
+ let base = columnType columnEntry
+ let type_ =
+ if columnEntry.isOmittable
+ then Type.nonNull base
+ else base
+ Type.inputValue colName type_
+
+ insertRows =
+ Type.inputObject
+ (tableName <> "_insert_input")
+ fields
+ & Type.withDescription
+ ("Input object for " <> table.name)
+
+ fieldEnumVariants =
+ table.columns <&> \columnEntry ->
+ Type.enumValue $ column_name_gql columnEntry
+
+ fieldEnumType =
+ Type.enum (tableName <> "_column") fieldEnumVariants
+ & Type.withDescription
+ "This enum contains a variant for each column in the table"
+
+ onConflict =
+ Type.inputObject
+ (tableName <> "_upsert_on_conflict")
+ [ Type.inputValue
+ "constraint"
+ (Type.nonNull $ Type.list $ Type.nonNull fieldEnumType)
+ & Type.inputValueWithDescription
+ "columns to handle conflicts of"
+ , Type.inputValue
+ "update_columns"
+ (Type.nonNull $ Type.list $ Type.nonNull fieldEnumType)
+ & Type.inputValueWithDescription
+ "columns to override on conflict"
+ , Type.inputValue "where" (filterType table)
+ & Type.inputValueWithDescription
+ "filter specifying which conflicting columns to update"
+ ]
+ & Type.withDescription
+ ( "Specifies how broken UNIQUE constraints for "
+ <> table.name
+ <> " should be handled"
+ )
+
+ Type.field
+ ("insert_" <> tableName)
+ (mutationResponseType accessMode table)
+ & Type.fieldWithDescription
+ ("Insert new rows in table \"" <> table.name <> "\"")
+ & Type.withArguments
+ [ Type.inputValue
+ "objects"
+ (Type.nonNull $ Type.list $ Type.nonNull insertRows)
+ & Type.inputValueWithDescription "Rows to be inserted"
+ , Type.inputValue
+ "on_conflict"
+ (Type.list $ Type.nonNull onConflict)
+ & Type.inputValueWithDescription
+ "Specifies how to handle broken UNIQUE constraints"
+ ]
+
+
+tableUpdateField :: AccessMode -> TableEntry -> Type.Field
+tableUpdateField accessMode table = do
+ let
+ tableName = doubleXEncodeGql table.name
+
+ fields =
+ table.columns <&> \columnEntry -> do
+ let colName = columnEntry.column_name_gql
+ let base = columnType columnEntry
+ Type.inputValue colName $ Type.nonNull base
+
+ updateRow =
+ Type.inputObject
+ (tableName <> "_set_input")
+ fields
+ & Type.withDescription
+ ("Fields to set for " <> table.name)
+
+ Type.field
+ ("update_" <> tableName)
+ (mutationResponseType accessMode table)
+ & Type.fieldWithDescription
+ ("Update rows in table \"" <> table.name <> "\"")
+ & Type.withArguments
+ [ Type.inputValue
+ "set"
+ (Type.nonNull $ Type.nonNull updateRow)
+ & Type.inputValueWithDescription "Fields to be updated"
+ , Type.inputValue
+ "filter"
+ (Type.nonNull $ filterType table)
+ & Type.inputValueWithDescription "Filter to select rows to be updated"
+ ]
+
+
+tableDeleteField :: AccessMode -> TableEntry -> Type.Field
+tableDeleteField accessMode table = do
+ Type.field
+ ("delete_" <> doubleXEncodeGql table.name)
+ (mutationResponseType accessMode table)
+ & Type.fieldWithDescription
+ ("Delete rows in table \"" <> table.name <> "\"")
+ & Type.withArguments
+ [ Type.inputValue
+ "filter"
+ (Type.nonNull $ filterType table)
+ & Type.inputValueWithDescription "Filter to select rows to be deleted"
+ ]
+
+
+getSchema
+ :: AccessMode
+ -> [TableEntry]
+ -> Type.Schema
+getSchema accessMode tables = do
+ let
+ queryType =
+ if canRead accessMode
+ then tables <&> tableQueryField
+ else []
+
+ mutationType =
+ if canWrite accessMode
+ then
+ P.fold
+ [ tables <&> tableInsertField accessMode
+ , tables <&> tableUpdateField accessMode
+ , tables <&> tableDeleteField accessMode
+ ]
+ else []
+
+ Type.collectSchemaTypes $
+ Type.Schema
+ Nothing
+ []
+ (Type.object "Query" queryType)
+ (Just $ Type.object "Mutation" mutationType)
+
+
+-- We make this toplevel, because putting it inside `getSchemaResolver`
+-- means haskell will evaluate it each time, which leads to each execution
+-- taking 2-3s
+makeSchemaResolver :: Either Text (Type.Schema -> Resolver IO)
+makeSchemaResolver = do
+ let schemaField = Type.field "__schema" Type.typeSchema
+ ty <- makeType schemaField.type_
+ let gqlField = Out.Field schemaField.description ty mempty
+ pure $ \schema -> Out.ValueResolver gqlField $ pure $ toGraphQL schema
+
+
+getSchemaResolver
+ :: AccessMode
+ -> [TableEntry]
+ -> IO (HashMap Text (Resolver IO))
+getSchemaResolver accessMode tables = do
+ case makeSchemaResolver of
+ Right make -> do
+ let schema = getSchema accessMode tables
+ pure $ HashMap.singleton "__schema" $ make schema
+ Left err -> fail $ T.unpack err
diff --git a/source/AirGQL/Introspection/Resolver.hs b/source/AirGQL/Introspection/Resolver.hs
new file mode 100644
index 0000000..f030c65
--- /dev/null
+++ b/source/AirGQL/Introspection/Resolver.hs
@@ -0,0 +1,182 @@
+module AirGQL.Introspection.Resolver (makeType, makeConstField, makeChildField) where
+
+import Protolude (
+ Either (Left),
+ IO,
+ Int,
+ MonadReader (ask),
+ Text,
+ fromMaybe,
+ mempty,
+ note,
+ pure,
+ ($),
+ (+),
+ (<$>),
+ (<&>),
+ (<>),
+ (>=),
+ )
+import Protolude qualified as P
+
+import AirGQL.Introspection.Types qualified as IType
+import Data.HashMap.Strict qualified as HashMap
+import Language.GraphQL.Type qualified as Type
+import Language.GraphQL.Type.In qualified as In
+import Language.GraphQL.Type.Out qualified as Out
+
+
+type Result = Either Text
+
+
+maxDepth :: Int
+maxDepth = 9
+
+
+makeType :: IType.IntrospectionType -> Result (Out.Type IO)
+makeType = makeTypeWithDepth 0
+
+
+makeTypeWithDepth :: Int -> IType.IntrospectionType -> Result (Out.Type IO)
+makeTypeWithDepth depth ty = do
+ case ty.kind of
+ IType.Scalar -> do
+ name <- note "No `name` found for scalar" ty.name
+ pure $ Out.NamedScalarType $ Type.ScalarType name ty.description
+ IType.List -> do
+ ofType <- note "No `ofType` found for list" ty.ofType
+ Out.ListType <$> makeTypeWithDepth depth ofType
+ IType.Enum -> do
+ name <- note "No `name` found for enum" ty.name
+ enumValues <- note "No `enumValues` found for enum" ty.enumValues
+ let variants = enumValues <&> \variant -> (variant.name, Type.EnumValue variant.description)
+ pure $
+ Out.NamedEnumType $
+ Type.EnumType name ty.description $
+ HashMap.fromList variants
+ IType.NonNull -> do
+ ofType <- note "No `ofType` found for nonnull" ty.ofType
+ inner <- makeTypeWithDepth depth ofType
+ pure $ case inner of
+ Out.EnumBaseType enumType -> Out.NonNullEnumType enumType
+ Out.UnionBaseType unionType -> Out.NonNullUnionType unionType
+ Out.ScalarBaseType scalarType -> Out.NonNullScalarType scalarType
+ Out.ObjectBaseType objectType -> Out.NonNullObjectType objectType
+ Out.ListBaseType listType -> Out.NonNullListType listType
+ Out.InterfaceBaseType interfaceType -> Out.NonNullInterfaceType interfaceType
+ IType.InputObject -> do
+ Left "input object in out position"
+ IType.Object -> do
+ name <- note "No `name` found for object" ty.name
+ fields <- note "No `fields` found for object" ty.fields
+ resolvers <-
+ if depth >= maxDepth
+ then pure []
+ else P.for fields $ \field -> do
+ resolver <- makeChildFieldWithDepth (depth + 1) field
+ pure (field.name, resolver)
+
+ typenameResolver <-
+ makeConstFieldWithDepth
+ depth
+ (IType.field "__typename" $ IType.nonNull IType.typeString)
+ (Type.String name)
+
+ pure
+ $ Out.NamedObjectType
+ $ Type.ObjectType
+ name
+ ty.description
+ []
+ $ HashMap.fromList
+ $ ("__typename", typenameResolver) : resolvers
+
+
+makeConstField :: IType.Field -> Type.Value -> Result (Out.Resolver IO)
+makeConstField = makeConstFieldWithDepth 0
+
+
+makeConstFieldWithDepth :: Int -> IType.Field -> Type.Value -> Result (Out.Resolver IO)
+makeConstFieldWithDepth depth field value = do
+ ty <- makeTypeWithDepth depth field.type_
+ let gqlField = Out.Field field.description ty mempty
+ pure $ Out.ValueResolver gqlField $ pure value
+
+
+makeChildField :: IType.Field -> Result (Out.Resolver IO)
+makeChildField = makeChildFieldWithDepth 0
+
+
+makeChildFieldWithDepth :: Int -> IType.Field -> Result (Out.Resolver IO)
+makeChildFieldWithDepth depth field = do
+ args <- P.for field.args $ \arg -> do
+ ty <- makeInTypeWithDepth depth arg.type_
+ pure (arg.name, In.Argument arg.description ty arg.defaultValue)
+ ty <- makeTypeWithDepth depth field.type_
+ let gqlField = Out.Field field.description ty $ HashMap.fromList args
+ pure $ Out.ValueResolver gqlField $ do
+ context <- ask
+ let defaultValue =
+ if Out.isNonNullType ty
+ then
+ Type.String $
+ "Error: field '"
+ <> field.name
+ <> "' not found "
+ else Type.Null
+ case context.values of
+ Type.Object obj ->
+ pure $
+ fromMaybe defaultValue $
+ HashMap.lookup field.name obj
+ _ -> pure defaultValue
+
+
+makeInTypeWithDepth :: Int -> IType.IntrospectionType -> Result In.Type
+makeInTypeWithDepth depth ty = do
+ case ty.kind of
+ IType.Scalar -> do
+ name <- note "No `name` found for scalar" ty.name
+ pure $ In.NamedScalarType $ Type.ScalarType name ty.description
+ IType.List -> do
+ ofType <- note "No `ofType` found for list" ty.ofType
+ In.ListType <$> makeInTypeWithDepth depth ofType
+ IType.Enum -> do
+ name <- note "No `name` found for enum" ty.name
+ enumValues <- note "No `enumValues` found for enum" ty.enumValues
+ let variants = enumValues <&> \variant -> (variant.name, Type.EnumValue variant.description)
+ pure $
+ In.NamedEnumType $
+ Type.EnumType name ty.description $
+ HashMap.fromList variants
+ IType.NonNull -> do
+ ofType <- note "No `ofType` found for nonnull" ty.ofType
+ inner <- makeInTypeWithDepth depth ofType
+ pure $ case inner of
+ In.EnumBaseType enumType -> In.NonNullEnumType enumType
+ In.ScalarBaseType scalarType -> In.NonNullScalarType scalarType
+ In.InputObjectBaseType objectType -> In.NonNullInputObjectType objectType
+ In.ListBaseType listType -> In.NonNullListType listType
+ IType.Object -> do
+ Left "out object in input position"
+ IType.InputObject -> do
+ name <- note "No `name` found for object" ty.name
+ fields <- note "No `inputFields` found for object" ty.inputFields
+ gqlFields <-
+ if depth >= maxDepth
+ then pure []
+ else P.for fields $ \field -> do
+ inner <- makeInTypeWithDepth (depth + 1) field.type_
+ let inputField =
+ In.InputField
+ field.description
+ inner
+ field.defaultValue
+ pure (field.name, inputField)
+
+ pure
+ $ In.NamedInputObjectType
+ $ Type.InputObjectType
+ name
+ ty.description
+ $ HashMap.fromList gqlFields
diff --git a/source/AirGQL/Introspection/Types.hs b/source/AirGQL/Introspection/Types.hs
new file mode 100644
index 0000000..ed8ecc4
--- /dev/null
+++ b/source/AirGQL/Introspection/Types.hs
@@ -0,0 +1,481 @@
+module AirGQL.Introspection.Types (
+ Schema (..),
+ IntrospectionType (..),
+ TypeKind (..),
+ Field (..),
+ InputValue (..),
+ EnumValue (..),
+ list,
+ nonNull,
+ field,
+ withArguments,
+ inputValue,
+ inputValueWithDescription,
+ withName,
+ withDescription,
+ fieldWithDescription,
+ scalar,
+ object,
+ inputObject,
+ typeSchema,
+ typeIntrospectionType,
+ typeField,
+ typeString,
+ typeInt,
+ typeBool,
+ collectSchemaTypes,
+ enum,
+ enumValue,
+ enumValueWithDescription,
+ deprecatedEnumValue,
+) where
+
+import Data.HashMap.Strict (HashMap)
+import Data.HashMap.Strict qualified as HashMap
+import Language.GraphQL.Class (ToGraphQL (toGraphQL))
+import Language.GraphQL.Type qualified as Value
+import Protolude (
+ Bool (False, True),
+ Generic,
+ Maybe (Just, Nothing),
+ MonadState (get, put),
+ Monoid (mempty),
+ Show,
+ State,
+ Text,
+ execState,
+ for_,
+ not,
+ show,
+ when,
+ ($),
+ (&),
+ )
+
+
+data Schema = Schema
+ { description :: Maybe Text
+ , types :: [IntrospectionType]
+ , queryType :: IntrospectionType
+ , mutationType :: Maybe IntrospectionType
+ }
+ deriving (Show, Generic)
+
+
+instance ToGraphQL Schema where
+ toGraphQL schema =
+ Value.Object $
+ HashMap.fromList
+ [ ("description", toGraphQL schema.description)
+ , ("types", toGraphQL schema.types)
+ , ("queryType", toGraphQL schema.queryType)
+ , ("mutationType", toGraphQL schema.mutationType)
+ , ("subscriptionType", Value.Null)
+ , ("directives", Value.List [])
+ ]
+
+
+typeSchema :: IntrospectionType
+typeSchema =
+ object
+ "__Schema"
+ [ field "description" typeString
+ , field "types" $ nonNull $ list $ nonNull typeIntrospectionType
+ , field "queryType" $ nonNull typeIntrospectionType
+ , field "mutationType" typeIntrospectionType
+ , field "subscriptionType" typeIntrospectionType
+ , field "directives" $ nonNull $ list $ nonNull typeDirective
+ ]
+
+
+typeDirective :: IntrospectionType
+typeDirective =
+ object
+ "__Directive"
+ [ field "name" typeString
+ , field "description" typeString
+ , field "args" $ nonNull $ list $ nonNull typeInputValue
+ , field "isRepeatable" $ nonNull typeBool
+ , field "locations" $ nonNull $ list $ nonNull typeDirectiveLocation
+ ]
+
+
+typeDirectiveLocation :: IntrospectionType
+typeDirectiveLocation =
+ enum
+ "__DirectiveLocation"
+ [ enumValue "QUERY"
+ , enumValue "MUTATION"
+ , enumValue "SUBSCRIPTION"
+ , enumValue "FIELD"
+ , enumValue "FRAGMENT_DEFINITION"
+ , enumValue "FRAGMENT_SPREAD"
+ , enumValue "INLINE_FRAGMENT"
+ , enumValue "VARIABLE_DEFINITION"
+ , enumValue "SCHEMA"
+ , enumValue "SCALAR"
+ , enumValue "OBJECT"
+ , enumValue "FIELD_DEFINITION"
+ , enumValue "ARGUMENT_DEFINITION"
+ , enumValue "INTERFACE"
+ , enumValue "UNION"
+ , enumValue "ENUM"
+ , enumValue "ENUM_VALUE"
+ , enumValue "INPUT_OBJECT"
+ , enumValue "INPUT_FIELD_DEFINITION"
+ ]
+
+
+data TypeKind = Scalar | Object | Enum | InputObject | List | NonNull
+ deriving (Show, Generic)
+
+
+-- $(deriveToGraphQL ''TypeKind)
+instance ToGraphQL TypeKind where
+ toGraphQL Scalar = Value.Enum "SCALAR"
+ toGraphQL Object = Value.Enum "OBJECT"
+ toGraphQL Enum = Value.Enum "ENUM"
+ toGraphQL InputObject = Value.Enum "INPUT_OBJECT"
+ toGraphQL List = Value.Enum "LIST"
+ toGraphQL NonNull = Value.Enum "NON_NULL"
+
+
+data IntrospectionType = IType
+ { kind :: TypeKind
+ , name :: Maybe Text
+ , description :: Maybe Text
+ , interfaces :: Maybe [IntrospectionType]
+ , possibleTypes :: Maybe [IntrospectionType]
+ , fields :: Maybe [Field]
+ , inputFields :: Maybe [InputValue]
+ , enumValues :: Maybe [EnumValue]
+ , ofType :: Maybe IntrospectionType
+ }
+ deriving (Show, Generic)
+
+
+instance ToGraphQL IntrospectionType where
+ toGraphQL ty =
+ Value.Object $
+ HashMap.fromList
+ [ ("kind", toGraphQL ty.kind)
+ , ("name", toGraphQL ty.name)
+ , ("description", toGraphQL ty.description)
+ , ("interfaces", toGraphQL ty.interfaces)
+ , ("possibleTypes", toGraphQL ty.possibleTypes)
+ , ("fields", toGraphQL ty.fields)
+ , ("enumValues", toGraphQL ty.enumValues)
+ , ("inputFields", toGraphQL ty.inputFields)
+ , ("ofType", toGraphQL ty.ofType)
+ ]
+
+
+typeIntrospectionType :: IntrospectionType
+typeIntrospectionType =
+ object
+ "__Type"
+ [ field
+ "kind"
+ $ enum
+ "__TypeKind"
+ [ enumValue "SCALAR"
+ , enumValue "OBJECT"
+ , enumValue "ENUM"
+ , enumValue "INPUT_OBJECT"
+ , enumValue "LIST"
+ , enumValue "NON_NULL"
+ , enumValue "INTERFACE"
+ ]
+ , field "name" typeString
+ , field "description" typeString
+ , field "interfaces" $ list $ nonNull typeIntrospectionType
+ , field "possibleTypes" $ list $ nonNull typeIntrospectionType
+ , field "fields" (list $ nonNull typeField)
+ & withArguments [inputValue "includeDeprecated" typeBool]
+ , field "enumValues" (list $ nonNull typeEnumValue)
+ & withArguments [inputValue "includeDeprecated" typeBool]
+ , field "inputFields" $ list $ nonNull typeInputValue
+ , field "ofType" typeIntrospectionType
+ ]
+
+
+emptyType :: TypeKind -> IntrospectionType
+emptyType kind =
+ IType
+ { kind
+ , name = Nothing
+ , description = Nothing
+ , interfaces = Nothing
+ , possibleTypes = Nothing
+ , fields = Nothing
+ , enumValues = Nothing
+ , inputFields = Nothing
+ , ofType = Nothing
+ }
+
+
+nonNull :: IntrospectionType -> IntrospectionType
+nonNull ty =
+ (emptyType NonNull)
+ { ofType = Just ty
+ }
+
+
+list :: IntrospectionType -> IntrospectionType
+list ty =
+ (emptyType List)
+ { ofType = Just ty
+ }
+
+
+object :: Text -> [Field] -> IntrospectionType
+object name fields =
+ (emptyType Object)
+ { fields = Just fields
+ , name = Just name
+ , interfaces = Just []
+ }
+
+
+inputObject :: Text -> [InputValue] -> IntrospectionType
+inputObject name fields =
+ (emptyType InputObject)
+ { inputFields = Just fields
+ , name = Just name
+ , interfaces = Just []
+ }
+
+
+enum :: Text -> [EnumValue] -> IntrospectionType
+enum name variants =
+ (emptyType Enum)
+ { enumValues = Just variants
+ , name = Just name
+ }
+
+
+withName :: Text -> IntrospectionType -> IntrospectionType
+withName newName (IType{..}) =
+ IType
+ { name = Just newName
+ , ..
+ }
+
+
+withDescription :: Text -> IntrospectionType -> IntrospectionType
+withDescription newDesc (IType{..}) =
+ IType
+ { description = Just newDesc
+ , ..
+ }
+
+
+scalar :: Text -> IntrospectionType
+scalar tyName =
+ emptyType Scalar
+ & withName tyName
+
+
+data Field = Field
+ { name :: Text
+ , description :: Maybe Text
+ , args :: [InputValue]
+ , type_ :: IntrospectionType
+ , isDeprecated :: Bool
+ , deprecationReason :: Maybe Text
+ }
+ deriving (Show, Generic)
+
+
+instance ToGraphQL Field where
+ toGraphQL thisField =
+ Value.Object $
+ HashMap.fromList
+ [ ("name", toGraphQL thisField.name)
+ , ("description", toGraphQL thisField.description)
+ , ("args", toGraphQL thisField.args)
+ , ("type", toGraphQL thisField.type_)
+ , ("isDeprecated", toGraphQL thisField.isDeprecated)
+ , ("deprecationReason", toGraphQL thisField.deprecationReason)
+ ]
+
+
+typeField :: IntrospectionType
+typeField =
+ object
+ "__Field"
+ [ field "name" $ nonNull typeString
+ , field "description" typeString
+ , field "args" $ nonNull $ list $ nonNull typeInputValue
+ , field "type" $ nonNull typeIntrospectionType
+ , field "isDeprecated" $ nonNull typeBool
+ , field "deprecationReason" typeString
+ ]
+
+
+fieldWithDescription :: Text -> Field -> Field
+fieldWithDescription newDesc (Field{..}) =
+ Field
+ { description = Just newDesc
+ , ..
+ }
+
+
+field :: Text -> IntrospectionType -> Field
+field fieldName fieldType =
+ Field
+ { name = fieldName
+ , description = Nothing
+ , args = []
+ , type_ = fieldType
+ , isDeprecated = False
+ , deprecationReason = Nothing
+ }
+
+
+withArguments :: [InputValue] -> Field -> Field
+withArguments argList (Field{..}) = Field{args = argList, ..}
+
+
+data InputValue = InputValue
+ { name :: Text
+ , description :: Maybe Text
+ , type_ :: IntrospectionType
+ , defaultValue :: Maybe Value.Value
+ }
+ deriving (Show, Generic)
+
+
+instance ToGraphQL InputValue where
+ toGraphQL value =
+ Value.Object $
+ HashMap.fromList
+ [ ("name", toGraphQL value.name)
+ , ("description", toGraphQL value.description)
+ , ("type", toGraphQL value.type_)
+ , -- TODO: I don't think show is the correct function here
+ ("defaultValue", Value.String $ show value.defaultValue)
+ ]
+
+
+typeInputValue :: IntrospectionType
+typeInputValue =
+ object
+ "__InputValue"
+ [ field "name" $ nonNull typeString
+ , field "description" typeString
+ , field "type" $ nonNull typeIntrospectionType
+ , field "defaultValue" typeString
+ ]
+
+
+inputValue :: Text -> IntrospectionType -> InputValue
+inputValue fieldName fieldType =
+ InputValue
+ { name = fieldName
+ , description = Nothing
+ , type_ = fieldType
+ , defaultValue = Nothing
+ }
+
+
+inputValueWithDescription :: Text -> InputValue -> InputValue
+inputValueWithDescription newDesc (InputValue{..}) =
+ InputValue
+ { description = Just newDesc
+ , ..
+ }
+
+
+data EnumValue = EnumValue
+ { name :: Text
+ , description :: Maybe Text
+ , isDeprecated :: Bool
+ , deprecationReason :: Maybe Text
+ }
+ deriving (Show, Generic)
+
+
+instance ToGraphQL EnumValue where
+ toGraphQL value =
+ Value.Object $
+ HashMap.fromList
+ [ ("name", toGraphQL value.name)
+ , ("description", toGraphQL value.description)
+ , ("isDeprecated", toGraphQL value.isDeprecated)
+ , ("deprecationReason", toGraphQL value.deprecationReason)
+ ]
+
+
+typeEnumValue :: IntrospectionType
+typeEnumValue =
+ object
+ "__EnumValue"
+ [ field "name" $ nonNull typeString
+ , field "description" typeString
+ , field "isDeprecated" $ nonNull typeBool
+ , field "deprecationReason" typeString
+ ]
+
+
+enumValue :: Text -> EnumValue
+enumValue name = EnumValue{name = name, description = Nothing, isDeprecated = False, deprecationReason = Nothing}
+
+
+enumValueWithDescription :: Text -> EnumValue -> EnumValue
+enumValueWithDescription newDesc (EnumValue{..}) =
+ EnumValue{description = Just newDesc, ..}
+
+
+deprecatedEnumValue :: Text -> EnumValue -> EnumValue
+deprecatedEnumValue reason (EnumValue{..}) =
+ EnumValue
+ { isDeprecated = True
+ , deprecationReason = Just reason
+ , ..
+ }
+
+
+typeString :: IntrospectionType
+typeString = scalar "String"
+
+
+typeInt :: IntrospectionType
+typeInt = scalar "Int"
+
+
+typeBool :: IntrospectionType
+typeBool = scalar "Boolean"
+
+
+collectSchemaTypes :: Schema -> Schema
+collectSchemaTypes schema = do
+ let basic = [typeInt, typeString, typeBool, typeSchema]
+ let all = do
+ collectTypes schema.queryType
+ for_ schema.mutationType collectTypes
+ for_ basic collectTypes
+ schema
+ { types = HashMap.elems $ execState all mempty
+ }
+
+
+-- | Collect a map of all the named types occurring inside a type
+collectTypes :: IntrospectionType -> State (HashMap Text IntrospectionType) ()
+collectTypes ty = do
+ for_ ty.ofType collectTypes
+ for_ ty.name $ \name -> do
+ current <- get
+ when (not $ HashMap.member name current) $ do
+ put $ HashMap.insert name ty current
+ for_ ty.interfaces $ \interfaces -> do
+ for_ interfaces collectTypes
+ for_ ty.possibleTypes $ \possibleTypes -> do
+ for_ possibleTypes collectTypes
+ for_ ty.inputFields $ \inputFields -> do
+ for_ inputFields $ \thisField -> collectTypes thisField.type_
+ for_ ty.fields $ \fields -> do
+ for_ fields $ \thisField -> do
+ collectTypes thisField.type_
+ for_ thisField.args $ \arg ->
+ collectTypes arg.type_
diff --git a/source/AirGQL/Lib.hs b/source/AirGQL/Lib.hs
index 5aa4902..c3c72ff 100644
--- a/source/AirGQL/Lib.hs
+++ b/source/AirGQL/Lib.hs
@@ -7,6 +7,8 @@
module AirGQL.Lib (
AccessMode (..),
+ canRead,
+ canWrite,
ColumnEntry (..),
GqlTypeName (..),
getEnrichedTable,
@@ -117,6 +119,16 @@ data AccessMode = ReadOnly | WriteOnly | ReadAndWrite
deriving (Eq, Show)
+canRead :: AccessMode -> Bool
+canRead WriteOnly = False
+canRead _ = True
+
+
+canWrite :: AccessMode -> Bool
+canWrite ReadOnly = False
+canWrite _ = True
+
+
data ObjectType = Table | Index | View | Trigger
deriving (Show, Eq, Generic)
diff --git a/source/AirGQL/ServerUtils.hs b/source/AirGQL/ServerUtils.hs
index 4cfbb4e..f046436 100644
--- a/source/AirGQL/ServerUtils.hs
+++ b/source/AirGQL/ServerUtils.hs
@@ -26,7 +26,7 @@ import Language.GraphQL.JSON (graphql)
import System.FilePath (pathSeparator, (</>))
import AirGQL.GraphQL (getDerivedSchema)
-import AirGQL.Lib (getTables)
+import AirGQL.Lib (getEnrichedTables)
import AirGQL.Types.SchemaConf (SchemaConf)
import AirGQL.Types.Types (
GQLResponse (GQLResponse, data_, errors),
@@ -49,23 +49,32 @@ executeQuery schemaConf dbIdOrPath reqDir query vars opNameMb = do
else reqDir </> "main.sqlite"
theConn <- SS.open dbFilePath
- tables <- getTables theConn
- schema <- getDerivedSchema schemaConf theConn dbIdOrPath tables
- result <- graphql schema opNameMb vars query
- SS.close theConn
-
- case result of
- Left errMsg -> do
- errors <- sourceToList errMsg
+ tablesEither <- getEnrichedTables theConn
+ case tablesEither of
+ Left err ->
pure $
gqlResponseToObject $
GQLResponse
{ data_ = Nothing
- , errors =
- Just $
- errors
- <&> ((\(Response _ errs) -> errs) >>> toList)
- & P.concat
- <&> (\(Error msg _ _) -> String msg)
+ , errors = Just [String err]
}
- Right response -> pure response
+ Right tables -> do
+ schema <- getDerivedSchema schemaConf theConn dbIdOrPath tables
+ result <- graphql schema opNameMb vars query
+ SS.close theConn
+
+ case result of
+ Left errMsg -> do
+ errors <- sourceToList errMsg
+ pure $
+ gqlResponseToObject $
+ GQLResponse
+ { data_ = Nothing
+ , errors =
+ Just $
+ errors
+ <&> ((\(Response _ errs) -> errs) >>> toList)
+ & P.concat
+ <&> (\(Error msg _ _) -> String msg)
+ }
+ Right response -> pure response