hasura/graphql-engine
1
0
Fork 0
mirror of https://github.com/hasura/graphql-engine.git synced 2024-12-14 08:02:15 +03:00
Code Issues Projects Releases Wiki Activity

Enable and test remote relationships from remote schemas.

Browse Source 
### Description

This is it! This PR enables the Metadata API for remote relationships from remote schemas, adds tests, ~~adds documentation~~, adds an entry to the Changelog. This is the release PR that enables the feature.

### Checklist
- [ ] Tests:
  - [x] RS-to-Postgres (high level)
  - [x] RS-to-RS (high level)
  - [x] From RS specifically (testing for edge cases)
  - [x] Metadata API tests
  - [ ] Unit testing the actual engine?
- [x] Changelog entry
- [ ] Documentation?

PR-URL: https://github.com/hasura/graphql-engine-mono/pull/3974
Co-authored-by: Vamshi Surabhi <6562944+0x777@users.noreply.github.com>
Co-authored-by: Vishnu Bharathi <4211715+scriptnull@users.noreply.github.com>
Co-authored-by: jkachmar <8461423+jkachmar@users.noreply.github.com>
GitOrigin-RevId: c9aebf12e6eebef8d264ea831a327b968d4be9d2
This commit is contained in:
Antoine Leblanc 2022-03-17 20:53:56 +00:00 committed by hasura-bot
parent 810c94c776
commit ccea1da1d5
17 changed files with 1540 additions and 93 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

44
CHANGELOG.md
View File

@ -1,6 +1,50 @@
# Hasura GraphQL Engine Changelog
## Next release
### Remote relationships from remote schemas
This release adds three new metadata API commands:
- `create_remote_schema_remote_relationship`
- `update_remote_schema_remote_relationship`
- `delete_remote_schema_remote_relationship`
that allows to create remote relationships between remote schemas on
the left-hand side and databases or remote schemas on the right-hand
side. Both use the same syntax as remote relationships from databases:
```yaml
type: create_remote_schema_remote_relationship
args:
remote_schema: LeftHandSide
type_name: LeftHandSideTypeName
name: RelationshipName
definition:
to_remote_schema:
remote_schema: RightHandSideSchema
lhs_fields: [LHSJoinKeyName]
remote_field:
rhsFieldName:
arguments:
ids: $LHSJoinKeyName
type: create_remote_schema_remote_relationship
args:
remote_schema: LeftHandSide
type_name: LeftHandSideTypeName
name: RelationshipName
definition:
to_source:
source: RightHandSideSource
table: {schema: public, name: RHSTable}
relationship_type: object
field_mapping:
LHSJoinKeyName: RHSColumnName
```
Similarly to DB-to-DB relationships, only `Postgres` is supported on
the right-hand side for now.
### Deprecations
* The `custom_column_names` property of TableConfig used on `<db>_track_table` and `set_table_customization` metadata APIs has been deprecated in favour of the new `column_config` property. `custom_column_names` will still work for now, however, values used in `column_config` will take precedence over values from `custom_column_names` and any overlapped values in `custom_column_names` will be discarded.

1
server/graphql-engine.cabal
View File

@ -1047,6 +1047,7 @@ test-suite tests-hspec
Test.ObjectRelationshipsLimitSpec
Test.ObjectRelationshipsSpec
Test.OrderingSpec
Test.RemoteRelationship.FromRemoteSchemaSpec
Test.RemoteRelationship.XToDBArrayRelationshipSpec
Test.RemoteRelationship.XToDBObjectRelationshipSpec
Test.RemoteRelationship.XToRemoteSchemaRelationshipSpec

2
server/src-lib/Hasura/RQL/DDL/RemoteRelationship.hs
View File

@ -364,7 +364,7 @@ getRemoteSchemaEntityJoinColumns ::
getRemoteSchemaEntityJoinColumns remoteSchemaName introspection typeName = do
typeDefinition <-
onNothing (lookupType introspection typeName) $
throw400 NotFound ("no such type defined in remote schema: " <>> remoteSchemaName)
throw400 NotFound ("no type named " <> typeName <<> " defined in remote schema " <>> remoteSchemaName)
case typeDefinition of
G.TypeDefinitionObject objectDefinition ->
pure $

11
server/src-lib/Hasura/Server/API/Metadata.hs
View File

@ -112,6 +112,10 @@ data RQLMetadataV1
| -- Remote schemas permissions
RMAddRemoteSchemaPermissions !AddRemoteSchemaPermission
| RMDropRemoteSchemaPermissions !DropRemoteSchemaPermissions
| -- Remote Schema remote relationships
RMCreateRemoteSchemaRemoteRelationship CreateRemoteSchemaRemoteRelationship
| RMUpdateRemoteSchemaRemoteRelationship CreateRemoteSchemaRemoteRelationship
| RMDeleteRemoteSchemaRemoteRelationship DeleteRemoteSchemaRemoteRelationship
| -- Scheduled triggers
RMCreateCronTrigger !(Unvalidated CreateCronTrigger)
| RMDeleteCronTrigger !ScheduledTriggerName
@ -185,6 +189,9 @@ instance FromJSON RQLMetadataV1 where
"introspect_remote_schema" -> RMIntrospectRemoteSchema <$> args
"add_remote_schema_permissions" -> RMAddRemoteSchemaPermissions <$> args
"drop_remote_schema_permissions" -> RMDropRemoteSchemaPermissions <$> args
"create_remote_schema_remote_relationship" -> RMCreateRemoteSchemaRemoteRelationship <$> args
"update_remote_schema_remote_relationship" -> RMUpdateRemoteSchemaRemoteRelationship <$> args
"delete_remote_schema_remote_relationship" -> RMDeleteRemoteSchemaRemoteRelationship <$> args
"create_cron_trigger" -> RMCreateCronTrigger <$> args
"delete_cron_trigger" -> RMDeleteCronTrigger <$> args
"create_scheduled_event" -> RMCreateScheduledEvent <$> args
@ -317,6 +324,7 @@ runMetadataQuery env logger instanceId userInfo httpManager serverConfigCtx sche
(MaintenanceModeDisabled, ReadOnlyModeDisabled) -> do
-- set modified metadata in storage
newResourceVersion <- setMetadata (fromMaybe currentResourceVersion _rqlMetadataResourceVersion) modMetadata
-- notify schema cache sync
notifySchemaCacheSync newResourceVersion instanceId cacheInvalidations
(_, modSchemaCache', _) <-
@ -449,6 +457,9 @@ runMetadataQueryV1M env currentResourceVersion = \case
RMIntrospectRemoteSchema q -> runIntrospectRemoteSchema q
RMAddRemoteSchemaPermissions q -> runAddRemoteSchemaPermissions q
RMDropRemoteSchemaPermissions q -> runDropRemoteSchemaPermissions q
RMCreateRemoteSchemaRemoteRelationship q -> runCreateRemoteSchemaRemoteRelationship q
RMUpdateRemoteSchemaRemoteRelationship q -> runUpdateRemoteSchemaRemoteRelationship q
RMDeleteRemoteSchemaRemoteRelationship q -> runDeleteRemoteSchemaRemoteRelationship q
RMCreateCronTrigger q ->
validateTransforms
(unUnvalidate . cctRequestTransform . _Just)

4
server/src-lib/Hasura/Server/API/Metadata.hs-boot
View File

@ -74,6 +74,10 @@ data RQLMetadataV1
| -- Remote schemas permissions
RMAddRemoteSchemaPermissions !AddRemoteSchemaPermission
| RMDropRemoteSchemaPermissions !DropRemoteSchemaPermissions
| -- Remote Schema remote relationships
RMCreateRemoteSchemaRemoteRelationship CreateRemoteSchemaRemoteRelationship
| RMUpdateRemoteSchemaRemoteRelationship CreateRemoteSchemaRemoteRelationship
| RMDeleteRemoteSchemaRemoteRelationship DeleteRemoteSchemaRemoteRelationship
| -- Scheduled triggers
RMCreateCronTrigger !(Unvalidated CreateCronTrigger)
| RMDeleteCronTrigger !ScheduledTriggerName

2
server/tests-hspec/Harness/Constants.hs
View File

@ -263,7 +263,7 @@ serveOptions =
-- only used in 'serveOptions'.
--
-- This should be adjusted locally for debugging purposes; e.g. change it to
-- @Just L.Debug@ to enable all logs.
-- @Just L.LevelDebug@ to enable all logs.
--
-- See 'L.LogLevel' for an enumeration of available log levels.
engineLogLevel :: Maybe L.LogLevel

25
server/tests-hspec/Harness/GraphqlEngine.hs
View File

@ -21,12 +21,8 @@ module Harness.GraphqlEngine
setSource,
setSources,
-- * Misc. Helpers
graphqlEndpoint,
-- * Server Setup & Teardown
-- * Server Setup
startServerThread,
stopServer,
-- * Re-exports
serverUrl,
@ -36,7 +32,7 @@ where
-------------------------------------------------------------------------------
import Control.Concurrent (forkIO, killThread, threadDelay)
import Control.Concurrent (forkIO, threadDelay)
import Control.Exception.Safe (bracket)
import Control.Monad.Trans.Managed (ManagedT (..), lowerManagedT)
import Data.Aeson (Value, object, (.=))
@ -85,7 +81,7 @@ post_ state path = void . postWithHeaders_ state path mempty
postWithHeaders ::
HasCallStack => State -> String -> Http.RequestHeaders -> Value -> IO Value
postWithHeaders (getServer -> Server {urlPrefix, port}) path =
Http.postValue_ (urlPrefix ++ ":" ++ show port ++ path)
Http.postValue (urlPrefix ++ ":" ++ show port ++ path)
-- | Post some JSON to graphql-engine, getting back more JSON.
--
@ -150,17 +146,6 @@ args:
-------------------------------------------------------------------------------
-- | Extracts the full GraphQL endpoint URL from a given 'Server'.
--
-- @
-- > graphqlEndpoint (Server 8080 "http://localhost" someThreadId)
-- "http://localhost:8080/graphql"
-- @
graphqlEndpoint :: Server -> String
graphqlEndpoint server = serverUrl server ++ "/graphql"
-------------------------------------------------------------------------------
-- | Choose a random port and start a graphql-engine server on that
-- port accessible from localhost. It waits until the server is
-- available before returning.
@ -183,10 +168,6 @@ startServerThread murlPrefixport = do
Http.healthCheck (serverUrl server)
pure server
-- | Forcibly stop a given 'Server'.
stopServer :: Server -> IO ()
stopServer Server {threadId} = killThread threadId
-------------------------------------------------------------------------------
-- | Run the graphql-engine server.

6
server/tests-hspec/Harness/Http.hs
View File

@ -1,7 +1,7 @@
-- | Helper functions for HTTP requests.
module Harness.Http
( get_,
postValue_,
postValue,
healthCheck,
Http.RequestHeaders,
)
@ -32,8 +32,8 @@ get_ url = do
-- | Post the JSON to the given URL, and produces a very descriptive
-- exception on failure.
postValue_ :: HasCallStack => String -> Http.RequestHeaders -> Value -> IO Value
postValue_ url headers value = do
postValue :: HasCallStack => String -> Http.RequestHeaders -> Value -> IO Value
postValue url headers value = do
let request =
Http.setRequestHeaders headers $
Http.setRequestMethod Http.methodPost $

13
server/tests-hspec/Harness/RemoteServer.hs
View File

@ -3,6 +3,7 @@ module Harness.RemoteServer
( run,
generateInterpreter,
generateQueryInterpreter,
graphqlEndpoint,
)
where
@ -162,6 +163,18 @@ generateQueryInterpreter ::
Interpreter
generateQueryInterpreter queryResolver = generateInterpreter queryResolver Undefined
-- | Extracts the full GraphQL endpoint URL from a given remote server's 'Server'.
--
-- @
-- > graphqlEndpoint (Server 8080 "http://localhost" someThreadId)
-- "http://localhost:8080/graphql"
-- @
--
-- NOTE: the resulting endpoint is only relevant for a 'Server' started by this
-- module's 'run' function; the GraphQL engine doesn't have a /graphql endoint.
graphqlEndpoint :: Server -> String
graphqlEndpoint server = serverUrl server ++ "/graphql"
-------------------------------------------------------------------------------
-- | An interpreter is a transformation function, applied to an incoming GraphQL

7
server/tests-hspec/Harness/State.hs
View File

@ -7,10 +7,11 @@ module Harness.State
Server (..),
getServer,
serverUrl,
stopServer,
)
where
import Control.Concurrent
import Control.Concurrent (ThreadId, killThread)
import Data.Word
import Hasura.Prelude hiding (State)
@ -41,3 +42,7 @@ getServer State {server} = server
-- @
serverUrl :: Server -> String
serverUrl Server {urlPrefix, port} = urlPrefix ++ ":" ++ show port
-- | Forcibly stop a given 'Server'.
stopServer :: Server -> IO ()
stopServer Server {threadId} = killThread threadId

