ddd/airgql
ddd/airgql
1
Fork 0
mirror of https://github.com/Airsequel/AirGQL.git synced 2025-07-28 05:53:20 +03:00
Code Activity

Migrate all gql code to share types with introspection

Browse source
This commit is contained in:
prescientmoon 2024-11-14 18:04:10 +01:00
commit 9cebb6dc2d
4 changed files with 364 additions and 828 deletions

1066
source/AirGQL/GraphQL.hs
View file

File diff suppressed because it is too large Load diff

23
source/AirGQL/Introspection.hs
View file

@ -3,6 +3,9 @@ module AirGQL.Introspection (
getSchemaResolver,
tableQueryField,
tableQueryByPKField,
tableInsertField,
tableUpdateField,
tableDeleteField,
)
where
@ -411,13 +414,12 @@ getSchema accessMode tables = do
-- 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.nonNull Type.typeSchema
ty <- makeType schemaField.type_
let gqlField = Out.Field schemaField.description ty mempty
pure $ \schema -> Out.ValueResolver gqlField $ pure $ toGraphQL schema
-- taking 2-3 additional seconds
schemaField :: Either Text (Out.Field IO)
schemaField = do
let field = Type.field "__schema" $ Type.nonNull Type.typeSchema
ty <- makeType field.type_
pure $ Out.Field field.description ty mempty
getSchemaResolver
@ -425,8 +427,9 @@ getSchemaResolver
-> [TableEntry]
-> IO (HashMap Text (Resolver IO))
getSchemaResolver accessMode tables = do
case makeSchemaResolver of
Right make -> do
case schemaField of
Right field -> do
let schema = getSchema accessMode tables
pure $ HashMap.singleton "__schema" $ make schema
let resolver = Out.ValueResolver field $ pure $ toGraphQL schema
pure $ HashMap.singleton "__schema" resolver
Left err -> fail $ T.unpack err

9
source/AirGQL/Lib.hs
View file

@ -672,10 +672,10 @@ resolveReferencesConstraint tables referencedTable = do
tables
let columns = table.columns
let pks = P.filter (\column -> column.primary_key) columns
let nonRowidPks = P.filter (\column -> column.isRowid) pks
case nonRowidPks of
[] -> pure "rowid"
[column] -> pure column.column_name
let nonRowidPks = P.filter (\column -> P.not column.isRowid) pks
column <- case nonRowidPks of
[] -> P.find (\column -> column.isRowid) pks
[column] -> pure column
-- Note: we currently do not support having composite primary keys
-- referenced implicitly, as that would lead to multiple complications like:
-- - figuring out the correct order for the references
@ -685,6 +685,7 @@ resolveReferencesConstraint tables referencedTable = do
-- do it as long as we keep track of the column order. Not sure it's worth the
-- hassle though...
_ -> Nothing
pure column.column_name
-- See the docs for `resolveReferencesConstraint` for details

94
tests/Spec.hs
View file

@ -8,25 +8,20 @@
{-# HLINT ignore "Replace case with maybe" #-}
import Protolude (
Applicative (pure),
Bool (False, True),
Either (Right),
FilePath,
IO,
Maybe (Just, Nothing),
Monoid (mempty),
Text,
fromMaybe,
show,
($),
(&),
(.),
(<$),
(<>),
)
import Protolude qualified as P
import Control.Monad.Catch (catchAll)
import Data.Aeson (Value (Number))
import Data.Aeson qualified as Ae
import Data.Aeson.KeyMap qualified as KeyMap
@ -118,6 +113,7 @@ import Tests.Utils (
rmSpaces,
shouldSaveDbs,
testRoot,
unorderedShouldBe,
withDataDbConn,
withTestDbConn,
)
@ -2000,31 +1996,36 @@ testSuite = do
}
|]
expected :: Text
expected =
"user error (Column progress cannot be set on conflicts without being explicitly provided)"
[raw|
{
"data": null,
"errors": [{
"locations": [{ "column": 3, "line": 2 }],
"path": ["insert_users"],
"message": "user error (Column progress cannot be set on conflicts without being explicitly provided)"
}]
}
|]
conn <- SS.open dbPath
Right tables <- getEnrichedTables conn
schema <- getDerivedSchema defaultSchemaConf conn fixtureDbId tables
Right _ <- graphql schema Nothing mempty firstQuery
Just err <-
catchAll
(Nothing <$ graphql schema Nothing mempty secondQuery)
(pure . Just . show)
Right err <- graphql schema Nothing mempty secondQuery
err `shouldBe` expected
err `unorderedShouldBe` expected
it "supports deleting data and returning the deleted data" $ do
conn <- SS.open dbPath
execute_
conn
[sql|
insert into users (name, email, created_utc)
values
('John', 'john@del-test.com', '2021-01-01T00:00Z'),
('Eve', 'eve@del-test.com', '2021-01-02T00:00Z')
|]
insert into users (name, email, created_utc)
values
('John', 'john@del-test.com', '2021-01-01T00:00Z'),
('Eve', 'eve@del-test.com', '2021-01-02T00:00Z')
|]
let
query =
@ -2041,21 +2042,24 @@ testSuite = do
}
}
|]
expected =
rmSpaces
[raw|{
"data": {
"delete_users": {
"affected_rows": 1,
"returning": [
{
"rowid": 2,
"name": "Eve"
}
]
[raw|
{
"data": {
"delete_users": {
"affected_rows": 1,
"returning": [
{
"rowid": 2,
"name": "Eve"
}
]
}
}
}
}|]
|]
Right tables <- getEnrichedTables conn
schema <- getDerivedSchema defaultSchemaConf conn fixtureDbId tables
@ -2106,14 +2110,14 @@ testSuite = do
expected =
rmSpaces
[raw|
{
"data": {
"insert_checks": {
"affected_rows": 1
{
"data": {
"insert_checks": {
"affected_rows": 1
}
}
}
}
|]
|]
Right result <- graphql schema Nothing mempty mutation
@ -2256,7 +2260,7 @@ testSuite = do
let
query =
[gql|
mutation InsertUsers ($objects: [users_insert_input]) {
mutation InsertUsers ($objects: [users_insert_input!]!) {
insert_users(objects: $objects) {
affected_rows
}
@ -2646,16 +2650,16 @@ testSuite = do
let expected =
rmSpaces
[raw|{
"data": { "insert_track": null },
"errors": [
{
"locations": [ { "column": 3, "line": 2 } ],
"message":
"SQLite3 returned ErrorConstraint while attempting to perform step: FOREIGN KEY constraint failed",
"path": [ "insert_track" ]
}
]
}|]
"data": null,
"errors": [
{
"locations": [ { "column": 3, "line": 2 } ],
"message":
"SQLite3 returned ErrorConstraint while attempting to perform step: FOREIGN KEY constraint failed",
"path": [ "insert_track" ]
}
]
}|]
Ae.encode result `shouldBe` expected