ddd/airgql
ddd/airgql
1
Fork 0
mirror of https://github.com/Airsequel/AirGQL.git synced 2025-08-11 01:16:58 +03:00
Code Activity
airgql/tests/Spec.hs

3395 lines
95 KiB
Haskell
Raw Blame History

-- Unit and integration tests
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# OPTIONS_GHC -Wno-missing-local-signatures #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# HLINT ignore "Replace case with maybe" #-}
import Protolude (
Applicative (pure),
Bool (False, True),
Either (Right),
FilePath,
IO,
Maybe (Just, Nothing),
Monoid (mempty),
Text,
fromMaybe,
readFile,
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
import Data.Aeson.Types (Object)
import Data.ByteString.Lazy qualified as BL
import Data.HashMap.Internal.Strict qualified as HashMap
import Data.List qualified as List
import Data.Text (pack, unpack)
import Data.Text qualified as T
import Data.Text.Encoding as T (encodeUtf8)
import Database.SQLite.Simple (
Query,
SQLData (SQLFloat, SQLInteger, SQLNull, SQLText),
execute_,
open,
query_,
)
import Database.SQLite.Simple qualified as SS
import Database.SQLite.Simple.QQ (sql)
import Language.GraphQL.JSON (graphql)
import Language.GraphQL.TH (gql)
import Language.GraphQL.Type as GQL (Value (Object, String))
import Servant.Server (runHandler)
import System.Directory (createDirectoryIfMissing, makeAbsolute)
import System.FilePath ((</>))
import System.Posix (changeWorkingDirectory, getWorkingDirectory)
import Test.Hspec (
SpecWith,
before_,
describe,
it,
pendingWith,
shouldBe,
shouldContain,
shouldMatchList,
)
import Test.Hspec qualified as Hspec
import AirGQL.GraphQL (getDerivedSchema)
import AirGQL.Introspection (createType)
import AirGQL.Lib (
AccessMode (WriteOnly),
ColumnEntry (
ColumnEntry,
column_name,
column_name_gql,
datatype,
datatype_gql,
dflt_value,
isGenerated,
isOmittable,
isUnique,
notnull,
primary_key,
select_options
),
GqlTypeName (GqlTypeName, full, root),
ObjectType (Table),
SQLPost (SQLPost),
TableEntryRaw (
TableEntryRaw,
name,
object_type,
rootpage,
tbl_name
),
getColumns,
getTables,
parseSql,
replaceCaseInsensitive,
stringToGqlTypeName,
)
import AirGQL.Lib qualified
import AirGQL.Raw (raw)
import AirGQL.Servant.SqlQuery (sqlQueryPostHandler)
import AirGQL.Types.PragmaConf qualified as PragmaConf
import AirGQL.Types.SchemaConf (SchemaConf (accessMode), defaultSchemaConf)
import AirGQL.Types.SqlQueryPostResult (
SqlQueryPostResult (
affectedTables,
errors,
rows
),
)
import AirGQL.Types.Utils (encodeToText)
import AirGQL.Utils (
getOrderOfLinkedList,
removeIfExists,
withRetryConn,
)
import Tests.Utils (testRoot, withDataDbConn, withTestDbConn)
-- | Save test databases after running tests for later inspection
shouldSaveDbs :: Bool
shouldSaveDbs = True
dbPath :: Text
dbPath = T.pack (testRoot </> "fixture.db")
rmSpaces :: Text -> BL.ByteString
rmSpaces text =
let
value :: Maybe Ae.Value =
text
& T.encodeUtf8
& pure
& BL.fromChunks
& Ae.decode
in
case value of
Just val -> Ae.encode val
Nothing -> "ERROR: Failed to decode JSON"
createUsersTableQuery :: Query
createUsersTableQuery =
[sql|
CREATE TABLE IF NOT EXISTS "users" (
"name" TEXT,
"email" TEXT NOT NULL UNIQUE,
"created_utc" TEXT NOT NULL,
"number_of_logins" INTEGER,
"progress" REAL,
PRIMARY KEY("email")
);
|]
createUsersTable :: SS.Connection -> IO ()
createUsersTable conn =
execute_ conn createUsersTableQuery
createSongsTableQuery :: Query
createSongsTableQuery =
[sql|
CREATE TABLE IF NOT EXISTS "songs" (
"name" TEXT NOT NULL,
"duration_seconds" INTEGER NOT NULL
);
|]
createSongsTable :: SS.Connection -> IO ()
createSongsTable conn =
execute_ conn createSongsTableQuery
-- prettyPrintSchema :: Schema m -> Text
-- prettyPrintSchema schema =
-- let
-- ObjectType name queryDesc interfaceTypes resolvers = query schema
-- in ""
-- <> "Description:\n" <> show (description schema) <> "\n\n"
-- <> "Query:\n\n"
-- <> " Name:\n" <> name <> "\n\n"
-- <> " Description:\n" <> show queryDesc <> "\n\n"
-- <> " InterfaceTypes:\n" <> show interfaceTypes <> "\n\n"
-- <> " Resolvers:\n" <> show resolvers <> "\n\n"
-- <> "Mutation:\n\n" <> show (mutation schema) <> "\n\n"
-- <> "Subscriptions:\n" <> show (subscription schema) <> "\n\n"
-- -- "Directives:\n" <> show (directives schema) <> "\n\n" <>
-- -- "Types:\n" <> show (types schema) <> "\n\n" <>
-- -- "Interface Implementations:\n" <> show (implementations schema) <> "\n\n"
-- <> ""
testSuite :: SpecWith ()
testSuite = do
describe "Utils" $ do
-- Hspec.fit "pretty prints the schema" $ do
-- conn <- open $ unpack dbPath
-- tables <- getTables conn
-- schema <-
-- getDerivedSchema defaultSchemaConf conn dbPath tables
-- putText $ prettyPrintSchema schema
-- True `shouldBe` True
it "replaces strings case insensitively" $ do
let
results =
[ replaceCaseInsensitive "hello" "hi" "hello world"
, replaceCaseInsensitive "hello" "hi" "Hello World"
, replaceCaseInsensitive "l" "L" "Hello World"
]
results `shouldBe` ["hi world", "hi World", "HeLLo WorLd"]
it "loads all tables from database" $ do
tables <- do
conn <- open $ unpack dbPath
getTables conn
shouldBe
tables
[ TableEntryRaw
{ name = "users"
, tbl_name = "users"
, object_type = Table
, rootpage = 2
, AirGQL.Lib.sql =
"\
\CREATE TABLE \"users\" (\n\
\ \"name\" TEXT,\n\
\ \"email\" TEXT NOT NULL UNIQUE,\n\
\ \"created_utc\" TEXT NOT NULL,\n\
\ \"number_of_logins\" INTEGER,\n\
\ \"progress\" REAL,\n\
\ PRIMARY KEY(\"email\")\n\
\ )"
}
, TableEntryRaw
{ name = "songs"
, tbl_name = "songs"
, object_type = Table
, rootpage = 4
, AirGQL.Lib.sql =
"\
\CREATE TABLE \"songs\" (\n\
\ \"name\" TEXT NOT NULL,\n\
\ \"duration_seconds\" INTEGER NOT NULL\n\
\ )"
}
]
describe "getColumns" $ do
it "loads all columns from users table" $ do
tableColumns <- do
conn <- open $ unpack dbPath
getColumns dbPath conn "users"
let
columnsExpected =
[ ColumnEntry
{ column_name = "rowid"
, column_name_gql = "rowid"
, datatype = "INTEGER"
, datatype_gql = Just $ stringToGqlTypeName "Int"
, select_options = Nothing
, notnull = False
, isUnique = False
, isOmittable = True
, isGenerated = False
, dflt_value = Nothing
, primary_key = True
}
, ColumnEntry
{ column_name = "name"
, column_name_gql = "name"
, datatype = "TEXT"
, datatype_gql = Just $ stringToGqlTypeName "String"
, select_options = Nothing
, notnull = False
, isUnique = False
, isOmittable = False
, isGenerated = False
, dflt_value = Nothing
, primary_key = False
}
, ColumnEntry
{ column_name = "email"
, column_name_gql = "email"
, datatype = "TEXT"
, datatype_gql = Just $ stringToGqlTypeName "String"
, select_options = Nothing
, notnull = True
, isUnique = True
, isOmittable = False
, isGenerated = False
, dflt_value = Nothing
, primary_key = True
}
, ColumnEntry
{ column_name = "created_utc"
, column_name_gql = "created_utc"
, datatype = "TEXT"
, datatype_gql = Just $ stringToGqlTypeName "String"
, select_options = Nothing
, notnull = True
, isUnique = False
, isOmittable = False
, isGenerated = False
, dflt_value = Nothing
, primary_key = False
}
, ColumnEntry
{ column_name = "number_of_logins"
, column_name_gql = "number_of_logins"
, datatype = "INTEGER"
, datatype_gql = Just $ stringToGqlTypeName "Int"
, select_options = Nothing
, notnull = False
, isUnique = False
, isOmittable = False
, isGenerated = False
, dflt_value = Nothing
, primary_key = False
}
, ColumnEntry
{ column_name = "progress"
, column_name_gql = "progress"
, datatype = "REAL"
, datatype_gql = Just $ stringToGqlTypeName "Float"
, select_options = Nothing
, notnull = False
, isUnique = False
, isOmittable = False
, isGenerated = False
, dflt_value = Nothing
, primary_key = False
}
]
tableColumns `shouldBe` columnsExpected
it "loads a nullable single-select column" $ do
let dbName = "creates_nullable_single-select.db"
withTestDbConn shouldSaveDbs dbName $ \conn -> do
execute_
conn
[sql|
CREATE TABLE checks (
color TEXT CHECK (color IN ('red', 'green', 'blue'))
)
|]
tableColumns <- getColumns dbName conn "checks"
let
columnExpected =
ColumnEntry
{ column_name = "color"
, column_name_gql = "color"
, datatype = "TEXT"
, datatype_gql =
Just $
GqlTypeName
{ full = "checks_color_String"
, root = "String"
}
, select_options = Just ["red", "green", "blue"]
, notnull = False
, isUnique = False
, isOmittable = False
, isGenerated = False
, dflt_value = Nothing
, primary_key = False
}
P.lastMay tableColumns `shouldBe` Just columnExpected
it "loads a non-null single-select column" $ do
let dbName = "creates_non-null_single-select.db"
withTestDbConn shouldSaveDbs dbName $ \conn -> do
execute_
conn
[sql|
CREATE TABLE checks (
color TEXT CHECK (color IN ('red', 'green', 'blue')) NOT NULL
)
|]
tableColumns <- getColumns dbName conn "checks"
let
columnExpected =
ColumnEntry
{ column_name = "color"
, column_name_gql = "color"
, datatype = "TEXT"
, datatype_gql =
Just $
GqlTypeName
{ full = "checks_color_String"
, root = "String"
}
, select_options = Just ["red", "green", "blue"]
, notnull = True
, isUnique = False
, isOmittable = False
, isGenerated = False
, dflt_value = Nothing
, primary_key = False
}
P.lastMay tableColumns `shouldBe` Just columnExpected
it "coerces a multi-type single-select column to text" $ do
let dbName = "multi-type_single-select.db"
withTestDbConn shouldSaveDbs dbName $ \conn -> do
execute_
conn
[sql|
CREATE TABLE checks (
value TEXT CHECK (value IN (1, 2.2, 'three'))
)
|]
tableColumns <- getColumns dbName conn "checks"
let
columnExpected =
ColumnEntry
{ column_name = "value"
, column_name_gql = "value"
, datatype = "TEXT"
, datatype_gql =
Just $
GqlTypeName
{ full = "checks_value_String"
, root = "String"
}
, select_options = Just ["1", "2.2", "three"]
, notnull = False
, isUnique = False
, isOmittable = False
, isGenerated = False
, dflt_value = Nothing
, primary_key = False
}
P.lastMay tableColumns `shouldBe` Just columnExpected
it "marks integer primary keys as omittable" $ do
let dbName = "integer-omittable-primary-key.db"
withTestDbConn shouldSaveDbs dbName $ \conn -> do
execute_
conn
[sql|
CREATE TABLE items (
id INTEGER PRIMARY KEY
)
|]
tableColumns <- getColumns dbName conn "items"
let
columnExpected =
ColumnEntry
{ column_name = "id"
, column_name_gql = "id"
, datatype = "INTEGER"
, datatype_gql = Just $ stringToGqlTypeName "Int"
, select_options = Nothing
, notnull = False
, isUnique = False
, isOmittable = True
, isGenerated = False
, dflt_value = Nothing
, primary_key = True
}
P.lastMay tableColumns `shouldBe` Just columnExpected
it "correctly parses generated columns" $ do
let dbName = "generated-columns.db"
withTestDbConn shouldSaveDbs dbName $ \conn -> do
execute_
conn
[sql|
CREATE TABLE "generated_columns" (
"start" REAL NOT NULL,
"end" REAL NOT NULL,
"distance_km" REAL GENERATED ALWAYS AS ("end" - "start") STORED,
"distance_miles" REAL GENERATED ALWAYS AS (distance_km * 1.6) VIRTUAL
)
|]
tableColumns <- getColumns dbName conn "generated_columns"
let (generated, non_generated) =
-- => [ColumnDef]
tableColumns
-- => ([ColumnDef], [ColumnDef])
& List.partition (\c -> c.isGenerated)
-- => (Text, Text)
& P.bimap
(P.fmap column_name)
(P.fmap column_name)
-- We use `shouldMatchList` because the order does not matter
non_generated `shouldMatchList` ["start", "end", "rowid"]
generated `shouldMatchList` ["distance_km", "distance_miles"]
it "sorts the tables from the metadata table" $ do
getOrderOfLinkedList [("a", Nothing), ("b", Just "a"), ("c", Just "b")]
`shouldBe` ["a", "b", "c"]
getOrderOfLinkedList [("a", Nothing), ("c", Just "b"), ("b", Just "a")]
`shouldBe` ["a", "b", "c"]
getOrderOfLinkedList [("b", Just "a"), ("c", Just "b"), ("a", Nothing)]
`shouldBe` ["a", "b", "c"]
getOrderOfLinkedList [("a", Just "x"), ("c", Just "b"), ("b", Just "a")]
`shouldBe` ["x", "a", "b", "c"]
getOrderOfLinkedList [("c", Just "b"), ("b", Just "a"), ("a", Just "x")]
`shouldBe` ["x", "a", "b", "c"]
getOrderOfLinkedList [("a", Nothing), ("b", Just "a"), ("c", Nothing)]
`shouldBe` ["a", "b", "c"]
getOrderOfLinkedList [("a", Nothing), ("b", Nothing), ("c", Nothing)]
`shouldBe` ["a", "b", "c"]
getOrderOfLinkedList [("a", Nothing), ("b", Just "a"), ("d", Just "c")]
`shouldBe` ["a", "b", "c", "d"]
-- Nothing must always be first
getOrderOfLinkedList [("c", Just "b"), ("d", Just "c"), ("a", Nothing)]
`shouldBe` ["a", "b", "c", "d"]
-- Should *not* error out on cycles
getOrderOfLinkedList [("c", Just "a"), ("b", Just "a"), ("a", Just "b")]
`shouldBe` ["a", "b", "c"]
describe "REST API" $ do
describe "SQL" $ do
it "supports retrieving the schema" $ do
-- let query = "CREATE TABLE users (name TEXT, email TEXT);"
-- let dbPost = DatabasePost "test-db" (Just "test-team") "" (Just query)
-- Right schemaResult <-
-- runHandler $
-- apiDatabaseSchemaGetHandler ctx "TODO"
-- T.strip schemaResult `shouldBe` query
pendingWith "Create database first"
it "supports executing an SQL query" $ do
let dbId = "api-sql-query"
withDataDbConn dbId $ \_ -> do
Right result <-
runHandler $
sqlQueryPostHandler
PragmaConf.defaultConf
("_TEST_" <> dbId)
SQLPost{query = "SELECT TRUE, 123, 'test'"}
result.rows
`shouldBe` [ KeyMap.fromList
[ ("TRUE", Number 1)
, ("123", Number 123)
, ("'test'", "test")
]
]
result.affectedTables `shouldMatchList` []
it "return columns in the requested order" $ do
-- Even though JSON objects are unordered by definition,
-- the fields (columns) must be returned in the requested order
-- as Elm relies on it for decoding.
let dbId = "api-sql-col-order"
withDataDbConn dbId $ \_ -> do
Right result <-
runHandler $
sqlQueryPostHandler
PragmaConf.defaultConf
("_TEST_" <> dbId)
SQLPost{query = "SELECT 0 AS b, 0 AS a"}
(result & encodeToText & T.unpack)
`shouldContain` "[{\"b\":0,\"a\":0}]"
result.affectedTables `shouldMatchList` []
it "supports using math functions" $ do
let dbId = "api-sql-math-query"
withDataDbConn dbId $ \_ -> do
Right result <-
runHandler $
sqlQueryPostHandler
PragmaConf.defaultConf
("_TEST_" <> dbId)
SQLPost{query = "SELECT abs(floor(cos(2 * pi() / 3)))"}
result.rows
`shouldBe` [ KeyMap.singleton
"abs(floor(cos(2 * pi() / 3)))"
(Number 1.0)
]
result.affectedTables `shouldMatchList` []
-- The following few tests verify that different operations return
-- the proper set of affected tables. This query creates a completely
-- unrelated table just to ensure it is not getting returned by the
-- methods tested below
let createUnrelatedTable = do
[sql|
CREATE TABLE IF NOT EXISTS todos (
title TEXT,
content TEXT,
done INTEGER
)
|]
-- This query creates a table commonly used by the following few tests.
let createNotesTable = do
[sql|
CREATE TABLE IF NOT EXISTS notes (
content TEXT
)
|]
it "should not allow rowid references" $ do
let dbId = "api-sql-rowid-references"
let query = "CREATE TABLE foo ( bar TEXT references goo(rowid) )"
withDataDbConn dbId $ \_ -> do
Right result <-
runHandler $
sqlQueryPostHandler
PragmaConf.defaultConf
("_TEST_" <> dbId)
SQLPost{query = query}
let
expectedMessage =
"Column 'bar' references the rowid column of table 'goo'.\n"
<> "This is not supported by SQLite:\n"
<> "https://www.sqlite.org/foreignkeys.html"
result.errors `shouldBe` [expectedMessage]
it "should return no affected tables on a simple select" $ do
let dbId = "api-sql-simple-select"
withDataDbConn dbId $ \conn -> do
execute_ conn createUnrelatedTable
execute_ conn createNotesTable
execute_
conn
[sql|
INSERT INTO notes VALUES ("hello")
|]
Right result <-
runHandler $
sqlQueryPostHandler
PragmaConf.defaultConf
("_TEST_" <> dbId)
SQLPost{query = "SELECT * from notes"}
result.rows
`shouldBe` [KeyMap.singleton "content" "hello"]
result.affectedTables `shouldMatchList` []
it "should return the correct affected tables when creating tables" $ do
let dbId = "api-sql-simple-create"
withDataDbConn dbId $ \conn -> do
execute_ conn createUnrelatedTable
Right result <-
runHandler $
sqlQueryPostHandler
PragmaConf.defaultConf
("_TEST_" <> dbId)
SQLPost
{ query = SS.fromQuery createNotesTable
}
result.affectedTables
`shouldMatchList` ["notes"]
it "should return the correct affected tables when dropping tables" $ do
let dbId = "api-sql-simple-drop"
withDataDbConn dbId $ \conn -> do
execute_ conn createUnrelatedTable
execute_ conn createNotesTable
Right result <-
runHandler $
sqlQueryPostHandler
PragmaConf.defaultConf
("_TEST_" <> dbId)
SQLPost{query = "DROP TABLE notes"}
result.affectedTables `shouldMatchList` ["notes"]
it "should return the correct affected tables when editing tables" $ do
let dbId = "api-sql-add-column"
withDataDbConn dbId $ \conn -> do
execute_ conn createUnrelatedTable
execute_ conn createNotesTable
Right result <-
runHandler $
sqlQueryPostHandler
PragmaConf.defaultConf
("_TEST_" <> dbId)
SQLPost
{ query =
"ALTER TABLE notes ADD COLUMN title TEXT"
}
result.affectedTables `shouldMatchList` ["notes"]
it "should mark every table as affected when changes are detected" $ do
let dbId = "api-sql-insert-values"
withDataDbConn dbId $ \conn -> do
execute_ conn createUnrelatedTable
execute_ conn createNotesTable
Right result <-
runHandler $
sqlQueryPostHandler
PragmaConf.defaultConf
("_TEST_" <> dbId)
SQLPost
{ query =
[raw| INSERT INTO "notes" VALUES ("hello") |]
}
result.affectedTables `shouldMatchList` ["notes", "todos"]
describe "Queries" $ do
it "supports retrieving data" $ do
conn <- open $ unpack dbPath
execute_
conn
[sql|
insert into users (name, email, created_utc)
values ('Adrian', 'adrian@example.com', '2021-01-01T00:00Z')
|]
tables <- getTables conn
schema <-
getDerivedSchema
defaultSchemaConf
conn
dbPath
tables
Right result <- graphql schema Nothing mempty "{ users { name } }"
Ae.encode result
`shouldBe` [gql|
{"data":{"users":[{"name":"Adrian"}]}}
|]
it "supports retrieving data from tables with special names" $ do
let testDbPath = testRoot </> "special_table_name.db"
removeIfExists testDbPath
let dbPathNorm = if shouldSaveDbs then testDbPath else ":memory:"
withRetryConn dbPathNorm $ \conn -> do
execute_
conn
[sql|
CREATE TABLE "name with-special$chars" (
name TEXT
)
|]
execute_
conn
[sql|
INSERT INTO "name with-special$chars" (name)
VALUES ('John')
|]
tables <- getTables conn
schema <-
getDerivedSchema
defaultSchemaConf
conn
dbPath
tables
Right result <-
graphql
schema
Nothing
mempty
"{ nameXX0withXXDspecialXX4chars { name } }"
Ae.encode result
`shouldBe` [gql|
{"data":{"nameXX0withXXDspecialXX4chars":[{"name":"John"}]}}
|]
describe "column names with special characters" $ do
let
dbPathSpaces :: FilePath = testRoot </> "spaces-test.db"
setupDatabaseSpaces = do
removeIfExists dbPathSpaces
conn <- open dbPathSpaces
execute_
conn
[sql|
CREATE TABLE IF NOT EXISTS test_entries (
id INTEGER PRIMARY KEY,
`column with spaces` TEXT
)
|]
execute_
conn
[sql|
INSERT INTO test_entries (id, `column with spaces`)
VALUES (0, 'Just a test')
|]
before_ setupDatabaseSpaces $ it "supports column names with spaces" $ do
conn <- open dbPathSpaces
tables <- getTables conn
schema <-
getDerivedSchema
defaultSchemaConf
conn
(pack dbPathSpaces)
tables
Right result <-
graphql
schema
Nothing
mempty
"{ test_entries { columnXX0withXX0spaces } }"
Ae.encode result
`shouldBe` rmSpaces
[raw|
{ "data": {
"test_entries": [
{ "columnXX0withXX0spaces": "Just a test" }
]
}}
|]
before_ setupDatabaseSpaces $
it "generates introspection schema for column names with spaces" $
do
conn <- open dbPathSpaces
tables <- getTables conn
schema <-
getDerivedSchema
defaultSchemaConf
conn
(pack dbPathSpaces)
tables
Right result <-
graphql
schema
Nothing
mempty
"{ __schema{ types { name fields { name } } } } }"
show (Ae.encode result) `shouldContain` "columnXX0withXX0spaces"
it "avoids column name remapping collisions" $ do
let dbPathSpaces = testRoot </> "spaces-collision-test.db"
removeIfExists dbPathSpaces
conn <- open dbPathSpaces
execute_
conn
[sql|
CREATE TABLE IF NOT EXISTS test_entries (
id INTEGER PRIMARY KEY,
`the column` TEXT,
`the_column` TEXT,
`the_column_1` TEXT,
`the_column_2` TEXT
)
|]
execute_
conn
[sql|
INSERT INTO test_entries
(id, `the column`, the_column, the_column_1, the_column_2)
VALUES
(0, 'with spaces', 'no spaces', 'no spaces 1', 'no spaces 2')
|]
tables <- getTables conn
schema <-
getDerivedSchema
defaultSchemaConf
conn
(pack dbPathSpaces)
tables
Right result <-
graphql
schema
Nothing
mempty
[gql|
{ test_entries {
theXX0column
the_column
the_column_1
the_column_2
}
}
|]
Ae.encode result
`shouldBe` rmSpaces
[raw|
{ "data": {
"test_entries": [
{ "theXX0column": "with spaces",
"the_column": "no spaces",
"the_column_1": "no spaces 1",
"the_column_2": "no spaces 2"
}
]
}}
|]
it "includes rowid and sorts by rowid" $ do
let dbPathSpaces = testRoot </> "rowid_test.db"
removeIfExists dbPathSpaces
conn <- open dbPathSpaces
execute_
conn
[sql|
CREATE TABLE IF NOT EXISTS "users" (
"email" TEXT NOT NULL UNIQUE PRIMARY KEY,
"number_of_logins" INTEGER
);
|]
execute_
conn
[sql|
INSERT INTO users (email, number_of_logins)
VALUES ('john@example.com', 0), ('eve@example.com', 4);
|]
tables <- getTables conn
schema <-
getDerivedSchema
defaultSchemaConf
conn
(pack dbPathSpaces)
tables
Right result <-
graphql
schema
Nothing
mempty
[gql|
{
users {
rowid
}
}
|]
Ae.encode result
`shouldBe` rmSpaces
[raw|
{
"data": {
"users": [
{ "rowid": 1 },
{ "rowid": 2 }
]
}
}
|]
it "supports aliases" $ do
conn <- open $ unpack dbPath
execute_
conn
[sql|
insert into users (name, email, created_utc)
values ('Adrian', 'adrian@example.com', '2021-01-01T00:00Z')
|]
let
query =
[gql|
{
userA: users { name }
userB: users { email }
}
|]
expected =
rmSpaces
[raw|
{"data":{
"userB":[{"email":"adrian@example.com"}],
"userA":[{"name":"Adrian"}]
}}
|]
tables <- getTables conn
schema <-
getDerivedSchema
defaultSchemaConf
conn
dbPath
tables
Right result <- graphql schema Nothing mempty query
Ae.encode result `shouldBe` expected
it "supports fragments" $ do
conn <- open $ unpack dbPath
execute_
conn
[sql|
insert into users (name, email, created_utc)
values ('Adrian', 'adrian@example.com', '2021-01-01T00:00Z')
|]
let
query =
[gql|
{
userA: users { ...basicFields }
userB: users { ...basicFields }
}
fragment basicFields on users {
name
email
}
|]
expected =
rmSpaces
[raw|
{ "data": {
"userB":[{"email":"adrian@example.com","name":"Adrian"}],
"userA":[{"email":"adrian@example.com","name":"Adrian"}]
}}
|]
tables <- getTables conn
schema <-
getDerivedSchema
defaultSchemaConf
conn
dbPath
tables
Right result <- graphql schema Nothing mempty query
Ae.encode result `shouldBe` expected
it "supports directives" $ do
conn <- open $ unpack dbPath
execute_
conn
[sql|
insert into users (name, email, created_utc)
values
('John', 'john@example.com', '2021-01-01T00:00Z'),
('Eve', 'eve@example.com', '2019-01-01T00:00Z')
|]
let
query =
[gql|
query DirectiveTest ($withName: Boolean!) {
users {
name @include(if: $withName)
}
}
|]
variables :: Object
variables =
fromMaybe mempty $ Ae.decode "{ \"withName\": true }"
expected =
rmSpaces
[raw|
{ "data": {
"users": [
{ "name": "John" },
{ "name": "Eve" }
]
}}
|]
tables <- getTables conn
schema <-
getDerivedSchema
defaultSchemaConf
conn
dbPath
tables
Right result <- graphql schema Nothing variables query
Ae.encode result `shouldBe` expected
it "supports retrieving records with a filter" $ do
conn <- open $ unpack dbPath
execute_
conn
[sql|
insert into users (name, email, created_utc)
values
('John', 'john@example.com', '2021-01-01T00:00Z'),
('Eve', 'eve@example.com', '2019-01-01T00:00Z')
|]
tables <- getTables conn
schema <-
getDerivedSchema
defaultSchemaConf
conn
dbPath
tables
Right result <-
graphql
schema
Nothing
mempty
[gql|
{
users (filter: {email: {eq: "eve@example.com"}}) {
name
}
}
|]
Ae.encode result
`shouldBe` "{\"data\":{\"users\":[{\"name\":\"Eve\"}]}}"
it "supports retrieving records with a filter over int and float" $ do
conn <- open $ unpack dbPath
execute_
conn
[sql|
insert into users (name, email, created_utc, progress)
values
('John', 'john@example.com', '2021-01-01T00:00Z', 0.7),
('Eve', 'eve@example.com', '2019-01-01T00:00Z', 0.4)
|]
tables <- getTables conn
schema <-
getDerivedSchema
defaultSchemaConf
conn
dbPath
tables
Right result1 <-
graphql
schema
Nothing
mempty
[gql|{
users (filter: {rowid: {eq: 2}}) {
name
}
}|]
Ae.encode result1
`shouldBe` "{\"data\":{\"users\":[{\"name\":\"Eve\"}]}}"
Right result2 <-
graphql
schema
Nothing
mempty
[gql|{
users (filter: {progress: {eq: 0.4}}) {
name
}
}|]
Ae.encode result2
`shouldBe` "{\"data\":{\"users\":[{\"name\":\"Eve\"}]}}"
it "supports retrieving records with a filter over boolean and null" $ do
let dbPathFilter = testRoot </> "filter_eq_boolean.db"
removeIfExists dbPathFilter
conn <- open dbPathFilter
execute_
conn
[sql|
CREATE TABLE IF NOT EXISTS "users" (
"name" TEXT,
"is_admin" BOOLEAN
);
|]
execute_
conn
[sql|
INSERT INTO USERS (name, is_admin)
VALUES
('John', TRUE),
('Eve', FALSE),
('Anna', NULL)
|]
tables <- getTables conn
schema <- getDerivedSchema defaultSchemaConf conn dbPath tables
Right result1 <-
graphql
schema
Nothing
mempty
[gql|{
users (filter: {is_admin: {eq: false}}) {
name
}
}|]
Ae.encode result1
`shouldBe` "{\"data\":{\"users\":[{\"name\":\"Eve\"}]}}"
Right result2 <-
graphql
schema
Nothing
mempty
[gql|{
users (filter: {is_admin: {eq: null}}) {
name
}
}|]
Ae.encode result2
`shouldBe` "{\"data\":{\"users\":[{\"name\":\"Anna\"}]}}"
it "supports retrieving records with like and ilike filter" $ do
withRetryConn (unpack dbPath) $ \conn -> do
execute_
conn
[sql|
insert into users (name, email, created_utc)
values
('John', 'john@example.com', '2021-01-01T00:00Z'),
('Anna', 'anna@EXAMPLE.COM', '2019-01-01T00:00Z'),
('Eve', 'eve@evil.com', '2019-01-01T00:00Z')
|]
tables <- getTables conn
schema <-
getDerivedSchema
defaultSchemaConf
conn
dbPath
tables
Right likeResult <-
graphql
schema
Nothing
mempty
[gql|
{
users (filter: {email: {like: "%example%"}}) {
name
}
}
|]
Ae.encode likeResult
`shouldBe` "{\"data\":{\"users\":[{\"name\":\"John\"}]}}"
Right ilikeResult <-
graphql
schema
Nothing
mempty
[gql|
{
users (filter: {email: {ilike: "%example%"}}) {
name
}
}
|]
Ae.encode ilikeResult
`shouldBe` "{\"data\":{\"users\":\
\[{\"name\":\"John\"},{\"name\":\"Anna\"}]}}"
it "supports retrieving records with several filters" $ do
withRetryConn (unpack dbPath) $ \conn -> do
execute_
conn
[sql|
insert into users (name, email, created_utc)
values
('John', 'john@example.com', '2021-01-01T00:00Z'),
('Anna', 'anna@example.com', '2019-01-01T00:00Z'),
('Eve', 'eve@evil.com', '2019-01-01T00:00Z')
|]
tables <- getTables conn
schema <-
getDerivedSchema
defaultSchemaConf
conn
dbPath
tables
Right likeResult <-
graphql
schema
Nothing
mempty
[gql|
{
users (
filter: {
email: { like: "%example%" },
name: { gt: "B" }
}
) {
name
}
}
|]
Ae.encode likeResult
`shouldBe` "{\"data\":{\"users\":[{\"name\":\"John\"}]}}"
it "supports mutating records with several filters" $ do
withRetryConn (unpack dbPath) $ \conn -> do
execute_
conn
[sql|
insert into users (name, email, created_utc)
values
('John', 'john@example.com', '2021-01-01T00:00Z'),
('Anna', 'anna@example.com', '2019-01-01T00:00Z'),
('Eve', 'eve@evil.com', '2019-01-01T00:00Z')
|]
tables <- getTables conn
schema <-
getDerivedSchema
defaultSchemaConf
conn
dbPath
tables
Right likeResult <-
graphql
schema
Nothing
mempty
[gql|
mutation UpdateEmailAddress {
update_users (
filter: {
email: { like: "%example%" }
name: { gt: "B" }
}
set: { email: "john@new.com" }
) {
affected_rows
returning {
email
}
}
}
|]
Ae.encode likeResult
`shouldBe` "{\"data\":{\"update_users\":\
\{\"affected_rows\":1,\
\\"returning\":[{\"email\":\"john@new.com\"}]}}}"
it "supports retrieving multi-type columns" $ do
withTestDbConn shouldSaveDbs "multi-type_columns.db" $ \conn -> do
execute_
conn
[sql|
CREATE VIEW "multi_type_column" AS
SELECT 1 AS col UNION
SELECT 2.2 AS col UNION
SELECT 'three' AS col UNION
SELECT NULL AS col
|]
tables <- getTables conn
schema <-
getDerivedSchema defaultSchemaConf conn dbPath tables
Right result1 <-
graphql
schema
Nothing
mempty
[gql|{
multi_type_column { col }
}|]
let expected =
rmSpaces
[raw|
{
"data": {
"multi_type_column": [
{ "col": null },
{ "col": "1" },
{ "col": "2.2" },
{ "col": "three" }
]
}
}
|]
Ae.encode result1 `shouldBe` expected
it "supports querying a single entry" $ do
conn <- open $ unpack dbPath
execute_
conn
[sql|
insert into users (name, email, created_utc)
values
('John', 'john@example.com', '2021-01-01T00:00Z'),
('Eve', 'eve@example.com', '2019-01-01T00:00Z')
|]
tables <- getTables conn
schema <- getDerivedSchema defaultSchemaConf conn dbPath tables
Right result <-
graphql
schema
Nothing
mempty
[gql|
{
users_by_pk (email: "eve@example.com") {
name
}
}
|]
pendingWith "Not implemented yet"
Ae.encode result
`shouldBe` "{\"data\":{\"users\":[{\"name\":\"Eve\"}]}}"
it "errors out on integer overflows" $ do
withTestDbConn shouldSaveDbs "integer-overflows.db" $ \conn -> do
execute_
conn
[sql|
CREATE TABLE test (
big INTEGER,
alsobig INTEGER
)
|]
execute_
conn
[sql|
INSERT INTO test(big, alsobig)
VALUES (8000000000, 9000000000)
|]
tables <- getTables conn
schema <- getDerivedSchema defaultSchemaConf conn dbPath tables
Right result <-
graphql
schema
Nothing
mempty
[gql|
{
test {
big,
alsobig
}
}
|]
let expected =
rmSpaces
[raw|
{
"data": {
"test": null
},
"errors": [{
"locations": [{
"column": 3,
"line": 2
}],
"message":
"user error (Multiple errors occurred:\nOn column \"big\": Integer 8000000000 would overflow. This happens because SQLite uses 64-bit ints, but GraphQL uses 32-bit ints. Use a Number (64-bit float) or Text column instead.\nOn column \"alsobig\": Integer 9000000000 would overflow. This happens because SQLite uses 64-bit ints, but GraphQL uses 32-bit ints. Use a Number (64-bit float) or Text column instead.\n)",
"path": ["test"]
}]
}
|]
Ae.encode result `shouldBe` expected
describe "Mutations" $ do
it "supports inserting data" $ do
let
query =
[gql|
mutation InsertUser {
insert_users(objects: [
{
name: "John",
email: "john@example.com",
created_utc: "2021-11-21T09:51Z"
},
{
email: "eve@example.com",
created_utc: "2021-11-21T09:51Z"
}
]) {
affected_rows
}
}
|]
expected =
rmSpaces
[raw|
{
"data": {
"insert_users": {
"affected_rows": 2
}
}
}
|]
conn <- open $ unpack dbPath
tables <- getTables conn
schema <- getDerivedSchema defaultSchemaConf conn dbPath tables
Right result <- graphql schema Nothing mempty query
Ae.encode result `shouldBe` expected
allUsers <- query_ conn "select * from users"
allUsers
`shouldBe` [
[ SQLText "John"
, SQLText "john@example.com"
, SQLText "2021-11-21T09:51Z"
, SQLNull
, SQLNull
]
,
[ SQLNull
, SQLText "eve@example.com"
, SQLText "2021-11-21T09:51Z"
, SQLNull
, SQLNull
]
]
it "supports inserting and retrieving booleans" $ do
let testDbPath = testRoot </> "boolean-test.db"
conn <- open testDbPath
execute_
conn
[sql|
CREATE TABLE IF NOT EXISTS checks (
id INTEGER PRIMARY KEY,
completed BOOLEAN DEFAULT (FALSE) NOT NULL
)
|]
execute_ conn "DELETE FROM checks"
execute_
conn
[sql|
INSERT INTO checks (id, completed)
VALUES (1, 0), (2, 1), (3, FALSE), (4, TRUE)
|]
tables <- getTables conn
schema <-
getDerivedSchema
defaultSchemaConf
conn
(T.pack testDbPath)
tables
let
mutation =
[gql|
mutation InsertChecks {
insert_checks(objects: [
{ id: 5, completed: true },
]) {
affected_rows
}
}
|]
expected =
rmSpaces
[raw|
{
"data": {
"insert_checks": {
"affected_rows": 1
}
}
}
|]
Right result <- graphql schema Nothing mempty mutation
Ae.encode result `shouldBe` expected
allUsers <- query_ conn "select * from checks"
allUsers
`shouldBe` [ [SQLInteger 1, SQLInteger 0]
, [SQLInteger 2, SQLInteger 1]
, [SQLInteger 3, SQLInteger 0]
, [SQLInteger 4, SQLInteger 1]
, [SQLInteger 5, SQLInteger 1]
]
let
query =
[gql|
query GetChecks {
checks { id, completed }
}
|]
expectedResult =
rmSpaces
[raw|
{"data":{"checks":[
{"id":1,"completed":false},
{"id":2,"completed":true},
{"id":3,"completed":false},
{"id":4,"completed":true},
{"id":5,"completed":true}
]}}
|]
Right queryResult <- graphql schema Nothing mempty query
Ae.encode queryResult `shouldBe` expectedResult
it "supports inserting empty records" $ do
let testDbPath = testRoot </> "empty-record-insertion.db"
SS.withConnection testDbPath $ \conn -> do
execute_
conn
[sql|
CREATE TABLE IF NOT EXISTS items (
id INTEGER PRIMARY KEY NOT NULL
)
|]
execute_ conn "DELETE FROM items"
tables <- getTables conn
schema <-
getDerivedSchema
defaultSchemaConf
conn
(T.pack testDbPath)
tables
let
mutation =
[gql|
mutation InsertItems {
insert_items(objects: [{}]) {
affected_rows
}
}
|]
expected =
rmSpaces
[raw|
{
"data": {
"insert_items": {
"affected_rows": 1
}
}
}
|]
Right result <- graphql schema Nothing mempty mutation
Ae.encode result `shouldBe` expected
allItems <- query_ conn "select * from items"
allItems `shouldBe` [[SQLInteger 1]]
it "treats NULL as a value when using 'neq' filters" $ do
conn <- open $ unpack dbPath
execute_
conn
[sql|
insert into users (name, email, created_utc)
values
(NULL, 'john@example.com', '2021-01-01T00:00Z'),
('Eve', 'eve@example.com', '2021-01-02T00:00Z')
|]
let
query =
[gql|
query {
users(filter: { name: { neq: "Eve" }}) {
name, email
}
}
|]
expected =
rmSpaces
[raw|{
"data": {
"users": [{
"name": null,
"email": "john@example.com"
}]
}
}|]
tables <- getTables conn
schema <- getDerivedSchema defaultSchemaConf conn dbPath tables
Right result <- graphql schema Nothing mempty query
Ae.encode result `shouldBe` expected
it "treats NULL as a value when using 'nin' filters" $ do
conn <- open $ unpack dbPath
execute_
conn
[sql|
insert into users (name, email, created_utc)
values
('Eve', 'eve@example.com', '2021-01-01T00:00Z'),
('Jon', 'jon@example.com', '2021-01-02T00:00Z'),
('Arbuckle', 'arbuckle@example.com', '2021-01-03T00:00Z'),
(NULL, 'adam@example.com', '2021-01-04T00:00Z')
|]
let
query =
[gql|
query {
users(filter: { name: { nin: ["Eve", "Arbuckle"]}}) {
name, email
}
}
|]
expected =
rmSpaces
[raw|{
"data": {
"users": [{
"name": "Jon",
"email": "jon@example.com"
}, {
"name": null,
"email": "adam@example.com"
}]
}
}|]
tables <- getTables conn
schema <- getDerivedSchema defaultSchemaConf conn dbPath tables
Right result <- graphql schema Nothing mempty query
Ae.encode result `shouldBe` expected
it "supports 'in' filters" $ do
conn <- open $ unpack dbPath
execute_
conn
[sql|
insert into users (name, email, created_utc)
values
('Eve', 'eve@example.com', '2021-01-01T00:00Z'),
('Jon', 'jon@example.com', '2021-01-02T00:00Z'),
('Arbuckle', 'arbuckle@example.com', '2021-01-03T00:00Z'),
(NULL, 'adam@example.com', '2021-01-04T00:00Z')
|]
let
query =
[gql|
query {
users(filter: { name: { in: ["Eve", "Arbuckle"]}}) {
name, email
}
}
|]
expected =
rmSpaces
[raw|{
"data": {
"users": [{
"name": "Eve",
"email": "eve@example.com"
}, {
"name": "Arbuckle",
"email": "arbuckle@example.com"
}]
}
}|]
tables <- getTables conn
schema <- getDerivedSchema defaultSchemaConf conn dbPath tables
Right result <- graphql schema Nothing mempty query
Ae.encode result `shouldBe` expected
it "supports inserting data and returning the created data" $ do
let
query =
[gql|
mutation InsertUsers {
insert_users(objects: [
{
name: "John",
email: "john@example.com",
created_utc: "2021-11-21T09:51Z"
}
]) {
affected_rows
returning {
rowid,
name
}
}
}
|]
expected =
rmSpaces
[raw|{
"data": {
"insert_users": {
"affected_rows": 1,
"returning": [
{
"rowid": 1,
"name": "John"
}
]
}
}
}|]
conn <- open $ unpack dbPath
tables <- getTables conn
schema <- getDerivedSchema defaultSchemaConf conn dbPath tables
Right result <- graphql schema Nothing mempty query
Ae.encode result `shouldBe` expected
it "supports updating data and returning the updated data" $ do
conn <- open $ unpack dbPath
execute_
conn
[sql|
insert into users (name, email, created_utc)
values
('John', 'john@update-test.com', '2021-01-01T00:00Z'),
('Eve', 'eve@update-test.com', '2021-01-02T00:00Z')
|]
let
query =
[gql|
mutation UpdateUsers {
update_users(
filter: { email: { eq: "eve@update-test.com" } },
set: { name: "New Name" }
) {
affected_rows
returning {
rowid
name
}
}
}
|]
expected =
rmSpaces
[raw|{
"data": {
"update_users": {
"affected_rows": 1,
"returning": [
{
"rowid": 2,
"name": "New Name"
}
]
}
}
}|]
tables <- getTables conn
schema <- getDerivedSchema defaultSchemaConf conn dbPath tables
Right result <- graphql schema Nothing mempty query
Ae.encode result `shouldBe` expected
it "supports upserting data" $ do
let
firstQuery =
[gql|
mutation {
insert_users(objects: [
{
email: "eve@example.com",
name: "Eve",
created_utc: "2021-11-21T09:51Z"
}
]) {
affected_rows
}
}
|]
-- the `where` clause is not required here, but is there
-- to make sure filters work properly.
secondQuery =
[gql|
mutation {
insert_users(
objects: {
email: "eve@example.com",
name: "Eveline",
created_utc: "2022-11-21T09:51Z"
},
on_conflict: {
constraint: email,
update_columns: [name, created_utc],
where: { created_utc: { eq: "2021-11-21T09:51Z" }}
}) {
returning { name }
}
}
|]
expected =
rmSpaces
[raw|
{
"data": {
"insert_users": {
"returning": [{
"name": "Eveline"
}]
}
}
}
|]
conn <- open $ unpack dbPath
tables <- getTables conn
schema <- getDerivedSchema defaultSchemaConf conn dbPath tables
Right _ <- graphql schema Nothing mempty firstQuery
Right result <- graphql schema Nothing mempty secondQuery
Ae.encode result `shouldBe` expected
allUsers <- query_ conn "select * from users"
let user =
[ SQLText "Eveline"
, SQLText "eve@example.com"
, SQLText "2022-11-21T09:51Z"
, SQLNull
, SQLNull
]
allUsers `shouldBe` [user]
it "fails on invalid upserts" $ do
let
firstQuery =
[gql|
mutation {
insert_users(objects: [
{
email: "eve@example.com",
name: "Eve",
created_utc: "2021-11-21T09:51Z"
}
]) {
affected_rows
}
}
|]
-- We specify the `progress` column on `update_columns`,
-- but do not provide an explicit value.
secondQuery =
[gql|
mutation {
insert_users(
objects: {
email: "eve@example.com",
name: "Eveline",
created_utc: "2022-11-21T09:51Z"
},
on_conflict: {
constraint: email,
update_columns: [name, created_utc, progress]
}) {
returning { name }
}
}
|]
expected :: Text
expected =
"user error (Column progress cannot be set on conflicts without being explicitly provided)"
conn <- open $ unpack dbPath
tables <- getTables conn
schema <- getDerivedSchema defaultSchemaConf conn dbPath tables
Right _ <- graphql schema Nothing mempty firstQuery
Just err <-
catchAll
(Nothing <$ graphql schema Nothing mempty secondQuery)
(pure . Just . show)
err `shouldBe` expected
it "supports deleting data and returning the deleted data" $ do
conn <- open $ unpack 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')
|]
let
query =
[gql|
mutation DeleteUsers {
delete_users(
filter: { email: { eq: "eve@del-test.com" } }
) {
affected_rows
returning {
rowid
name
}
}
}
|]
expected =
rmSpaces
[raw|{
"data": {
"delete_users": {
"affected_rows": 1,
"returning": [
{
"rowid": 2,
"name": "Eve"
}
]
}
}
}|]
tables <- getTables conn
schema <- getDerivedSchema defaultSchemaConf conn dbPath tables
Right result <- graphql schema Nothing mempty query
Ae.encode result `shouldBe` expected
it "supports parsing SQL queries" $ do
let
sqlQuery =
[raw|
CREATE TABLE IF NOT EXISTS checks (
color TEXT CHECK ( color IN ('red', 'green', 'blue') ) NOT NULL
)
|]
sqlQueryParsed :: Text =
[raw|
Right (
CreateTable
[Name Nothing "checks"]
[TableColumnDef
(ColumnDef
(Name Nothing "color")
(TypeName [Name Nothing "TEXT"])
Nothing
[ ColConstraintDef Nothing
(ColCheckConstraint
(In True
(Iden [Name Nothing "color"])
(InList
[ StringLit "'" "'" "red"
, StringLit "'" "'" "green"
, StringLit "'" "'" "blue"
]
)
)
)
, ColConstraintDef Nothing ColNotNullConstraint
]
)
]
)
|]
rmSpacesText txt =
txt
& T.replace " " ""
& T.replace "\n" ""
rmSpacesText (show $ parseSql sqlQuery)
`shouldBe` rmSpacesText sqlQueryParsed
it "supports inserting and retrieving single select fields" $ do
let testDbPath = testRoot </> "single-select-test.db"
conn <- open testDbPath
let
sqlQuery =
[raw|
CREATE TABLE IF NOT EXISTS checks (
color TEXT CHECK ( color IN ('red', 'green', 'blue') )
)
|]
execute_ conn $ SS.Query sqlQuery
execute_ conn "DELETE FROM checks"
execute_
conn
[sql|
INSERT INTO checks (color)
VALUES ('red')
|]
tables <- getTables conn
schema <-
getDerivedSchema
defaultSchemaConf
conn
(T.pack testDbPath)
tables
-- tableColumns <- getColumns testDbPath conn "checks"
let
mutation =
[gql|
mutation {
insert_checks(objects: [
{ color: "green" },
]) {
affected_rows
}
}
|]
expected =
rmSpaces
[raw|
{
"data": {
"insert_checks": {
"affected_rows": 1
}
}
}
|]
Right result <- graphql schema Nothing mempty mutation
Ae.encode result `shouldBe` expected
allColors <- query_ conn "select * from checks"
allColors `shouldBe` [[SQLText "red"], [SQLText "green"]]
let
query =
[gql|
query {
checks { color }
}
|]
expectedResult =
rmSpaces
[raw|
{ "data": {
"checks": [
{"color": "red"},
{"color": "green"}
]
} }
|]
Right queryResult <- graphql schema Nothing mempty query
Ae.encode queryResult `shouldBe` expectedResult
it "supports simultaneous inserts" $ do
conn <- open $ unpack dbPath
let
query =
[gql|
mutation InsertObjects {
insert_users(objects: [
{
email: "john@example.com",
created_utc: "2021-11-21T09:51Z",
}
]) {
affected_rows
}
insert_songs(objects: [
{
name: "Best Song",
duration_seconds: 125,
}
]) {
affected_rows
}
}
|]
expected =
rmSpaces
[raw|
{
"data": {
"insert_users": {
"affected_rows": 1
},
"insert_songs": {
"affected_rows": 1
}
}
}
|]
tables <- getTables conn
schema <- getDerivedSchema defaultSchemaConf conn dbPath tables
Right result <- graphql schema Nothing mempty query
Ae.encode result `shouldBe` expected
allUsers <- query_ conn "select * from songs"
allUsers `shouldBe` [[SQLText "Best Song", SQLInteger 125]]
it "supports simultaneous updates" $ do
conn <- open $ unpack dbPath
execute_
conn
[sql|
insert into users (name, email, created_utc)
values
('John', 'john@update-test.com', '2021-01-01T00:00Z'),
('Eve', 'eve@update-test.com', '2021-01-02T00:00Z')
|]
let
query =
[gql|
mutation UpdateUsers {
john_update: update_users(
filter: { email: { eq: "john@update-test.com" } }
set: { name: "John New" }
) {
affected_rows
}
eve_update: update_users(
filter: { email: { eq: "eve@update-test.com" } }
set: { name: "Eve New" }
) {
affected_rows
}
}
|]
expected =
rmSpaces
[raw|
{
"data": {
"john_update": {
"affected_rows": 1
},
"eve_update": {
"affected_rows": 1
}
}
}
|]
tables <- getTables conn
schema <- getDerivedSchema defaultSchemaConf conn dbPath tables
Right result <- graphql schema Nothing mempty query
Ae.encode result `shouldBe` expected
allUsers <- query_ conn "select name from users"
allUsers
`shouldBe` [ [SQLText "John New"]
, [SQLText "Eve New"]
]
it "supports variables" $ do
let
query =
[gql|
mutation InsertUsers ($objects: [users_insert_input]) {
insert_users(objects: $objects) {
affected_rows
}
}
|]
variables :: Object
variables =
fromMaybe mempty $
Ae.decode
[raw|
{
"objects": [
{
"email": "new.user@example.org",
"created_utc" : "2022-01-29T14:22Z"
}
]
}
|]
expected =
rmSpaces
[raw|
{
"data": {
"insert_users": {
"affected_rows": 1
}
}
}
|]
conn <- open $ unpack dbPath
tables <- getTables conn
schema <- getDerivedSchema defaultSchemaConf conn dbPath tables
Right result <- graphql schema Nothing variables query
Ae.encode result `shouldBe` expected
it "correctly converts between GraphQL and SQLite floats" $ do
conn <- open (testRoot </> "float-test.db")
execute_
conn
[sql|
CREATE TABLE IF NOT EXISTS loaders (
id INTEGER PRIMARY KEY,
progress REAL NOT NULL
)
|]
execute_ conn "DELETE FROM loaders"
execute_
conn
[sql|
INSERT INTO loaders (id, progress)
VALUES (1, 0), (2, 0.1), (3, -0.1), (4, 123.456)
|]
tables <- getTables conn
schema <- getDerivedSchema defaultSchemaConf conn dbPath tables
let
mutation =
[gql|
mutation InsertLoaders {
insert_loaders(objects: [
{ id: 5, progress: 1.23 },
]) {
affected_rows
}
}
|]
expected =
rmSpaces
[raw|
{
"data": {
"insert_loaders": {
"affected_rows": 1
}
}
}
|]
Right result <- graphql schema Nothing mempty mutation
Ae.encode result `shouldBe` expected
allUsers <- query_ conn "select * from loaders"
allUsers
`shouldBe` [ [SQLInteger 1, SQLFloat 0.0]
, [SQLInteger 2, SQLFloat 0.1]
, [SQLInteger 3, SQLFloat (-0.1)]
, [SQLInteger 4, SQLFloat 123.456]
, [SQLInteger 5, SQLFloat 1.23]
]
let
query =
[gql|
query GetLoaders {
loaders { id, progress }
}
|]
expectedResult :: Object
expectedResult =
fromMaybe mempty $
Ae.decode
[raw|
{ "data": { "loaders": [
{ "id": 1, "progress": 0 },
{ "id": 2, "progress": 0.1 },
{ "id": 3, "progress": -0.1 },
{ "id": 4, "progress": 123.456 },
{ "id": 5, "progress": 1.23 }
]}}
|]
Right queryResult <- graphql schema Nothing mempty query
queryResult `shouldBe` expectedResult
-- This particular case used to fail in a previous ticket
it "correctly roundtrips floats inserted using graphql and retrieved using REST" $ do
let dbId = "float-roundtrip-test"
withDataDbConn dbId $ \conn -> do
SS.execute_
conn
[sql|
CREATE TABLE IF NOT EXISTS loaders (
progress REAL NOT NULL
)
|]
tables <- getTables conn
schema <-
getDerivedSchema
defaultSchemaConf
conn
("_TEST_" <> dbId)
tables
let
mutation =
[gql|
mutation InsertLoaders {
insert_loaders(objects: [
{ progress: 1.23000 },
]) {
affected_rows
}
}
|]
expected =
rmSpaces
[raw|
{
"data": {
"insert_loaders": {
"affected_rows": 1
}
}
}
|]
Right result <- graphql schema Nothing mempty mutation
Ae.encode result `shouldBe` expected
Right restResult <-
runHandler $
sqlQueryPostHandler
PragmaConf.defaultConf
("_TEST_" <> dbId)
SQLPost{query = "SELECT * from loaders"}
restResult.rows
`shouldBe` [ KeyMap.singleton
"progress"
(Number 1.23)
]
it "supports updating data" $ do
conn <- open $ unpack dbPath
execute_
conn
[sql|
insert into users (name, email, created_utc)
values
('John', 'john@example.com', '2021-01-01T00:00Z'),
('Eve', 'eve@example.com', '2018-01-01T00:00Z')
|]
let
query =
[gql|
mutation UpdateUser {
update_users(
filter: {email: {eq: "eve@example.com"}},
set: {
name: "Liz"
}
) {
affected_rows
}
}
|]
expected =
rmSpaces
[raw|
{
"data": {
"update_users": {
"affected_rows": 1
}
}
}
|]
tables <- getTables conn
schema <- getDerivedSchema defaultSchemaConf conn dbPath tables
Right result <- graphql schema Nothing mempty query
Ae.encode result `shouldBe` expected
remainingUsers <-
query_
conn
"select * from users where email = 'eve@example.com'"
remainingUsers
`shouldBe` [
[ SQLText "Liz"
, SQLText "eve@example.com"
, SQLText "2018-01-01T00:00Z"
, SQLNull
, SQLNull
]
]
it "supports deleting data by text id" $ do
conn <- open $ unpack dbPath
execute_
conn
[sql|
insert into users (name, email, created_utc)
values
('John', 'john@example.com', '2021-01-01T00:00Z'),
('Eve', 'eve@example.com', '2019-01-01T00:00Z')
|]
let
query =
[gql|
mutation DeleteUsers {
delete_users(filter: {email: {eq: "eve@example.com"}}) {
affected_rows
}
}
|]
expected =
rmSpaces
[raw|
{
"data": {
"delete_users": {
"affected_rows": 1
}
}
}
|]
tables <- getTables conn
schema <- getDerivedSchema defaultSchemaConf conn dbPath tables
Right result <- graphql schema Nothing mempty query
Ae.encode result `shouldBe` expected
remainingUsers <- query_ conn "select * from users"
remainingUsers
`shouldBe` [
[ SQLText "John"
, SQLText "john@example.com"
, SQLText "2021-01-01T00:00Z"
, SQLNull
, SQLNull
]
]
it "supports deleting data by integer id" $ do
conn <- open $ unpack dbPath
execute_
conn
[sql|
insert into users (name, email, created_utc)
values
('John', 'john@example.com', '2021-01-01T00:00Z'),
('Eve', 'eve@example.com', '2019-01-01T00:00Z')
|]
let
query =
[gql|
mutation DeleteUsers {
delete_users(filter: {rowid: {eq: 2}}) {
affected_rows
}
}
|]
expected =
rmSpaces
[raw|{
"data": {
"delete_users": {
"affected_rows": 1
}
}
}|]
tables <- getTables conn
schema <- getDerivedSchema defaultSchemaConf conn dbPath tables
Right result <- graphql schema Nothing mempty query
Ae.encode result `shouldBe` expected
remainingUsers <- query_ conn "select * from users"
remainingUsers
`shouldBe` [
[ SQLText "John"
, SQLText "john@example.com"
, SQLText "2021-01-01T00:00Z"
, SQLNull
, SQLNull
]
]
it "returns error on foreign key constraint violation" $ do
withTestDbConn shouldSaveDbs (testRoot </> "foreign_key_constraint.db") $
\conn -> do
execute_
conn
[sql|
CREATE TABLE artist(
id INTEGER PRIMARY KEY,
name TEXT
)
|]
execute_
conn
[sql|
INSERT INTO artist (id, name)
VALUES (1, 'Artist 1')
|]
execute_
conn
[sql|
CREATE TABLE track(
id INTEGER,
name TEXT,
artistId INTEGER, -- Must map to an artist.id
FOREIGN KEY(artistId) REFERENCES artist(id)
)
|]
tables <- getTables conn
schema <-
getDerivedSchema defaultSchemaConf conn dbPath tables
let invalidQuery =
[gql|
mutation InsertTrack {
insert_track(objects: [
{
id: 1,
name: "Track 1",
artistId: 2
}
]) {
affected_rows
}
}
|]
Right result <- graphql schema Nothing mempty invalidQuery
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" ]
}
]
}|]
Ae.encode result `shouldBe` expected
describe "Introspection" $ do
it "creates JSON object for GQL types" $ do
let
tableName = "example_table"
actual =
createType
tableName
"Description of field"
[] -- No arguments
["NON_NULL", "LIST", "NON_NULL", "OBJECT"]
tableName
expected =
GQL.Object $
HashMap.fromList
[ ("name", GQL.String tableName)
, ("description", "Description of field")
,
( "type"
, GQL.Object $
HashMap.fromList
[ ("kind", "NON_NULL")
,
( "ofType"
, GQL.Object $
HashMap.fromList
[ ("kind", "LIST")
,
( "ofType"
, GQL.Object $
HashMap.fromList
[ ("kind", "NON_NULL")
,
( "ofType"
, GQL.Object $
HashMap.fromList
[ ("kind", "OBJECT")
, ("name", GQL.String tableName)
]
)
]
)
]
)
]
)
]
actual `shouldBe` expected
describe "Query" $ do
it "supports a minimal introspection query" $ do
let
introspectionQuery :: Text
introspectionQuery =
[gql|
query IntrospectionQuery {
__schema {
queryType { name }
}
}
|]
expected =
rmSpaces
[raw|
{
"data": {
"__schema": {
"queryType": {
"name": "Query"
}
}
}
}
|]
conn <- open $ unpack dbPath
tables <- getTables conn
schema <-
getDerivedSchema defaultSchemaConf conn dbPath tables
Right result <- graphql schema Nothing mempty introspectionQuery
Ae.encode result `shouldBe` expected
it "supports an optional filter argument" $ do
let
introspectionQuery :: Text
introspectionQuery =
[gql|
query IntrospectionQuery {
__schema {
queryType {
name
fields {
name
args {
name
type {
name
}
}
}
}
}
}
|]
expected =
rmSpaces
[raw|{
"data": {
"__schema": {
"queryType": {
"name": "Query",
"fields": [
{
"name": "users",
"args": [
{ "name": "filter",
"type": { "name": "users_filter" }
},
{ "name": "order_by",
"type": { "name": null }
},
{ "name": "limit",
"type": { "name": "Int" }
},
{ "name": "offset",
"type": { "name": "Int" }
}
]
},
{
"name": "songs",
"args": [
{ "name": "filter",
"type": { "name": "songs_filter" }
},
{ "name": "order_by",
"type": { "name": null }
},
{ "name": "limit",
"type": { "name": "Int" }
},
{ "name": "offset",
"type": { "name": "Int" }
}
]
}
]
}
}
}
}|]
conn <- open $ unpack dbPath
tables <- getTables conn
schema <-
getDerivedSchema defaultSchemaConf conn dbPath tables
Right result <- graphql schema Nothing mempty introspectionQuery
Ae.encode result `shouldBe` expected
it "doesn't allow writeonly tokens to read data" $ do
let
introspectionQuery :: Text
introspectionQuery =
[gql|
query IntrospectionQuery {
__schema {
queryType { name }
}
}
|]
expected =
rmSpaces
[raw|
{
"data": null,
"errors": [{
"locations": [{ "column":3, "line":2 }],
"message": "user error (Cannot read field using writeonly access code)",
"path": ["__schema"]
}]
}
|]
schema <- withRetryConn (unpack dbPath) $ \conn -> do
tables <- getTables conn
getDerivedSchema
defaultSchemaConf{accessMode = WriteOnly}
conn
dbPath
tables
Right response <-
graphql schema Nothing mempty introspectionQuery
Ae.encode response `shouldBe` expected
describe "Mutation" $ do
it "supports introspection queries" $ do
let
introspectionQuery :: Text
introspectionQuery =
[gql|
query IntrospectionQuery {
__schema {
mutationType {
name
fields {
name
args {
name
}
}
}
}
}
|]
expected =
rmSpaces
[raw|
{
"data": {
"__schema": {
"mutationType": {
"name": "Mutation",
"fields": [
{
"name": "insert_users",
"args": [ { "name": "objects" }, { "name": "on_conflict" } ]
},
{
"name": "update_users",
"args": [
{ "name": "filter" },
{ "name": "set" }
]
},
{
"name": "delete_users",
"args": [ { "name": "filter" } ]
},
{
"name": "insert_songs",
"args": [ { "name": "objects" }, { "name": "on_conflict" } ]
},
{
"name": "update_songs",
"args": [
{ "name": "filter" },
{ "name": "set" }
]
},
{
"name": "delete_songs",
"args": [ { "name": "filter" } ]
}
]
}
}
}
}
|]
conn <- open $ unpack dbPath
tables <- getTables conn
schema <-
getDerivedSchema defaultSchemaConf conn dbPath tables
Right result <- graphql schema Nothing mempty introspectionQuery
Ae.encode result `shouldBe` expected
it "supports __typename on root query" $ do
let
introspectionQuery =
[gql|
query TypeName {
__typename
}
|]
expected =
rmSpaces
[raw|
{
"data": {
"__typename" : "Query"
}
}
|]
conn <- open $ unpack dbPath
tables <- getTables conn
schema <- getDerivedSchema defaultSchemaConf conn dbPath tables
Right result <- graphql schema Nothing mempty introspectionQuery
Ae.encode result `shouldBe` expected
it "returns fields for {query,mutation,subscription}Type" $ do
let
introspectionQuery =
[gql|
query {
__schema {
queryType { fields { name } }
mutationType { fields { name } }
subscriptionType { fields { name } }
}
}
|]
expected =
rmSpaces
[raw|
{
"data": {
"__schema": {
"queryType": {
"fields": [
{ "name": "users" },
{ "name": "songs" }
]
},
"subscriptionType": null,
"mutationType": {
"fields": [
{ "name": "insert_users" },
{ "name": "update_users" },
{ "name": "delete_users" },
{ "name": "insert_songs" },
{ "name": "update_songs" },
{ "name": "delete_songs" }
]
}
}
}
}
|]
conn <- open $ unpack dbPath
tables <- getTables conn
schema <-
getDerivedSchema defaultSchemaConf conn dbPath tables
Right result <- graphql schema Nothing mempty introspectionQuery
Ae.encode result `shouldBe` expected
it "supports __typename fields" $ do
let
introspectionQuery =
[gql|
query UsersTypeName {
users {
__typename
}
}
|]
expected =
rmSpaces
[raw|
{
"data": {
"users": [
{ "__typename" : "users_row" }
]
}
}
|]
conn <- open $ unpack dbPath
execute_
conn
[sql|
insert into users (name, email, created_utc)
values ('John', 'john@example.com', '2022-01-01T00:00Z')
|]
tables <- getTables conn
schema <- getDerivedSchema defaultSchemaConf conn dbPath tables
Right result <- graphql schema Nothing mempty introspectionQuery
Ae.encode result `shouldBe` expected
it "returns types" $ do
let
introspectionQuery =
[gql|
query {
__schema {
types {
kind
name
}
}
}
|]
expected =
rmSpaces
[raw|
{
"data": {
"__schema": {
"types": [
{ "kind": "OBJECT", "name": "users_row" },
{ "kind": "OBJECT", "name": "users_mutation_response" },
{ "kind": "INPUT_OBJECT", "name": "users_insert_input" },
{ "kind": "ENUM", "name": "users_column" },
{ "kind": "INPUT_OBJECT", "name": "users_upsert_on_conflict" },
{ "kind": "INPUT_OBJECT", "name": "users_set_input" },
{ "kind": "INPUT_OBJECT", "name": "users_filter" },
{ "kind": "INPUT_OBJECT", "name": "users_order_by" },
{ "kind": "OBJECT", "name": "songs_row" },
{ "kind": "OBJECT", "name": "songs_mutation_response" },
{ "kind": "INPUT_OBJECT", "name": "songs_insert_input" },
{ "kind": "ENUM", "name": "songs_column" },
{ "kind": "INPUT_OBJECT", "name": "songs_upsert_on_conflict" },
{ "kind": "INPUT_OBJECT", "name": "songs_set_input" },
{ "kind": "INPUT_OBJECT", "name": "songs_filter" },
{ "kind": "INPUT_OBJECT", "name": "songs_order_by" },
{ "kind": "INPUT_OBJECT", "name": "IntComparison" },
{ "kind": "INPUT_OBJECT", "name": "FloatComparison" },
{ "kind": "INPUT_OBJECT", "name": "StringComparison" },
{ "kind": "INPUT_OBJECT", "name": "BooleanComparison" },
{ "kind": "ENUM", "name": "OrderingTerm" },
{ "kind": "OBJECT", "name": "Query" },
{ "kind": "OBJECT", "name": "Mutation" },
{ "kind": "SCALAR", "name": "Boolean" },
{ "kind": "SCALAR", "name": "Int" },
{ "kind": "SCALAR", "name": "Float" },
{ "kind": "SCALAR", "name": "String" },
{ "kind": "SCALAR", "name": "ID" },
{ "kind": "SCALAR", "name": "Upload" },
{ "kind": "OBJECT", "name": "__Schema" },
{ "kind": "OBJECT", "name": "__Type" },
{ "kind": "ENUM", "name": "__TypeKind" },
{ "kind": "OBJECT", "name": "__Field" },
{ "kind": "OBJECT", "name": "__InputValue" },
{ "kind": "OBJECT", "name": "__EnumValue" },
{ "kind": "OBJECT", "name": "__Directive" },
{ "kind": "ENUM", "name": "__DirectiveLocation" }
]
}
}
}
|]
conn <- open $ unpack dbPath
tables <- getTables conn
schema <- getDerivedSchema defaultSchemaConf conn dbPath tables
Right result <- graphql schema Nothing mempty introspectionQuery
Ae.encode result `shouldBe` expected
it "returns directives on __schema" $ do
let
introspectionQuery :: Text =
[gql|
query UsersTypeName {
__schema {
directives {
name
description
locations
args {
name
description
defaultValue
type { ...TypeRef }
}
}
}
}
fragment TypeRef on __Type {
kind
name
ofType {
kind
name
ofType {
kind
name
ofType {
kind
name
ofType {
kind
name
ofType {
kind
name
ofType {
kind
name
ofType {
kind
name
}
}
}
}
}
}
}
}
|]
expected =
rmSpaces
[raw|
{
"data": {
"__schema": {
"directives": [
{
"name": "skip",
"args": [
{
"name": "if",
"defaultValue": null,
"type": {
"kind": "NON_NULL",
"name": null,
"ofType": {
"kind":"SCALAR",
"name":"Boolean",
"ofType":null
}
},
"description": "Skipped when true."
}
],
"locations": [
"INLINE_FRAGMENT",
"FRAGMENT_SPREAD",
"FIELD"
],
"description": "Directs the executor to skip this field or fragment when the `if` argument is true."
},
{
"name": "include",
"args": [
{
"name": "if",
"defaultValue": null,
"type": {
"kind": "NON_NULL",
"name": null,
"ofType": {
"kind":"SCALAR",
"name":"Boolean",
"ofType":null
}
},
"description": "Included when true."
}
],
"locations": [
"INLINE_FRAGMENT",
"FRAGMENT_SPREAD",
"FIELD"
],
"description":
"Directs the executor to include this field or fragment only when the `if` argument is true."
},
{
"name": "deprecated",
"args": [
{
"name": "reason",
"defaultValue": "\"No longer supported\"",
"type": {
"kind": "SCALAR",
"name": "String",
"ofType": null
},
"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/)."
}
],
"locations": [
"ENUM_VALUE",
"FIELD_DEFINITION"
],
"description":
"Marks an element of a GraphQL schema as no longer supported."
}
]
}
}
}
|]
conn <- open $ unpack dbPath
tables <- getTables conn
schema <- getDerivedSchema defaultSchemaConf conn dbPath tables
Right result <- graphql schema Nothing mempty introspectionQuery
Ae.encode result `shouldBe` expected
it "supports a full introspection query" $ do
gqlFile <- makeAbsolute $ testRoot </> "introspection_query.gql"
introspectionQuery <- readFile gqlFile
jsonFile <- makeAbsolute $ testRoot </> "introspection_result.json"
expected <- readFile jsonFile
conn <- open $ unpack dbPath
tables <- getTables conn
schema <- getDerivedSchema defaultSchemaConf conn dbPath tables
Right result <- graphql schema Nothing mempty introspectionQuery
Ae.encode result `shouldBe` rmSpaces expected
deleteDbEntries :: Text -> IO ()
deleteDbEntries databasePath = do
conn <- open $ unpack databasePath
execute_ conn "delete from users"
execute_ conn "delete from songs"
main :: IO ()
main = do
cwd <- getWorkingDirectory
createDirectoryIfMissing True (".." </> "data" </> "TEST" </> "data")
changeWorkingDirectory (cwd </> ".." </> "data" </> "TEST")
removeIfExists $ unpack dbPath
withRetryConn (unpack dbPath) $ \conn -> do
createUsersTable conn
createSongsTable conn
Hspec.hspec $ before_ (deleteDbEntries dbPath) testSuite
View git blame Copy permalink