2
server/tests-hspec/Harness/Test/Context.hs
View File

@ -191,10 +191,12 @@ data Context a = Context
-- | A name describing the given context.
data ContextName
= Backend BackendType
| RemoteGraphQLServer
| Combine ContextName ContextName
instance Show ContextName where
show (Backend backend) = show backend
show RemoteGraphQLServer = "RemoteGraphQLServer"
show (Combine name1 name2) = show name1 ++ "-" ++ show name2
-- | Default function for 'mkLocalState' when there's no local state.

4
server/tests-hspec/SpecHook.hs
View File

@ -4,8 +4,8 @@ module SpecHook
where
import Control.Exception.Safe (bracket)
import Harness.GraphqlEngine (startServerThread, stopServer)
import Harness.State (State (..))
import Harness.GraphqlEngine (startServerThread)
import Harness.State (State (..), stopServer)
import System.Environment (lookupEnv)
import Test.Hspec (Spec, SpecWith, aroundAllWith)
import Text.Read (readMaybe)

747
server/tests-hspec/Test/RemoteRelationship/FromRemoteSchemaSpec.hs Normal file
View File

@ -0,0 +1,747 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE QuasiQuotes #-}
-- | Tests for remote relationships from remote schemas. Unlike the "ToX"
-- modules, this module specifically cares about the remote schema on the LHS:
-- - testing the metadata API
-- - testing how we generate queries to remote schemas for the purpose of
-- making joins against them.
module Test.RemoteRelationship.FromRemoteSchemaSpec (spec) where
import Data.Functor ((<&>))
import Data.Morpheus.Document (gqlDocument)
import Data.Morpheus.Types
import Data.Text (Text)
import Harness.Backend.Postgres qualified as Postgres
import Harness.GraphqlEngine qualified as GraphqlEngine
import Harness.Quoter.Graphql (graphql)
import Harness.Quoter.Yaml (shouldReturnYaml, yaml)
import Harness.RemoteServer qualified as RemoteServer
import Harness.State (Server, State, stopServer)
import Harness.Test.Context (Context (..))
import Harness.Test.Context qualified as Context
import Harness.Test.Schema qualified as Schema
import Test.Hspec (SpecWith, describe, it)
import Prelude
--------------------------------------------------------------------------------
-- Preamble
spec :: SpecWith State
spec = Context.runWithLocalState [context] tests
where
context =
Context
{ name = Context.RemoteGraphQLServer,
-- start only one remote server
mkLocalState = \_state ->
RemoteServer.run $
RemoteServer.generateQueryInterpreter $
Query
{ object = objectResolver,
writer = writerResolver,
artist = artistResolver,
objects = objectsResolver,
articles = articlesResolver
},
-- set that remote server as both source and target, for convenience
-- start a RHS Postgres for Metadata tests only
setup = \(state, server) -> do
GraphqlEngine.clearMetadata state
addRemoteSchema state "remote" server
addRelationships state
rhsPostgresSetup state,
-- shutdown the server
teardown = \(state, server) -> do
GraphqlEngine.clearMetadata state
stopServer server
rhsPostgresTeardown,
-- no custom options
customOptions = Nothing
}
-- | Add a remote schema to the engine with the given name.
addRemoteSchema :: State -> String -> Server -> IO ()
addRemoteSchema state rsName remoteServer = do
let remoteSchemaEndpoint = RemoteServer.graphqlEndpoint remoteServer
GraphqlEngine.postMetadata_
state
[yaml|
type: add_remote_schema
args:
name: *rsName
definition:
url: *remoteSchemaEndpoint
|]
-- | Create the remote relationships.
addRelationships :: State -> IO ()
addRelationships state = do
GraphqlEngine.postMetadata_
state
[yaml|
type: bulk
args:
- type: create_remote_schema_remote_relationship
args:
remote_schema: remote
type_name: Writer
name: articles
definition:
to_remote_schema:
remote_schema: remote
lhs_fields: [wIds]
remote_field:
articles:
arguments:
ids: $wIds
- type: create_remote_schema_remote_relationship
args:
remote_schema: remote
type_name: Artist
name: articles
definition:
to_remote_schema:
remote_schema: remote
lhs_fields: [aIds]
remote_field:
articles:
arguments:
ids: $aIds
- type: create_remote_schema_remote_relationship
args:
remote_schema: remote
type_name: Article
name: artist
definition:
to_remote_schema:
remote_schema: remote
lhs_fields: [aId]
remote_field:
artist:
arguments:
id: $aId
- type: create_remote_schema_remote_relationship
args:
remote_schema: remote
type_name: Article
name: writer
definition:
to_remote_schema:
remote_schema: remote
lhs_fields: [wId]
remote_field:
writer:
arguments:
id: $wId
|]
--------------------------------------------------------------------------------
-- Remote schema
[gqlDocument|
type Query {
object(id: Int!): Object
writer(id: Int!): Writer
artist(id: Int!): Artist
objects(ids: [Int!]!): [Object]!
articles(ids: [Int!]!): [Article]!
}
union Object = Writer | Artist | Article
type Writer {
id: Int!
name: String!
wIds: [Int!]!
local_articles: [Article!]!
}
type Artist {
id: Int!
name: String!
aIds: [Int!]!
local_articles: [Article!]!
self: Artist!
}
type Article {
id: Int!
title: String!
aId: Int!
wId: Int!
}
|]
knownObjects :: Monad m => [(Int, Object m)]
knownObjects =
[ (101, ObjectWriter writer1),
(102, ObjectWriter writer2),
(201, ObjectArtist artist1),
(202, ObjectArtist artist2),
(301, ObjectArticle article1),
(302, ObjectArticle article2),
(303, ObjectArticle article3),
(304, ObjectArticle article4)
]
where
writer1 = Writer (pure 101) (pure "Writer1") (pure [301, 302]) (pure [article1, article2])
writer2 = Writer (pure 102) (pure "Writer2") (pure [303, 304]) (pure [article3, article4])
artist1 = Artist (pure 201) (pure "Artist1") (pure [301, 303]) (pure [article1, article3]) (pure artist1)
artist2 = Artist (pure 202) (pure "Artist2") (pure [302, 304]) (pure [article2, article4]) (pure artist2)
article1 = Article (pure 301) (pure "Article1") (pure 201) (pure 101)
article2 = Article (pure 302) (pure "Article2") (pure 202) (pure 101)
article3 = Article (pure 303) (pure "Article3") (pure 201) (pure 102)
article4 = Article (pure 304) (pure "Article4") (pure 202) (pure 102)
objectResolver :: Monad m => Arg "id" Int -> m (Maybe (Object m))
objectResolver (Arg objectId) = pure $ lookup objectId knownObjects
writerResolver :: Monad m => Arg "id" Int -> m (Maybe (Writer m))
writerResolver (Arg objectId) =
pure $ case lookup objectId knownObjects of
Just (ObjectWriter w) -> Just w
_ -> Nothing
artistResolver :: Monad m => Arg "id" Int -> m (Maybe (Artist m))
artistResolver (Arg objectId) =
pure $ case lookup objectId knownObjects of
Just (ObjectArtist a) -> Just a
_ -> Nothing
objectsResolver :: Monad m => Arg "ids" [Int] -> m [Maybe (Object m)]
objectsResolver (Arg objectIds) = pure [lookup objectId knownObjects | objectId <- objectIds]
articlesResolver :: Monad m => Arg "ids" [Int] -> m [Maybe (Article m)]
articlesResolver (Arg objectIds) =
pure $
objectIds <&> \objectId ->
case lookup objectId knownObjects of
Just (ObjectArticle a) -> Just a
_ -> Nothing
--------------------------------------------------------------------------------
-- RHS Postgres (for metadata only)
track :: Schema.Table
track =
Schema.Table
"track"
[ Schema.column "id" Schema.TInt,
Schema.column "title" Schema.TStr,
Schema.columnNull "album_id" Schema.TInt
]
["id"]
[]
[ [Schema.VInt 1, Schema.VStr "track1_album1", Schema.VInt 1],
[Schema.VInt 2, Schema.VStr "track2_album1", Schema.VInt 1],
[Schema.VInt 3, Schema.VStr "track3_album1", Schema.VInt 1],
[Schema.VInt 4, Schema.VStr "track1_album2", Schema.VInt 2],
[Schema.VInt 5, Schema.VStr "track2_album2", Schema.VInt 2],
[Schema.VInt 6, Schema.VStr "track1_album3", Schema.VInt 3],
[Schema.VInt 7, Schema.VStr "track2_album3", Schema.VInt 3],
[Schema.VInt 8, Schema.VStr "track_no_album", Schema.VNull]
]
rhsPostgresSetup :: State -> IO ()
rhsPostgresSetup state = do
let sourceName = "db"
sourceConfig = Postgres.defaultSourceConfiguration
GraphqlEngine.postMetadata_
state
[yaml|
type: pg_add_source
args:
name: *sourceName
configuration: *sourceConfig
|]
-- setup tables only
Postgres.createTable track
Postgres.insertTable track
Schema.trackTable Context.Postgres sourceName track state
rhsPostgresTeardown :: IO ()
rhsPostgresTeardown = Postgres.dropTable track
--------------------------------------------------------------------------------
-- Tests
tests :: Context.Options -> SpecWith (State, Server)
tests opts = do
-- tests metadata API
metadataAPITests
-- ensures setup is correct
noJoinsTests opts
simpleTests opts
-- joins on neither part of the union
joinArticleTests opts
-- joins on parts of the union
joinWriterTests opts
joinArtistTests opts
-- joins on deeply nested joins
deeplyNestedJoinTests opts
metadataAPITests :: SpecWith (State, Server)
metadataAPITests = describe "metadata API" do
it "adds a RS-RS relationship" \(state, _) ->
GraphqlEngine.postMetadata_
state
[yaml|
type: create_remote_schema_remote_relationship
args:
remote_schema: remote
type_name: Writer
name: nonsensical1
definition:
to_remote_schema:
remote_schema: remote
lhs_fields: [wIds]
remote_field:
articles:
arguments:
ids: $wIds
|]
it "adds a RS-RD relationship" \(state, _) ->
GraphqlEngine.postMetadata_
state
[yaml|
type: create_remote_schema_remote_relationship
args:
remote_schema: remote
type_name: Writer
name: nonsensical2
definition:
to_source:
source: db
table: {schema: hasura, name: track}
relationship_type: object
field_mapping:
id: id
|]
it "updates a RS-RS relationship" \(state, _) ->
GraphqlEngine.postMetadata_
state
[yaml|
type: update_remote_schema_remote_relationship
args:
remote_schema: remote
type_name: Writer
name: nonsensical1
definition:
to_remote_schema:
remote_schema: remote
lhs_fields: [id]
remote_field:
artist:
arguments:
id: $id
|]
it "updates a RS-DB relationship" \(state, _) ->
GraphqlEngine.postMetadata_
state
[yaml|
type: update_remote_schema_remote_relationship
args:
remote_schema: remote
type_name: Writer
name: nonsensical2
definition:
to_source:
source: db
table: {schema: hasura, name: track}
relationship_type: array
field_mapping:
id: id
|]
it "deletes a RS-RS relationship" \(state, _) ->
GraphqlEngine.postMetadata_
state
[yaml|
type: delete_remote_schema_remote_relationship
args:
remote_schema: remote
type_name: Writer
name: nonsensical1
|]
it "deletes a RS-DB relationship" \(state, _) ->
GraphqlEngine.postMetadata_
state
[yaml|
type: delete_remote_schema_remote_relationship
args:
remote_schema: remote
type_name: Writer
name: nonsensical2
|]
-- | Ensure we don't insert `__hasura_internal_typename` when there are no
-- joins.
noJoinsTests :: Context.Options -> SpecWith (State, Server)
noJoinsTests opts = describe "simple joins" do
it "select objects without remote joins" \(state, _) -> do
let query =
[graphql|
query {
obj101: object(id: 101) {
__typename
}
obj201: object(id: 201) {
__typename
}
obj301: object(id: 301) {
__typename
}
}
|]
expectedResponse =
[yaml|
data:
obj101:
__typename: Writer
obj201:
__typename: Artist
obj301:
__typename: Article
|]
shouldReturnYaml
opts
(GraphqlEngine.postGraphql state query)
expectedResponse
simpleTests :: Context.Options -> SpecWith (State, Server)
simpleTests opts = describe "simple joins" do
it "joins writer against articles" \(state, _) -> do
let query =
[graphql|
query {
writer(id: 101) {
name
articles {
title
}
}
}
|]
expectedResponse =
[yaml|
data:
writer:
name: "Writer1"
articles:
- title: Article1
- title: Article2
|]
shouldReturnYaml
opts
(GraphqlEngine.postGraphql state query)
expectedResponse
it "joins no writer against articles" \(state, _) -> do
let query =
[graphql|
query {
writer(id: 0) {
name
articles {
title
}
}
}
|]
expectedResponse =
[yaml|
data:
writer: null
|]
shouldReturnYaml
opts
(GraphqlEngine.postGraphql state query)
expectedResponse
it "joins artist against articles" \(state, _) -> do
let query =
[graphql|
query {
artist(id: 201) {
name
articles {
title
}
}
}
|]
expectedResponse =
[yaml|
data:
artist:
name: "Artist1"
articles:
- title: Article1
- title: Article3
|]
shouldReturnYaml
opts
(GraphqlEngine.postGraphql state query)
expectedResponse
it "joins no artist against articles" \(state, _) -> do
let query =
[graphql|
query {
artist(id: 0) {
name
articles {
title
}
}
}
|]
expectedResponse =
[yaml|
data:
artist: null
|]
shouldReturnYaml
opts
(GraphqlEngine.postGraphql state query)
expectedResponse
joinArticleTests :: Context.Options -> SpecWith (State, Server)
joinArticleTests opts = describe "join from article object" do
it "does not join" \(state, _) -> do
let query =
[graphql|
query {
object(id: 301) {
... on Article {
title
}
... on Artist {
name
articles {
title
}
}
... on Writer {
name
articles {
title
}
}
}
}
|]
expectedResponse =
[yaml|
data:
object:
# to circumvent https://github.com/morpheusgraphql/morpheus-graphql/issues/687
__typename: Article
title: "Article1"
|]
shouldReturnYaml
opts
(GraphqlEngine.postGraphql state query)
expectedResponse
joinWriterTests :: Context.Options -> SpecWith (State, Server)
joinWriterTests opts = describe "join from writer object" do
it "joins against articles" \(state, _) -> do
let query =
[graphql|
query {
object(id: 101) {
... on Article {
title
}
... on Artist {
name
articles {
title
}
}
... on Writer {
name
articles {
title
}
}
}
}
|]
expectedResponse =
[yaml|
data:
object:
# to circumvent https://github.com/morpheusgraphql/morpheus-graphql/issues/687
__typename: Writer
name: "Writer1"
articles:
- title: Article1
- title: Article2
|]
shouldReturnYaml
opts
(GraphqlEngine.postGraphql state query)
expectedResponse
joinArtistTests :: Context.Options -> SpecWith (State, Server)
joinArtistTests opts = describe "join from artist object" do
it "joins against articles" \(state, _) -> do
let query =
[graphql|
query {
object(id: 201) {
... on Article {
title
}
... on Artist {
name
articles {
title
}
}
... on Writer {
name
articles {
title
}
}
}
}
|]
expectedResponse =
[yaml|
data:
object:
# to circumvent https://github.com/morpheusgraphql/morpheus-graphql/issues/687
__typename: Artist
name: "Artist1"
articles:
- title: Article1
- title: Article3
|]
shouldReturnYaml
opts
(GraphqlEngine.postGraphql state query)
expectedResponse
deeplyNestedJoinTests :: Context.Options -> SpecWith (State, Server)
deeplyNestedJoinTests opts = describe "join from artist object" do
it "joins ambiguously nested articles depending on the full path" \(state, _) -> do
let query =
[graphql|
query {
objects(ids: [101, 201]) {
... on Artist {
local_articles { # local join
title
foo: writer { # remote join
bar: wIds
baz: articles { # remote join
title
}
}
}
}
... on Writer {
local_articles { # local join
title
foo: artist { # remote join
bar: aIds
baz: articles { # remote join
title
}
}
}
}
}
}
|]
expectedResponse =
[yaml|
data:
objects:
- local_articles:
- title: Article1
foo:
bar:
- 301
- 303
baz:
- title: Article1
- title: Article3
- title: Article2
foo:
bar:
- 302
- 304
baz:
- title: Article2
- title: Article4
# to circumvent https://github.com/morpheusgraphql/morpheus-graphql/issues/687
__typename: Writer
- local_articles:
- title: Article1
foo:
bar:
- 301
- 302
baz:
- title: Article1
- title: Article2
- title: Article3
foo:
bar:
- 303
- 304
baz:
- title: Article3
- title: Article4
# to circumvent https://github.com/morpheusgraphql/morpheus-graphql/issues/687
__typename: Artist
|]
shouldReturnYaml
opts
(GraphqlEngine.postGraphql state query)
expectedResponse
it "joins nested articles at different depths" \(state, _) -> do
let query =
[graphql|
query {
objects(ids: [102, 202]) {
... on Artist {
bar: self {
baz: articles {
title
}
}
}
... on Writer {
bar: articles {
title
}
}
}
}
|]
expectedResponse =
[yaml|
data:
objects:
- bar:
- title: Article3
- title: Article4
# to circumvent https://github.com/morpheusgraphql/morpheus-graphql/issues/687
__typename: Writer
- bar:
baz:
- title: Article2
- title: Article4
# to circumvent https://github.com/morpheusgraphql/morpheus-graphql/issues/687
__typename: Artist
|]
shouldReturnYaml
opts
(GraphqlEngine.postGraphql state query)
expectedResponse

