2022-04-10 07:47:15 +03:00
|
|
|
module Test.QuerySpec.RelationshipsSpec (spec) where
|
|
|
|
|
2022-09-20 06:59:47 +03:00
|
|
|
import Control.Arrow ((>>>))
|
2022-07-29 11:05:57 +03:00
|
|
|
import Control.Lens (Traversal', ix, (&), (?~), (^.), (^..), (^?), _Just)
|
2022-09-20 06:59:47 +03:00
|
|
|
import Control.Monad (when)
|
2022-09-21 08:11:53 +03:00
|
|
|
import Data.HashMap.Strict (HashMap)
|
2022-09-20 06:59:47 +03:00
|
|
|
import Data.List (sortOn)
|
2022-04-10 07:47:15 +03:00
|
|
|
import Data.List.NonEmpty (NonEmpty (..))
|
2022-09-20 06:59:47 +03:00
|
|
|
import Data.List.NonEmpty qualified as NonEmpty
|
2022-07-20 08:20:49 +03:00
|
|
|
import Data.Maybe (maybeToList)
|
2022-05-02 08:03:12 +03:00
|
|
|
import Hasura.Backends.DataConnector.API
|
2022-04-10 07:47:15 +03:00
|
|
|
import Servant.API (NamedRoutes)
|
|
|
|
import Servant.Client (Client, (//))
|
2022-09-28 02:41:21 +03:00
|
|
|
import Test.Data (TestData (..))
|
2022-04-10 07:47:15 +03:00
|
|
|
import Test.Data qualified as Data
|
2022-08-04 04:00:48 +03:00
|
|
|
import Test.Expectations (jsonShouldBe, rowsShouldBe)
|
2022-04-10 07:47:15 +03:00
|
|
|
import Test.Hspec (Spec, describe, it)
|
|
|
|
import Prelude
|
|
|
|
|
2022-09-28 02:41:21 +03:00
|
|
|
spec :: TestData -> Client IO (NamedRoutes Routes) -> SourceName -> Config -> Maybe SubqueryComparisonCapabilities -> Spec
|
|
|
|
spec TestData {..} api sourceName config subqueryComparisonCapabilities = describe "Relationship Queries" $ do
|
2022-06-24 09:58:25 +03:00
|
|
|
it "perform an object relationship query by joining artist to albums" $ do
|
2022-04-10 07:47:15 +03:00
|
|
|
let query = albumsWithArtistQuery id
|
2022-07-20 08:20:49 +03:00
|
|
|
receivedAlbums <- Data.sortResponseRowsBy "AlbumId" <$> (api // _query) sourceName config query
|
2022-04-10 07:47:15 +03:00
|
|
|
|
2022-09-21 08:11:53 +03:00
|
|
|
let joinInArtist (album :: HashMap FieldName FieldValue) =
|
2022-09-28 02:41:21 +03:00
|
|
|
let artist = (album ^? Data.field "ArtistId" . Data._ColumnFieldNumber) >>= \artistId -> _tdArtistsRowsById ^? ix artistId
|
2022-07-20 08:20:49 +03:00
|
|
|
artistPropVal = maybeToList artist
|
2022-09-21 08:11:53 +03:00
|
|
|
in Data.insertField "Artist" (mkSubqueryResponse artistPropVal) album
|
|
|
|
let removeArtistId = Data.deleteField "ArtistId"
|
2022-04-10 07:47:15 +03:00
|
|
|
|
2022-09-28 02:41:21 +03:00
|
|
|
let expectedAlbums = (removeArtistId . joinInArtist) <$> _tdAlbumsRows
|
2022-08-04 04:00:48 +03:00
|
|
|
Data.responseRows receivedAlbums `rowsShouldBe` expectedAlbums
|
|
|
|
_qrAggregates receivedAlbums `jsonShouldBe` Nothing
|
2022-04-10 07:47:15 +03:00
|
|
|
|
2022-06-24 09:58:25 +03:00
|
|
|
it "perform an array relationship query by joining albums to artists" $ do
|
2022-04-10 07:47:15 +03:00
|
|
|
let query = artistsWithAlbumsQuery id
|
2022-07-20 08:20:49 +03:00
|
|
|
receivedArtists <- Data.sortResponseRowsBy "ArtistId" <$> (api // _query) sourceName config query
|
2022-04-10 07:47:15 +03:00
|
|
|
|
2022-09-21 08:11:53 +03:00
|
|
|
let joinInAlbums (artist :: HashMap FieldName FieldValue) =
|
|
|
|
let artistId = artist ^? Data.field "ArtistId" . Data._ColumnFieldNumber
|
|
|
|
albumFilter artistId' album = album ^? Data.field "ArtistId" . Data._ColumnFieldNumber == Just artistId'
|
2022-09-28 02:41:21 +03:00
|
|
|
albums = maybe [] (\artistId' -> filter (albumFilter artistId') _tdAlbumsRows) artistId
|
2022-09-21 08:11:53 +03:00
|
|
|
albums' = Data.deleteField "ArtistId" <$> albums
|
|
|
|
in Data.insertField "Albums" (mkSubqueryResponse albums') artist
|
2022-04-10 07:47:15 +03:00
|
|
|
|
2022-09-28 02:41:21 +03:00
|
|
|
let expectedAlbums = joinInAlbums <$> _tdArtistsRows
|
2022-08-04 04:00:48 +03:00
|
|
|
Data.responseRows receivedArtists `rowsShouldBe` expectedAlbums
|
|
|
|
_qrAggregates receivedArtists `jsonShouldBe` Nothing
|
2022-04-10 07:47:15 +03:00
|
|
|
|
2022-09-20 06:59:47 +03:00
|
|
|
it "perform an array relationship query by joining albums to artists with pagination of albums" $ do
|
|
|
|
let albumsOrdering = OrderBy mempty $ NonEmpty.fromList [OrderByElement [] (OrderByColumn $ ColumnName "AlbumId") Ascending]
|
|
|
|
let query = artistsWithAlbumsQuery (qOffset ?~ 1 >>> qLimit ?~ 2 >>> qOrderBy ?~ albumsOrdering)
|
|
|
|
receivedArtists <- Data.sortResponseRowsBy "ArtistId" <$> (api // _query) sourceName config query
|
|
|
|
|
2022-09-21 08:11:53 +03:00
|
|
|
let joinInAlbums (artist :: HashMap FieldName FieldValue) = do
|
|
|
|
let artistId = artist ^? Data.field "ArtistId" . Data._ColumnFieldNumber
|
|
|
|
albumFilter artistId' album = album ^? Data.field "ArtistId" . Data._ColumnFieldNumber == Just artistId'
|
2022-09-28 02:41:21 +03:00
|
|
|
albums = maybe [] (\artistId' -> filter (albumFilter artistId') _tdAlbumsRows) artistId
|
2022-09-21 08:11:53 +03:00
|
|
|
paginatedAlbums = albums & sortOn (^? Data.field "ArtistId") & drop 1 & take 2
|
|
|
|
paginatedAlbums' = Data.deleteField "ArtistId" <$> paginatedAlbums
|
|
|
|
in Data.insertField "Albums" (mkSubqueryResponse paginatedAlbums') artist
|
2022-09-20 06:59:47 +03:00
|
|
|
|
2022-09-28 02:41:21 +03:00
|
|
|
let expectedAlbums = joinInAlbums <$> _tdArtistsRows
|
2022-09-20 06:59:47 +03:00
|
|
|
Data.responseRows receivedArtists `rowsShouldBe` expectedAlbums
|
|
|
|
_qrAggregates receivedArtists `jsonShouldBe` Nothing
|
|
|
|
|
2022-09-21 13:46:46 +03:00
|
|
|
when ((_ctccSupportsRelations <$> subqueryComparisonCapabilities) == Just True) $
|
2022-09-20 06:59:47 +03:00
|
|
|
describe "Cross related table comparisons" $ do
|
|
|
|
it "perform an object relationship query by joining employee to customers and filter comparing columns across the object relationship" $ do
|
|
|
|
-- Join Employee to Customers via SupportRep, and only get those customers that have a rep
|
|
|
|
-- that is in the same country as the customer
|
|
|
|
-- This sort of thing would come from a permissions filter on Customer that looks like:
|
|
|
|
-- { SupportRep: { Country: { _ceq: [ "$", "Country" ] } } }
|
|
|
|
let where' =
|
2022-09-28 02:41:21 +03:00
|
|
|
Exists (RelatedTable _tdSupportRepRelationshipName) $
|
2022-09-20 06:59:47 +03:00
|
|
|
ApplyBinaryComparisonOperator
|
|
|
|
Equal
|
|
|
|
(Data.currentComparisonColumn "Country")
|
|
|
|
(AnotherColumn (Data.queryComparisonColumn "Country"))
|
|
|
|
let query = customersWithSupportRepQuery id & qrQuery . qWhere ?~ where'
|
|
|
|
receivedCustomers <- Data.sortResponseRowsBy "CustomerId" <$> (api // _query) sourceName config query
|
|
|
|
|
2022-09-21 08:11:53 +03:00
|
|
|
let joinInSupportRep (customer :: HashMap FieldName FieldValue) =
|
2022-09-28 02:41:21 +03:00
|
|
|
let supportRep = (customer ^? Data.field "SupportRepId" . Data._ColumnFieldNumber) >>= \employeeId -> _tdEmployeesRowsById ^? ix employeeId
|
2022-09-20 06:59:47 +03:00
|
|
|
supportRepPropVal = maybeToList $ Data.filterColumnsByQueryFields employeesQuery <$> supportRep
|
2022-09-21 08:11:53 +03:00
|
|
|
in Data.insertField "SupportRep" (mkSubqueryResponse supportRepPropVal) customer
|
2022-09-20 06:59:47 +03:00
|
|
|
|
2022-09-21 08:11:53 +03:00
|
|
|
let filterCustomersBySupportRepCountry (customer :: HashMap FieldName FieldValue) =
|
|
|
|
let customerCountry = customer ^? Data.field "Country" . Data._ColumnFieldString
|
|
|
|
supportRepCountry = customer ^.. Data.field "SupportRep" . subqueryRows . Data.field "Country" . Data._ColumnFieldString
|
2022-10-04 00:49:32 +03:00
|
|
|
in any (`elem` supportRepCountry) customerCountry
|
2022-09-20 06:59:47 +03:00
|
|
|
|
2022-09-28 02:41:21 +03:00
|
|
|
let expectedCustomers = filter filterCustomersBySupportRepCountry $ Data.filterColumnsByQueryFields (query ^. qrQuery) . joinInSupportRep <$> _tdCustomersRows
|
2022-09-20 06:59:47 +03:00
|
|
|
Data.responseRows receivedCustomers `rowsShouldBe` expectedCustomers
|
|
|
|
_qrAggregates receivedCustomers `jsonShouldBe` Nothing
|
|
|
|
|
|
|
|
it "perform an array relationship query by joining customers to employees and filter comparing columns across the array relationship" $ do
|
|
|
|
-- Join Customers to Employees via SupportRepForCustomers, and only get those employees that are reps for
|
|
|
|
-- customers that are in the same country as the employee
|
|
|
|
-- This sort of thing would come from a permissions filter on Employees that looks like:
|
|
|
|
-- { SupportRepForCustomers: { Country: { _ceq: [ "$", "Country" ] } } }
|
|
|
|
let where' =
|
2022-09-28 02:41:21 +03:00
|
|
|
Exists (RelatedTable _tdSupportRepForCustomersRelationshipName) $
|
2022-09-20 06:59:47 +03:00
|
|
|
ApplyBinaryComparisonOperator
|
|
|
|
Equal
|
|
|
|
(Data.currentComparisonColumn "Country")
|
|
|
|
(AnotherColumn (Data.queryComparisonColumn "Country"))
|
|
|
|
let query = employeesWithCustomersQuery id & qrQuery . qWhere ?~ where'
|
|
|
|
receivedEmployees <- Data.sortResponseRowsBy "EmployeeId" <$> (api // _query) sourceName config query
|
|
|
|
|
2022-09-21 08:11:53 +03:00
|
|
|
let joinInCustomers (employee :: HashMap FieldName FieldValue) =
|
|
|
|
let employeeId = employee ^? Data.field "EmployeeId" . Data._ColumnFieldNumber
|
|
|
|
customerFilter employeeId' customer = customer ^? Data.field "SupportRepId" . Data._ColumnFieldNumber == Just employeeId'
|
2022-09-28 02:41:21 +03:00
|
|
|
customers = maybe [] (\employeeId' -> filter (customerFilter employeeId') _tdCustomersRows) employeeId
|
2022-09-20 06:59:47 +03:00
|
|
|
customers' = Data.filterColumnsByQueryFields customersQuery <$> customers
|
2022-09-21 08:11:53 +03:00
|
|
|
in Data.insertField "SupportRepForCustomers" (mkSubqueryResponse customers') employee
|
2022-09-20 06:59:47 +03:00
|
|
|
|
2022-09-21 08:11:53 +03:00
|
|
|
let filterEmployeesByCustomerCountry (employee :: HashMap FieldName FieldValue) =
|
|
|
|
let employeeCountry = employee ^? Data.field "Country" . Data._ColumnFieldString
|
|
|
|
customerCountries = employee ^.. Data.field "SupportRepForCustomers" . subqueryRows . Data.field "Country" . Data._ColumnFieldString
|
2022-10-04 00:49:32 +03:00
|
|
|
in any (`elem` customerCountries) employeeCountry
|
2022-09-20 06:59:47 +03:00
|
|
|
|
2022-09-28 02:41:21 +03:00
|
|
|
let expectedEmployees = filter filterEmployeesByCustomerCountry $ Data.filterColumnsByQueryFields (query ^. qrQuery) . joinInCustomers <$> _tdEmployeesRows
|
2022-09-20 06:59:47 +03:00
|
|
|
Data.responseRows receivedEmployees `rowsShouldBe` expectedEmployees
|
|
|
|
_qrAggregates receivedEmployees `jsonShouldBe` Nothing
|
|
|
|
|
|
|
|
it "perform an object relationship query by joining employee to customers but filter employees by comparing columns on the employee" $ do
|
|
|
|
-- Join Employee to Customers via SupportRep, and only get those customers that have a rep
|
|
|
|
-- However, the Employee table is filtered with a permission rule that compares columns on that table.
|
|
|
|
-- This Employee table permissions filter would look like:
|
|
|
|
-- { FirstName: { _cgt: ["LastName"] } }
|
|
|
|
let customersWhere =
|
2022-09-28 02:41:21 +03:00
|
|
|
Exists (RelatedTable _tdSupportRepRelationshipName) $
|
2022-09-20 06:59:47 +03:00
|
|
|
And
|
|
|
|
[ ( ApplyBinaryComparisonOperator
|
|
|
|
GreaterThan
|
|
|
|
(Data.currentComparisonColumn "FirstName")
|
|
|
|
(AnotherColumn (Data.currentComparisonColumn "LastName"))
|
|
|
|
),
|
|
|
|
(Not (ApplyUnaryComparisonOperator IsNull (Data.currentComparisonColumn "EmployeeId")))
|
|
|
|
]
|
|
|
|
|
|
|
|
let employeesWhere =
|
|
|
|
ApplyBinaryComparisonOperator
|
|
|
|
GreaterThan
|
|
|
|
(Data.currentComparisonColumn "FirstName")
|
|
|
|
(AnotherColumn (Data.currentComparisonColumn "LastName"))
|
|
|
|
|
|
|
|
let query = customersWithSupportRepQuery (\q -> q & qWhere ?~ employeesWhere) & qrQuery . qWhere ?~ customersWhere
|
|
|
|
receivedCustomers <- Data.sortResponseRowsBy "CustomerId" <$> (api // _query) sourceName config query
|
|
|
|
|
2022-09-21 08:11:53 +03:00
|
|
|
let joinInSupportRep (customer :: HashMap FieldName FieldValue) =
|
2022-09-20 06:59:47 +03:00
|
|
|
let supportRep = do
|
2022-09-21 08:11:53 +03:00
|
|
|
employeeId <- (customer ^? Data.field "SupportRepId" . Data._ColumnFieldNumber)
|
2022-09-28 02:41:21 +03:00
|
|
|
employee <- _tdEmployeesRowsById ^? ix employeeId
|
2022-09-21 08:11:53 +03:00
|
|
|
firstName <- employee ^? Data.field "FirstName"
|
|
|
|
lastName <- employee ^? Data.field "LastName"
|
2022-09-20 06:59:47 +03:00
|
|
|
if firstName > lastName then pure employee else Nothing
|
|
|
|
supportRepPropVal = maybeToList $ Data.filterColumnsByQueryFields employeesQuery <$> supportRep
|
2022-09-21 08:11:53 +03:00
|
|
|
in Data.insertField "SupportRep" (mkSubqueryResponse supportRepPropVal) customer
|
2022-09-20 06:59:47 +03:00
|
|
|
|
2022-09-21 08:11:53 +03:00
|
|
|
let filterCustomersBySupportRepExistence (customer :: HashMap FieldName FieldValue) =
|
|
|
|
let supportRep = customer ^.. Data.field "SupportRep" . subqueryRows
|
2022-09-20 06:59:47 +03:00
|
|
|
in not (null supportRep)
|
|
|
|
|
2022-09-28 02:41:21 +03:00
|
|
|
let expectedCustomers = filter filterCustomersBySupportRepExistence $ Data.filterColumnsByQueryFields (query ^. qrQuery) . joinInSupportRep <$> _tdCustomersRows
|
2022-09-20 06:59:47 +03:00
|
|
|
Data.responseRows receivedCustomers `rowsShouldBe` expectedCustomers
|
|
|
|
_qrAggregates receivedCustomers `jsonShouldBe` Nothing
|
2022-09-28 02:41:21 +03:00
|
|
|
where
|
|
|
|
albumsWithArtistQuery :: (Query -> Query) -> QueryRequest
|
|
|
|
albumsWithArtistQuery modifySubquery =
|
|
|
|
let artistsSubquery = modifySubquery artistsQuery
|
|
|
|
fields =
|
|
|
|
Data.mkFieldsMap
|
|
|
|
[ ("AlbumId", Data.columnField "AlbumId"),
|
|
|
|
("Title", Data.columnField "Title"),
|
|
|
|
("Artist", RelField $ RelationshipField _tdArtistRelationshipName artistsSubquery)
|
|
|
|
]
|
|
|
|
query = albumsQuery & qFields ?~ fields
|
|
|
|
in QueryRequest _tdAlbumsTableName [Data.onlyKeepRelationships [_tdArtistRelationshipName] _tdAlbumsTableRelationships] query
|
|
|
|
|
|
|
|
artistsWithAlbumsQuery :: (Query -> Query) -> QueryRequest
|
|
|
|
artistsWithAlbumsQuery modifySubquery =
|
|
|
|
let albumFields = Data.mkFieldsMap [("AlbumId", Data.columnField "AlbumId"), ("Title", Data.columnField "Title")]
|
|
|
|
albumsSort = OrderBy mempty $ Data.orderByColumn [] "AlbumId" Ascending :| []
|
|
|
|
albumsSubquery = albumsQuery & qFields ?~ albumFields & qOrderBy ?~ albumsSort & modifySubquery
|
|
|
|
fields =
|
|
|
|
Data.mkFieldsMap
|
|
|
|
[ ("ArtistId", Data.columnField "ArtistId"),
|
|
|
|
("Name", Data.columnField "Name"),
|
|
|
|
("Albums", RelField $ RelationshipField _tdAlbumsRelationshipName albumsSubquery)
|
|
|
|
]
|
|
|
|
query = artistsQuery & qFields ?~ fields
|
|
|
|
in QueryRequest _tdArtistsTableName [Data.onlyKeepRelationships [_tdAlbumsRelationshipName] _tdArtistsTableRelationships] query
|
|
|
|
|
|
|
|
employeesWithCustomersQuery :: (Query -> Query) -> QueryRequest
|
|
|
|
employeesWithCustomersQuery modifySubquery =
|
|
|
|
let customersSort = OrderBy mempty $ Data.orderByColumn [] "CustomerId" Ascending :| []
|
|
|
|
customersSubquery = customersQuery & qOrderBy ?~ customersSort & modifySubquery
|
|
|
|
fields =
|
|
|
|
Data.queryFields employeesQuery
|
|
|
|
<> Data.mkFieldsMap
|
|
|
|
[ ("SupportRepForCustomers", RelField $ RelationshipField _tdSupportRepForCustomersRelationshipName customersSubquery)
|
|
|
|
]
|
|
|
|
query = employeesQuery & qFields ?~ fields
|
|
|
|
in QueryRequest _tdEmployeesTableName [Data.onlyKeepRelationships [_tdSupportRepForCustomersRelationshipName] _tdEmployeesTableRelationships] query
|
|
|
|
|
|
|
|
customersWithSupportRepQuery :: (Query -> Query) -> QueryRequest
|
|
|
|
customersWithSupportRepQuery modifySubquery =
|
|
|
|
let supportRepSubquery = employeesQuery & modifySubquery
|
|
|
|
fields =
|
|
|
|
Data.queryFields customersQuery
|
|
|
|
<> Data.mkFieldsMap
|
|
|
|
[ ("SupportRep", RelField $ RelationshipField _tdSupportRepRelationshipName supportRepSubquery)
|
|
|
|
]
|
|
|
|
query = customersQuery & qFields ?~ fields
|
|
|
|
in QueryRequest _tdCustomersTableName [Data.onlyKeepRelationships [_tdSupportRepRelationshipName] _tdCustomersTableRelationships] query
|
|
|
|
|
|
|
|
artistsQuery :: Query
|
|
|
|
artistsQuery =
|
|
|
|
let fields = Data.mkFieldsMap [("ArtistId", Data.columnField "ArtistId"), ("Name", Data.columnField "Name")]
|
|
|
|
in Data.emptyQuery & qFields ?~ fields
|
|
|
|
|
|
|
|
albumsQuery :: Query
|
|
|
|
albumsQuery =
|
|
|
|
let fields = Data.mkFieldsMap [("AlbumId", Data.columnField "AlbumId"), ("ArtistId", Data.columnField "ArtistId"), ("Title", Data.columnField "Title")]
|
|
|
|
in Data.emptyQuery & qFields ?~ fields
|
|
|
|
|
|
|
|
customersQuery :: Query
|
|
|
|
customersQuery =
|
|
|
|
let fields =
|
|
|
|
Data.mkFieldsMap
|
|
|
|
[ ("CustomerId", Data.columnField "CustomerId"),
|
|
|
|
("FirstName", Data.columnField "FirstName"),
|
|
|
|
("LastName", Data.columnField "LastName"),
|
|
|
|
("Country", Data.columnField "Country"),
|
|
|
|
("SupportRepId", Data.columnField "SupportRepId")
|
|
|
|
]
|
|
|
|
in Data.emptyQuery & qFields ?~ fields
|
|
|
|
|
|
|
|
employeesQuery :: Query
|
|
|
|
employeesQuery =
|
|
|
|
let fields =
|
|
|
|
Data.mkFieldsMap
|
|
|
|
[ ("EmployeeId", Data.columnField "EmployeeId"),
|
|
|
|
("FirstName", Data.columnField "FirstName"),
|
|
|
|
("LastName", Data.columnField "LastName"),
|
|
|
|
("Country", Data.columnField "Country")
|
|
|
|
]
|
|
|
|
in Data.emptyQuery & qFields ?~ fields
|
|
|
|
|
|
|
|
mkSubqueryResponse :: [HashMap FieldName FieldValue] -> FieldValue
|
|
|
|
mkSubqueryResponse rows =
|
|
|
|
mkRelationshipFieldValue $ QueryResponse (Just rows) Nothing
|
|
|
|
|
|
|
|
subqueryRows :: Traversal' FieldValue (HashMap FieldName FieldValue)
|
|
|
|
subqueryRows = _RelationshipFieldValue . qrRows . _Just . traverse
|