269
server/tests-hspec/Test/RemoteRelationship/XToDBArrayRelationshipSpec.hs
View File

@ -1,3 +1,4 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE QuasiQuotes #-}
-- | Tests for array remote relationships to databases. Remote relationships are
@ -15,13 +16,24 @@ where
import Control.Lens (findOf, has, only, (^?!))
import Data.Aeson (Value)
import Data.Aeson.Lens (key, values, _String)
import Data.Foldable (for_)
import Data.Char (isUpper, toLower)
import Data.Foldable (for_, traverse_)
import Data.Function ((&))
import Data.List (intercalate, sortBy)
import Data.List.Split (dropBlanks, keepDelimsL, split, whenElt)
import Data.Maybe qualified as Unsafe (fromJust)
import Data.Morpheus.Document (gqlDocument)
import Data.Morpheus.Types
import Data.Morpheus.Types qualified as Morpheus
import Data.Text (Text)
import Data.Typeable (Typeable)
import GHC.Generics (Generic)
import Harness.Backend.Postgres qualified as Postgres
import Harness.GraphqlEngine qualified as GraphqlEngine
import Harness.Quoter.Graphql (graphql)
import Harness.Quoter.Yaml (shouldBeYaml, shouldReturnYaml, yaml)
import Harness.State (Server, State)
import Harness.RemoteServer qualified as RemoteServer
import Harness.State (Server, State, stopServer)
import Harness.Test.Context (Context (..))
import Harness.Test.Context qualified as Context
import Harness.Test.Schema qualified as Schema
@ -34,7 +46,7 @@ import Prelude
spec :: SpecWith State
spec = Context.runWithLocalState contexts tests
where
lhsContexts = [lhsPostgres]
lhsContexts = [lhsPostgres, lhsRemoteServer]
rhsContexts = [rhsPostgres]
contexts = combine <$> lhsContexts <*> rhsContexts
@ -94,10 +106,15 @@ lhsPostgres tableName =
customOptions = Nothing
}
{-
lhsRemoteServer :: Value -> Context
lhsRemoteServer tableName = Context "from RS" (lhsRemoteSetup tableName) lhsRemoteTeardown
-}
lhsRemoteServer :: LHSContext
lhsRemoteServer tableName =
Context
{ name = Context.RemoteGraphQLServer,
mkLocalState = lhsRemoteServerMkLocalState,
setup = lhsRemoteServerSetup tableName,
teardown = lhsRemoteServerTeardown,
customOptions = Nothing
}
--------------------------------------------------------------------------------
@ -231,10 +248,197 @@ args:
|]
lhsPostgresTeardown :: (State, Maybe Server) -> IO ()
lhsPostgresTeardown (state, _) = do
let sourceName = "source"
Schema.untrackTable Context.Postgres sourceName artist state
Postgres.dropTable artist
lhsPostgresTeardown _ = Postgres.dropTable artist
--------------------------------------------------------------------------------
-- LHS Remote Server
-- | To circumvent Morpheus' default behaviour, which is to capitalize type
-- names and field names for Haskell records to be consistent with their
-- corresponding GraphQL equivalents, we define most of the schema manually with
-- the following options.
hasuraTypeOptions :: Morpheus.GQLTypeOptions
hasuraTypeOptions =
Morpheus.defaultTypeOptions
{ -- transformation to apply to constructors, for enums; we simply map to
-- lower case:
-- Asc -> asc
Morpheus.constructorTagModifier = map toLower,
-- transformation to apply to field names; we drop all characters up to and
-- including the first underscore:
-- hta_where -> where
Morpheus.fieldLabelModifier = tail . dropWhile (/= '_'),
-- transformation to apply to type names; we split the name on uppercase
-- letters, intercalate with underscore, and map everything to lowercase:
-- HasuraTrack -> hasura_track
Morpheus.typeNameModifier = \_ ->
map toLower
. intercalate "_"
. split (dropBlanks $ keepDelimsL $ whenElt isUpper)
}
data Query m = Query
{ hasura_artist :: HasuraArtistArgs -> m [HasuraArtist m]
}
deriving (Generic)
instance Typeable m => Morpheus.GQLType (Query m)
data HasuraArtistArgs = HasuraArtistArgs
{ aa_where :: Maybe HasuraArtistBoolExp,
aa_order_by :: Maybe [HasuraArtistOrderBy],
aa_limit :: Maybe Int
}
deriving (Generic)
instance Morpheus.GQLType HasuraArtistArgs where
typeOptions _ _ = hasuraTypeOptions
data HasuraArtist m = HasuraArtist
{ a_id :: m (Maybe Int),
a_name :: m (Maybe Text)
}
deriving (Generic)
instance Typeable m => Morpheus.GQLType (HasuraArtist m) where
typeOptions _ _ = hasuraTypeOptions
data HasuraArtistOrderBy = HasuraArtistOrderBy
{ aob_id :: Maybe OrderType,
aob_name :: Maybe OrderType
}
deriving (Generic)
instance Morpheus.GQLType HasuraArtistOrderBy where
typeOptions _ _ = hasuraTypeOptions
data HasuraArtistBoolExp = HasuraArtistBoolExp
{ abe__and :: Maybe [HasuraArtistBoolExp],
abe__or :: Maybe [HasuraArtistBoolExp],
abe__not :: Maybe HasuraArtistBoolExp,
abe_id :: Maybe IntCompExp,
abe_name :: Maybe StringCompExp
}
deriving (Generic)
instance Morpheus.GQLType HasuraArtistBoolExp where
typeOptions _ _ = hasuraTypeOptions
data OrderType = Asc | Desc
deriving (Show, Generic)
instance Morpheus.GQLType OrderType where
typeOptions _ _ = hasuraTypeOptions
[gqlDocument|
input IntCompExp {
_eq: Int
}
input StringCompExp {
_eq: String
}
|]
lhsRemoteServerMkLocalState :: State -> IO (Maybe Server)
lhsRemoteServerMkLocalState _ = do
server <-
RemoteServer.run $
RemoteServer.generateQueryInterpreter (Query {hasura_artist})
pure $ Just server
where
-- Implements the @hasura_artist@ field of the @Query@ type.
hasura_artist (HasuraArtistArgs {..}) = do
let filterFunction = case aa_where of
Nothing -> const True
Just whereArg -> flip matchArtist whereArg
orderByFunction = case aa_order_by of
Nothing -> \_ _ -> EQ
Just orderByArg -> orderArtist orderByArg
limitFunction = case aa_limit of
Nothing -> Prelude.id
Just limitArg -> take limitArg
pure $
artists
& filter filterFunction
& sortBy orderByFunction
& limitFunction
& map mkArtist
-- Returns True iif the given artist matches the given boolean expression.
matchArtist artistInfo@(artistId, artistName) (HasuraArtistBoolExp {..}) =
and
[ maybe True (all (matchArtist artistInfo)) abe__and,
maybe True (any (matchArtist artistInfo)) abe__or,
maybe True (not . matchArtist artistInfo) abe__not,
maybe True (matchMaybeInt artistId) abe_id,
maybe True (matchString artistName) abe_name
]
matchString stringField StringCompExp {..} = Just stringField == _eq
matchMaybeInt maybeIntField IntCompExp {..} = maybeIntField == _eq
-- Returns an ordering between the two given artists.
orderArtist
orderByList
(artistId1, artistName1)
(artistId2, artistName2) =
flip foldMap orderByList \HasuraArtistOrderBy {..} ->
if
| Just idOrder <- aob_id ->
compareWithNullLast idOrder artistId1 artistId2
| Just nameOrder <- aob_name -> case nameOrder of
Asc -> compare artistName1 artistName2
Desc -> compare artistName2 artistName1
| otherwise ->
error "empty artist_order object"
compareWithNullLast Desc x1 x2 = compareWithNullLast Asc x2 x1
compareWithNullLast Asc Nothing Nothing = EQ
compareWithNullLast Asc (Just _) Nothing = LT
compareWithNullLast Asc Nothing (Just _) = GT
compareWithNullLast Asc (Just x1) (Just x2) = compare x1 x2
artists =
[ (Just 1, "artist1"),
(Just 2, "artist2"),
(Just 3, "artist_no_albums"),
(Nothing, "artist_no_id")
]
mkArtist (artistId, artistName) =
HasuraArtist
{ a_id = pure artistId,
a_name = pure $ Just artistName
}
lhsRemoteServerSetup :: Value -> (State, Maybe Server) -> IO ()
lhsRemoteServerSetup tableName (state, maybeRemoteServer) = case maybeRemoteServer of
Nothing -> error "XToDBArrayRelationshipSpec: remote server local state did not succesfully create a server"
Just remoteServer -> do
let remoteSchemaEndpoint = GraphqlEngine.serverUrl remoteServer ++ "/graphql"
GraphqlEngine.postMetadata_
state
[yaml|
type: bulk
args:
- type: add_remote_schema
args:
name: source
definition:
url: *remoteSchemaEndpoint
- type: create_remote_schema_remote_relationship
args:
remote_schema: source
type_name: hasura_artist
name: albums
definition:
to_source:
source: target
table: *tableName
relationship_type: array
field_mapping:
id: artist_id
|]
lhsRemoteServerTeardown :: (State, Maybe Server) -> IO ()
lhsRemoteServerTeardown (_, maybeServer) = traverse_ stopServer maybeServer
--------------------------------------------------------------------------------
-- RHS Postgres
@ -294,16 +498,13 @@ args:
|]
rhsPostgresTeardown :: (State, ()) -> IO ()
rhsPostgresTeardown (state, _) = do
let sourceName = "target"
Schema.untrackTable Context.Postgres sourceName album state
Postgres.dropTable album
rhsPostgresTeardown _ = Postgres.dropTable album
--------------------------------------------------------------------------------
-- Tests
tests :: Context.Options -> SpecWith (State, Maybe Server)
tests opts = describe "array-relationship" $ do
tests opts = describe "array-relationship" do
schemaTests opts
executionTests opts
permissionTests opts
@ -311,7 +512,7 @@ tests opts = describe "array-relationship" $ do
schemaTests :: Context.Options -> SpecWith (State, Maybe Server)
schemaTests _opts =
-- we introspect the schema and validate it
it "graphql-schema" $ \(state, _) -> do
it "graphql-schema" \(state, _) -> do
let query =
[graphql|
fragment type_info on __Type {
@ -442,9 +643,9 @@ schemaTests _opts =
-- | Basic queries using DB-to-DB joins
executionTests :: Context.Options -> SpecWith (State, Maybe Server)
executionTests opts = describe "execution" $ do
executionTests opts = describe "execution" do
-- fetches the relationship data
it "related-data" $ \(state, _) -> do
it "related-data" \(state, _) -> do
let query =
[graphql|
query {
@ -471,7 +672,7 @@ executionTests opts = describe "execution" $ do
expectedResponse
-- when there are no matching rows, the relationship response should be []
it "related-data-empty-array" $ \(state, _) -> do
it "related-data-empty-array" \(state, _) -> do
let query =
[graphql|
query {
@ -496,7 +697,7 @@ executionTests opts = describe "execution" $ do
expectedResponse
-- when any of the join columns are null, the relationship should be null
it "related-data-null" $ \(state, _) -> do
it "related-data-null" \(state, _) -> do
let query =
[graphql|
query {
@ -521,7 +722,7 @@ executionTests opts = describe "execution" $ do
expectedResponse
-- when the lhs response has both null and non-null values for join columns
it "related-data-non-null-and-null" $ \(state, _) -> do
it "related-data-non-null-and-null" \(state, _) -> do
let query =
[graphql|
query {
@ -532,7 +733,7 @@ executionTests opts = describe "execution" $ do
{name: {_eq: "artist_no_id"}}
]
},
order_by: {id: asc}
order_by: [{id: asc}]
) {
name
albums {
@ -565,15 +766,15 @@ executionTests opts = describe "execution" $ do
-- | tests that describe an array relationship's data in the presence of permisisons
permissionTests :: Context.Options -> SpecWith (State, Maybe Server)
permissionTests opts = describe "permission" $ do
permissionTests opts = describe "permission" do
-- only the allowed rows on the target table are queryable
it "only-allowed-rows" $ \(state, _) -> do
it "only-allowed-rows" \(state, _) -> do
let userHeaders = [("x-hasura-role", "role1"), ("x-hasura-artist-id", "1")]
query =
[graphql|
query {
artist: hasura_artist(
order_by: {id: asc}
order_by: [{id: asc}]
) {
name
albums {
@ -605,7 +806,7 @@ permissionTests opts = describe "permission" $ do
-- we use an introspection query to check column permissions:
-- 1. the type 'hasura_album' has only 'artist_id' and 'title', the allowed columns
-- 2. the albums field in 'hasura_artist' type is of type 'hasura_album'
it "only-allowed-columns" $ \(state, _) -> do
it "only-allowed-columns" \(state, _) -> do
let userHeaders = [("x-hasura-role", "role1"), ("x-hasura-artist-id", "1")]
query =
[graphql|
@ -643,7 +844,7 @@ permissionTests opts = describe "permission" $ do
expectedResponse
-- _aggregate field should not be generated when 'allow_aggregations' isn't set to 'true'
it "aggregations-not-allowed" $ \(state, _) -> do
it "aggregations-not-allowed" \(state, _) -> do
let userHeaders = [("x-hasura-role", "role1")]
query =
[graphql|
@ -670,7 +871,7 @@ permissionTests opts = describe "permission" $ do
expectedResponse
-- _aggregate field should only be allowed when 'allow_aggregations' is set to 'true'
it "aggregations-allowed" $ \(state, _) -> do
it "aggregations-allowed" \(state, _) -> do
let userHeaders = [("x-hasura-role", "role2")]
query =
[graphql|
@ -698,7 +899,7 @@ permissionTests opts = describe "permission" $ do
expectedResponse
-- permission limit should kick in when no query limit is specified
it "no-query-limit" $ \(state, _) -> do
it "no-query-limit" \(state, _) -> do
let userHeaders = [("x-hasura-role", "role2"), ("x-hasura-artist-id", "1")]
query =
[graphql|
@ -727,7 +928,7 @@ permissionTests opts = describe "permission" $ do
expectedResponse
-- query limit should be applied when query limit <= permission limit
it "user-limit-less-than-permission-limit" $ \(state, _) -> do
it "user-limit-less-than-permission-limit" \(state, _) -> do
let userHeaders = [("x-hasura-role", "role2"), ("x-hasura-artist-id", "1")]
query =
[graphql|
@ -755,7 +956,7 @@ permissionTests opts = describe "permission" $ do
expectedResponse
-- permission limit should be applied when query limit > permission limit
it "user-limit-greater-than-permission-limit" $ \(state, _) -> do
it "user-limit-greater-than-permission-limit" \(state, _) -> do
let userHeaders = [("x-hasura-role", "role2"), ("x-hasura-artist-id", "1")]
query =
[graphql|
@ -784,7 +985,7 @@ permissionTests opts = describe "permission" $ do
expectedResponse
-- permission limit should only apply on 'nodes' but not on 'aggregate'
it "aggregations" $ \(state, _) -> do
it "aggregations" \(state, _) -> do
let userHeaders = [("x-hasura-role", "role2"), ("x-hasura-artist-id", "1")]
query =
[graphql|
@ -821,7 +1022,7 @@ permissionTests opts = describe "permission" $ do
expectedResponse
-- query limit applies to both 'aggregate' and 'nodes'
it "aggregations-query-limit" $ \(state, _) -> do
it "aggregations-query-limit" \(state, _) -> do
let userHeaders = [("x-hasura-role", "role2"), ("x-hasura-artist-id", "1")]
query =
[graphql|

246
server/tests-hspec/Test/RemoteRelationship/XToDBObjectRelationshipSpec.hs
View File

@ -1,3 +1,4 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE QuasiQuotes #-}
-- | Tests for object remote relationships to databases. Remote relationships
@ -14,11 +15,22 @@ module Test.RemoteRelationship.XToDBObjectRelationshipSpec
where
import Data.Aeson (Value)
import Data.Char (isUpper, toLower)
import Data.Foldable (traverse_)
import Data.Function ((&))
import Data.List (intercalate, sortBy)
import Data.List.Split (dropBlanks, keepDelimsL, split, whenElt)
import Data.Morpheus.Document (gqlDocument)
import Data.Morpheus.Types qualified as Morpheus
import Data.Text (Text)
import Data.Typeable (Typeable)
import GHC.Generics
import Harness.Backend.Postgres qualified as Postgres
import Harness.GraphqlEngine qualified as GraphqlEngine
import Harness.Quoter.Graphql (graphql)
import Harness.Quoter.Yaml (shouldReturnYaml, yaml)
import Harness.State (Server, State)
import Harness.RemoteServer qualified as RemoteServer
import Harness.State (Server, State, stopServer)
import Harness.Test.Context (Context (..))
import Harness.Test.Context qualified as Context
import Harness.Test.Schema qualified as Schema
@ -31,7 +43,7 @@ import Prelude
spec :: SpecWith State
spec = Context.runWithLocalState contexts tests
where
lhsContexts = [lhsPostgres]
lhsContexts = [lhsPostgres, lhsRemoteServer]
rhsContexts = [rhsPostgres]
contexts = combine <$> lhsContexts <*> rhsContexts
@ -91,10 +103,15 @@ lhsPostgres tableName =
customOptions = Nothing
}
{-
lhsRemoteServer :: Value -> Context
lhsRemoteServer tableName = Context "from RS" (lhsRemoteSetup tableName) lhsRemoteTeardown
-}
lhsRemoteServer :: LHSContext
lhsRemoteServer tableName =
Context
{ name = Context.RemoteGraphQLServer,
mkLocalState = lhsRemoteServerMkLocalState,
setup = lhsRemoteServerSetup tableName,
teardown = lhsRemoteServerTeardown,
customOptions = Nothing
}
--------------------------------------------------------------------------------
@ -232,10 +249,210 @@ args:
|]
lhsPostgresTeardown :: (State, Maybe Server) -> IO ()
lhsPostgresTeardown (state, _) = do
let sourceName = "source"
Schema.untrackTable Context.Postgres sourceName track state
Postgres.dropTable track
lhsPostgresTeardown _ = Postgres.dropTable track
--------------------------------------------------------------------------------
-- LHS Remote Server
-- | To circumvent Morpheus' default behaviour, which is to capitalize type
-- names and field names for Haskell records to be consistent with their
-- corresponding GraphQL equivalents, we define most of the schema manually with
-- the following options.
hasuraTypeOptions :: Morpheus.GQLTypeOptions
hasuraTypeOptions =
Morpheus.defaultTypeOptions
{ -- transformation to apply to constructors, for enums; we simply map to
-- lower case:
-- Asc -> asc
Morpheus.constructorTagModifier = map toLower,
-- transformation to apply to field names; we drop all characters up to and
-- including the first underscore:
-- hta_where -> where
Morpheus.fieldLabelModifier = tail . dropWhile (/= '_'),
-- transformation to apply to type names; we split the name on uppercase
-- letters, intercalate with underscore, and map everything to lowercase:
-- HasuraTrack -> hasura_track
Morpheus.typeNameModifier = \_ ->
map toLower
. intercalate "_"
. split (dropBlanks $ keepDelimsL $ whenElt isUpper)
}
data Query m = Query
{ hasura_track :: HasuraTrackArgs -> m [HasuraTrack m]
}
deriving (Generic)
instance Typeable m => Morpheus.GQLType (Query m)
data HasuraTrackArgs = HasuraTrackArgs
{ ta_where :: Maybe HasuraTrackBoolExp,
ta_order_by :: Maybe [HasuraTrackOrderBy],
ta_limit :: Maybe Int
}
deriving (Generic)
instance Morpheus.GQLType HasuraTrackArgs where
typeOptions _ _ = hasuraTypeOptions
data HasuraTrack m = HasuraTrack
{ t_id :: m (Maybe Int),
t_title :: m (Maybe Text),
t_album_id :: m (Maybe Int)
}
deriving (Generic)
instance Typeable m => Morpheus.GQLType (HasuraTrack m) where
typeOptions _ _ = hasuraTypeOptions
data HasuraTrackOrderBy = HasuraTrackOrderBy
{ tob_id :: Maybe OrderType,
tob_title :: Maybe OrderType,
tob_album_id :: Maybe OrderType
}
deriving (Generic)
instance Morpheus.GQLType HasuraTrackOrderBy where
typeOptions _ _ = hasuraTypeOptions
data HasuraTrackBoolExp = HasuraTrackBoolExp
{ tbe__and :: Maybe [HasuraTrackBoolExp],
tbe__or :: Maybe [HasuraTrackBoolExp],
tbe__not :: Maybe HasuraTrackBoolExp,
tbe_id :: Maybe IntCompExp,
tbe_title :: Maybe StringCompExp,
tbe_album_id :: Maybe IntCompExp
}
deriving (Generic)
instance Morpheus.GQLType HasuraTrackBoolExp where
typeOptions _ _ = hasuraTypeOptions
data OrderType = Asc | Desc
deriving (Show, Generic)
instance Morpheus.GQLType OrderType where
typeOptions _ _ = hasuraTypeOptions
[gqlDocument|
input IntCompExp {
_eq: Int
}
input StringCompExp {
_eq: String
}
|]
lhsRemoteServerMkLocalState :: State -> IO (Maybe Server)
lhsRemoteServerMkLocalState _ = do
server <-
RemoteServer.run $
RemoteServer.generateQueryInterpreter (Query {hasura_track})
pure $ Just server
where
-- Implements the @hasura_track@ field of the @Query@ type.
hasura_track (HasuraTrackArgs {..}) = do
let filterFunction = case ta_where of
Nothing -> const True
Just whereArg -> flip matchTrack whereArg
orderByFunction = case ta_order_by of
Nothing -> \_ _ -> EQ
Just orderByArg -> orderTrack orderByArg
limitFunction = case ta_limit of
Nothing -> Prelude.id
Just limitArg -> take limitArg
pure $
tracks
& filter filterFunction
& sortBy orderByFunction
& limitFunction
& map mkTrack
-- Returns True iif the given track matches the given boolean expression.
matchTrack trackInfo@(trackId, trackTitle, maybeAlbumId) (HasuraTrackBoolExp {..}) =
and
[ maybe True (all (matchTrack trackInfo)) tbe__and,
maybe True (any (matchTrack trackInfo)) tbe__or,
maybe True (not . matchTrack trackInfo) tbe__not,
maybe True (matchInt trackId) tbe_id,
maybe True (matchString trackTitle) tbe_title,
maybe True (matchMaybeInt maybeAlbumId) tbe_album_id
]
matchInt intField IntCompExp {..} = Just intField == _eq
matchString stringField StringCompExp {..} = Just stringField == _eq
matchMaybeInt maybeIntField IntCompExp {..} = maybeIntField == _eq
-- Returns an ordering between the two given tracks.
orderTrack
orderByList
(trackId1, trackTitle1, trackAlbumId1)
(trackId2, trackTitle2, trackAlbumId2) =
flip foldMap orderByList \HasuraTrackOrderBy {..} ->
if
| Just idOrder <- tob_id -> case idOrder of
Asc -> compare trackId1 trackId2
Desc -> compare trackId2 trackId1
| Just titleOrder <- tob_title -> case titleOrder of
Asc -> compare trackTitle1 trackTitle2
Desc -> compare trackTitle2 trackTitle1
| Just albumIdOrder <- tob_album_id ->
compareWithNullLast albumIdOrder trackAlbumId1 trackAlbumId2
| otherwise ->
error "empty track_order object"
compareWithNullLast Desc x1 x2 = compareWithNullLast Asc x2 x1
compareWithNullLast Asc Nothing Nothing = EQ
compareWithNullLast Asc (Just _) Nothing = LT
compareWithNullLast Asc Nothing (Just _) = GT
compareWithNullLast Asc (Just x1) (Just x2) = compare x1 x2
tracks =
[ (1, "track1_album1", Just 1),
(2, "track2_album1", Just 1),
(3, "track3_album1", Just 1),
(4, "track1_album2", Just 2),
(5, "track2_album2", Just 2),
(6, "track1_album3", Just 3),
(7, "track2_album3", Just 3),
(8, "track_no_album", Nothing)
]
mkTrack (trackId, title, albumId) =
HasuraTrack
{ t_id = pure $ Just trackId,
t_title = pure $ Just title,
t_album_id = pure albumId
}
lhsRemoteServerSetup :: Value -> (State, Maybe Server) -> IO ()
lhsRemoteServerSetup tableName (state, maybeRemoteServer) = case maybeRemoteServer of
Nothing -> error "XToDBObjectRelationshipSpec: remote server local state did not succesfully create a server"
Just remoteServer -> do
let remoteSchemaEndpoint = GraphqlEngine.serverUrl remoteServer ++ "/graphql"
GraphqlEngine.postMetadata_
state
[yaml|
type: bulk
args:
- type: add_remote_schema
args:
name: source
definition:
url: *remoteSchemaEndpoint
- type: create_remote_schema_remote_relationship
args:
remote_schema: source
type_name: hasura_track
name: album
definition:
to_source:
source: target
table: *tableName
relationship_type: object
field_mapping:
album_id: id
|]
lhsRemoteServerTeardown :: (State, Maybe Server) -> IO ()
lhsRemoteServerTeardown (_, maybeServer) = traverse_ stopServer maybeServer
--------------------------------------------------------------------------------
-- RHS Postgres
@ -295,10 +512,7 @@ args:
|]
rhsPostgresTeardown :: (State, ()) -> IO ()
rhsPostgresTeardown (state, _) = do
let sourceName = "target"
Schema.untrackTable Context.Postgres sourceName album state
Postgres.dropTable album
rhsPostgresTeardown _ = Postgres.dropTable album
--------------------------------------------------------------------------------
-- Tests
@ -375,7 +589,7 @@ executionTests opts = describe "execution" $ do
{title: {_eq: "track_no_album"}}
]
},
order_by: {id: asc}
order_by: [{id: asc}]
) {
title
album {
@ -411,7 +625,7 @@ permissionTests opts = describe "permission" $ do
[graphql|
query {
track: hasura_track(
order_by: {id: asc}
order_by: [{id: asc}]
) {
title
album {

246
server/tests-hspec/Test/RemoteRelationship/XToRemoteSchemaRelationshipSpec.hs
View File

@ -1,3 +1,4 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE QuasiQuotes #-}
-- | Tests for remote relationships to remote schemas. Remote relationships are
@ -12,15 +13,23 @@ module Test.RemoteRelationship.XToRemoteSchemaRelationshipSpec
)
where
import Data.Char (isUpper, toLower)
import Data.Foldable (traverse_)
import Data.Function ((&))
import Data.List (intercalate, sortBy)
import Data.List.Split (dropBlanks, keepDelimsL, split, whenElt)
import Data.Morpheus.Document (gqlDocument)
import Data.Morpheus.Types (Arg (..))
import Data.Morpheus.Types
import Data.Morpheus.Types qualified as Morpheus
import Data.Text (Text)
import Data.Typeable (Typeable)
import GHC.Generics (Generic)
import Harness.Backend.Postgres qualified as Postgres
import Harness.GraphqlEngine qualified as GraphqlEngine
import Harness.Quoter.Graphql (graphql)
import Harness.Quoter.Yaml (shouldReturnYaml, yaml)
import Harness.RemoteServer qualified as RemoteServer
import Harness.State (Server, State)
import Harness.State (Server, State, stopServer)
import Harness.Test.Context (Context (..))
import Harness.Test.Context qualified as Context
import Harness.Test.Schema qualified as Schema
@ -33,7 +42,7 @@ import Prelude
spec :: SpecWith State
spec = Context.runWithLocalState contexts tests
where
contexts = map mkContext [lhsPostgres]
contexts = map mkContext [lhsPostgres, lhsRemoteServer]
lhsPostgres =
Context
{ name = Context.Backend Context.Postgres,
@ -42,6 +51,14 @@ spec = Context.runWithLocalState contexts tests
teardown = lhsPostgresTeardown,
customOptions = Nothing
}
lhsRemoteServer =
Context
{ name = Context.RemoteGraphQLServer,
mkLocalState = lhsRemoteServerMkLocalState,
setup = lhsRemoteServerSetup,
teardown = lhsRemoteServerTeardown,
customOptions = Nothing
}
-- | Uses a given RHS context to create a combined context.
mkContext :: Context (Maybe Server) -> Context LocalTestState
@ -154,6 +171,213 @@ lhsPostgresTeardown (state, _) = do
Schema.untrackTable Context.Postgres sourceName track state
Postgres.dropTable track
--------------------------------------------------------------------------------
-- LHS Remote Server
-- | To circumvent Morpheus' default behaviour, which is to capitalize type
-- names and field names for Haskell records to be consistent with their
-- corresponding GraphQL equivalents, we define most of the schema manually with
-- the following options.
hasuraTypeOptions :: Morpheus.GQLTypeOptions
hasuraTypeOptions =
Morpheus.defaultTypeOptions
{ -- transformation to apply to constructors, for enums; we simply map to
-- lower case:
-- Asc -> asc
Morpheus.constructorTagModifier = map toLower,
-- transformation to apply to field names; we drop all characters up to and
-- including the first underscore:
-- hta_where -> where
Morpheus.fieldLabelModifier = tail . dropWhile (/= '_'),
-- transformation to apply to type names; we remove the leading "LHS" we
-- use to differentiate those types from the RHS ones, split the name on
-- uppercase letters, intercalate with underscore, and map everything to
-- lowercase: LHSHasuraTrack -> hasura_track
Morpheus.typeNameModifier = \_ ->
map toLower
. intercalate "_"
. split (dropBlanks $ keepDelimsL $ whenElt isUpper)
. drop 3
}
data LHSQuery m = LHSQuery
{ q_hasura_track :: LHSHasuraTrackArgs -> m [LHSHasuraTrack m]
}
deriving (Generic)
instance Typeable m => Morpheus.GQLType (LHSQuery m) where
typeOptions _ _ = hasuraTypeOptions
data LHSHasuraTrackArgs = LHSHasuraTrackArgs
{ ta_where :: Maybe LHSHasuraTrackBoolExp,
ta_order_by :: Maybe [LHSHasuraTrackOrderBy],
ta_limit :: Maybe Int
}
deriving (Generic)
instance Morpheus.GQLType LHSHasuraTrackArgs where
typeOptions _ _ = hasuraTypeOptions
data LHSHasuraTrack m = LHSHasuraTrack
{ t_id :: m (Maybe Int),
t_title :: m (Maybe Text),
t_album_id :: m (Maybe Int)
}
deriving (Generic)
instance Typeable m => Morpheus.GQLType (LHSHasuraTrack m) where
typeOptions _ _ = hasuraTypeOptions
data LHSHasuraTrackOrderBy = LHSHasuraTrackOrderBy
{ tob_id :: Maybe LHSOrderType,
tob_title :: Maybe LHSOrderType,
tob_album_id :: Maybe LHSOrderType
}
deriving (Generic)
instance Morpheus.GQLType LHSHasuraTrackOrderBy where
typeOptions _ _ = hasuraTypeOptions
data LHSHasuraTrackBoolExp = LHSHasuraTrackBoolExp
{ tbe__and :: Maybe [LHSHasuraTrackBoolExp],
tbe__or :: Maybe [LHSHasuraTrackBoolExp],
tbe__not :: Maybe LHSHasuraTrackBoolExp,
tbe_id :: Maybe IntCompExp,
tbe_title :: Maybe StringCompExp,
tbe_album_id :: Maybe IntCompExp
}
deriving (Generic)
instance Morpheus.GQLType LHSHasuraTrackBoolExp where
typeOptions _ _ = hasuraTypeOptions
data LHSOrderType = Asc | Desc
deriving (Show, Generic)
instance Morpheus.GQLType LHSOrderType where
typeOptions _ _ = hasuraTypeOptions
[gqlDocument|
input IntCompExp {
_eq: Int
}
input StringCompExp {
_eq: String
}
|]
lhsRemoteServerMkLocalState :: State -> IO (Maybe Server)
lhsRemoteServerMkLocalState _ = do
server <-
RemoteServer.run $
RemoteServer.generateQueryInterpreter (LHSQuery {q_hasura_track = hasura_track})
pure $ Just server
where
-- Implements the @hasura_track@ field of the @Query@ type.
hasura_track (LHSHasuraTrackArgs {..}) = do
let filterFunction = case ta_where of
Nothing -> const True
Just whereArg -> flip matchTrack whereArg
orderByFunction = case ta_order_by of
Nothing -> \_ _ -> EQ
Just orderByArg -> orderTrack orderByArg
limitFunction = case ta_limit of
Nothing -> Prelude.id
Just limitArg -> take limitArg
pure $
tracks
& filter filterFunction
& sortBy orderByFunction
& limitFunction
& map mkTrack
-- Returns True iif the given track matches the given boolean expression.
matchTrack trackInfo@(trackId, trackTitle, maybeAlbumId) (LHSHasuraTrackBoolExp {..}) =
and
[ maybe True (all (matchTrack trackInfo)) tbe__and,
maybe True (any (matchTrack trackInfo)) tbe__or,
maybe True (not . matchTrack trackInfo) tbe__not,
maybe True (matchInt trackId) tbe_id,
maybe True (matchString trackTitle) tbe_title,
maybe True (matchMaybeInt maybeAlbumId) tbe_album_id
]
matchInt intField IntCompExp {..} = Just intField == _eq
matchString stringField StringCompExp {..} = Just stringField == _eq
matchMaybeInt maybeIntField IntCompExp {..} = maybeIntField == _eq
-- Returns an ordering between the two given tracks.
orderTrack
orderByList
(trackId1, trackTitle1, trackAlbumId1)
(trackId2, trackTitle2, trackAlbumId2) =
flip foldMap orderByList \LHSHasuraTrackOrderBy {..} ->
if
| Just idOrder <- tob_id -> case idOrder of
Asc -> compare trackId1 trackId2
Desc -> compare trackId2 trackId1
| Just titleOrder <- tob_title -> case titleOrder of
Asc -> compare trackTitle1 trackTitle2
Desc -> compare trackTitle2 trackTitle1
| Just albumIdOrder <- tob_album_id ->
compareWithNullLast albumIdOrder trackAlbumId1 trackAlbumId2
| otherwise ->
error "empty track_order object"
compareWithNullLast Desc x1 x2 = compareWithNullLast Asc x2 x1
compareWithNullLast Asc Nothing Nothing = EQ
compareWithNullLast Asc (Just _) Nothing = LT
compareWithNullLast Asc Nothing (Just _) = GT
compareWithNullLast Asc (Just x1) (Just x2) = compare x1 x2
tracks =
[ (1, "track1_album1", Just 1),
(2, "track2_album1", Just 1),
(3, "track3_album1", Just 1),
(4, "track1_album2", Just 2),
(5, "track2_album2", Just 2),
(6, "track1_album3", Just 3),
(7, "track2_album3", Just 3),
(8, "track_no_album", Nothing)
]
mkTrack (trackId, title, albumId) =
LHSHasuraTrack
{ t_id = pure $ Just trackId,
t_title = pure $ Just title,
t_album_id = pure albumId
}
lhsRemoteServerSetup :: (State, Maybe Server) -> IO ()
lhsRemoteServerSetup (state, maybeRemoteServer) = case maybeRemoteServer of
Nothing -> error "XToDBObjectRelationshipSpec: remote server local state did not succesfully create a server"
Just remoteServer -> do
let remoteSchemaEndpoint = GraphqlEngine.serverUrl remoteServer ++ "/graphql"
GraphqlEngine.postMetadata_
state
[yaml|
type: bulk
args:
- type: add_remote_schema
args:
name: source
definition:
url: *remoteSchemaEndpoint
- type: create_remote_schema_remote_relationship
args:
remote_schema: source
type_name: hasura_track
name: album
definition:
to_remote_schema:
remote_schema: target
lhs_fields: [album_id]
remote_field:
album:
arguments:
album_id: $album_id
|]
lhsRemoteServerTeardown :: (State, Maybe Server) -> IO ()
lhsRemoteServerTeardown (_, maybeServer) = traverse_ stopServer maybeServer
--------------------------------------------------------------------------------
-- RHS Remote Server
@ -203,21 +427,21 @@ args:
|]
rhsRemoteSchemaTeardown :: (State, Server) -> IO ()
rhsRemoteSchemaTeardown (_, server) = GraphqlEngine.stopServer server
rhsRemoteSchemaTeardown (_, server) = stopServer server
--------------------------------------------------------------------------------
-- Tests
tests :: Context.Options -> SpecWith (State, LocalTestState)
tests opts = describe "remote-schema-relationship" $ do
tests opts = describe "remote-schema-relationship" do
schemaTests opts
executionTests opts
-- | Basic queries using *-to-DB joins
executionTests :: Context.Options -> SpecWith (State, LocalTestState)
executionTests opts = describe "execution" $ do
executionTests opts = describe "execution" do
-- fetches the relationship data
it "related-data" $ \(state, _) -> do
it "related-data" \(state, _) -> do
let query =
[graphql|
query {
@ -243,7 +467,7 @@ executionTests opts = describe "execution" $ do
expectedResponse
-- when any of the join columns are null, the relationship should be null
it "related-data-null" $ \(state, _) -> do
it "related-data-null" \(state, _) -> do
let query =
[graphql|
query {
@ -268,7 +492,7 @@ executionTests opts = describe "execution" $ do
expectedResponse
-- when the lhs response has both null and non-null values for join columns
it "related-data-non-null-and-null" $ \(state, _) -> do
it "related-data-non-null-and-null" \(state, _) -> do
let query =
[graphql|
query {
@ -279,7 +503,7 @@ executionTests opts = describe "execution" $ do
{title: {_eq: "track_no_album"}}
]
},
order_by: {id: asc}
order_by: [{id: asc}]
) {
title
album {
@ -309,7 +533,7 @@ schemaTests opts =
-- 1. a field 'album' is added to the track table
-- 1. track's where clause does not have 'album' field
-- 2. track's order_by clause does nat have 'album' field
it "graphql-schema" $ \(state, _) -> do
it "graphql-schema" \(state, _) -> do
let query =
[graphql|
query {

4
server/tests-py/test_schema_stitching.py
View File

@ -197,7 +197,7 @@ class TestRemoteSchemaBasic:
"""add 2 remote schemas with same node or types"""
q = mk_add_remote_q('simple 2', 'http://localhost:5000/hello-graphql')
st_code, resp = hge_ctx.v1q(q)
assert st_code == 400
assert st_code == 400, resp
assert resp['code'] == 'unexpected'
@pytest.mark.allow_server_upgrade_test
@ -346,7 +346,7 @@ class TestAddRemoteSchemaTbls:
"""add remote schema which conflicts with hasura tables"""
q = mk_add_remote_q('simple2', 'http://localhost:5000/hello-graphql')
st_code, resp = hge_ctx.v1q(q)
assert st_code == 400
assert st_code == 400, resp
assert resp['code'] == 'invalid-configuration'
@pytest.mark.allow_server_upgrade_test