Feature/gdw 113

PR-URL: https://github.com/hasura/graphql-engine-mono/pull/4620
GitOrigin-RevId: f732fff4f3f2449ebc97f76522ee6ad11bcfbc68

server/src-dc-api/Hasura/Backends/DataConnector/API/V0/Query.hs

@@ -8,6 +8,7 @@ module Hasura.Backends.DataConnector.API.V0.Query
   ( Query (..),
     Field (..),
     RelField (..),
+    RelType (..),
     ForeignKey (..),
     PrimaryKey (..),
     QueryResponse (..),
@@ -63,8 +64,17 @@ instance HasCodec Query where
 
 --------------------------------------------------------------------------------
 
+data RelType = ObjectRelationship | ArrayRelationship
+  deriving stock (Eq, Ord, Show, Generic, Data)
+
+instance HasCodec RelType where
+  codec =
+    named "RelType" $
+      disjointStringConstCodec [(ObjectRelationship, "object"), (ArrayRelationship, "array")]
+
 data RelField = RelField
   { columnMapping :: M.HashMap PrimaryKey ForeignKey,
+    relationType :: RelType,
     query :: Query
   }
   deriving stock (Eq, Ord, Show, Generic, Data)
@@ -73,6 +83,7 @@ instance HasObjectCodec RelField where
   objectCodec =
     RelField
       <$> requiredField "column_mapping" "Mapping from local fields to remote fields" .= columnMapping
+      <*> requiredField "relation_type" "Relation Type" .= relationType
       <*> requiredField "query" "Relationship query" .= query
 
 --------------------------------------------------------------------------------

server/src-dc-api/Hasura/Backends/DataConnector/Agent/Query.hs

@@ -124,9 +124,16 @@ projectRow fields performQuery r@(Row row) = forM fields $ \case
   API.RelationshipField relField ->
     let subquery = createSubqueryForRelationshipField r relField
      in case subquery of
-          Just subQuery -> do
-            API.QueryResponse obj <- performQuery subQuery
-            pure $ J.Array $ fmap J.Object $ V.fromList obj
+          Just subQuery ->
+            case API.relationType relField of
+              API.ArrayRelationship -> do
+                API.QueryResponse obj <- performQuery subQuery
+                pure $ J.Array $ fmap J.Object $ V.fromList obj
+              API.ObjectRelationship -> do
+                API.QueryResponse obj <- performQuery subQuery
+                if null obj
+                  then pure J.Null
+                  else pure $ J.Object $ head obj
           Nothing -> pure $ J.Array mempty
 
 queryHandler :: StaticData -> API.SourceName -> API.Config -> API.Query -> Handler API.QueryResponse

server/src-lib/Hasura/Backends/DataConnector/Adapter/Execute.hs

@@ -31,29 +31,29 @@ import Hasura.Tracing qualified as Tracing
 --------------------------------------------------------------------------------
 
 instance BackendExecute 'DataConnector where
-  type PreparedQuery 'DataConnector = DC.Plan
+  type PreparedQuery 'DataConnector = IR.Q.Query
   type MultiplexedQuery 'DataConnector = Void
   type ExecutionMonad 'DataConnector = Tracing.TraceT (ExceptT QErr IO)
 
   mkDBQueryPlan UserInfo {..} sourceName sourceConfig ir = do
-    plan' <- DC.mkPlan _uiSession sourceConfig ir
+    query' <- DC.mkPlan _uiSession sourceConfig ir
     pure
       DBStepInfo
         { dbsiSourceName = sourceName,
           dbsiSourceConfig = sourceConfig,
-          dbsiPreparedQuery = Just plan',
-          dbsiAction = buildAction sourceName sourceConfig (DC.query plan')
+          dbsiPreparedQuery = Just query',
+          dbsiAction = buildAction sourceName sourceConfig query'
         }
 
   mkDBQueryExplain fieldName UserInfo {..} sourceName sourceConfig ir = do
-    plan' <- DC.mkPlan _uiSession sourceConfig ir
+    query' <- DC.mkPlan _uiSession sourceConfig ir
     pure $
       mkAnyBackend @'DataConnector
         DBStepInfo
           { dbsiSourceName = sourceName,
             dbsiSourceConfig = sourceConfig,
-            dbsiPreparedQuery = Just plan',
-            dbsiAction = pure . encJFromJValue . toExplainPlan fieldName $ plan'
+            dbsiPreparedQuery = Just query',
+            dbsiAction = pure . encJFromJValue . toExplainPlan fieldName $ query'
           }
   mkDBMutationPlan _ _ _ _ _ =
     throw400 NotSupported "mkDBMutationPlan: not implemented for the Data Connector backend."
@@ -66,9 +66,9 @@ instance BackendExecute 'DataConnector where
   mkSubscriptionExplain _ =
     throw400 NotSupported "mkSubscriptionExplain: not implemented for the Data Connector backend."
 
-toExplainPlan :: GQL.RootFieldAlias -> DC.Plan -> ExplainPlan
-toExplainPlan fieldName plan_ =
-  ExplainPlan fieldName (Just "") (Just [TE.decodeUtf8 $ BL.toStrict $ J.encode $ DC.query $ plan_])
+toExplainPlan :: GQL.RootFieldAlias -> IR.Q.Query -> ExplainPlan
+toExplainPlan fieldName query' =
+  ExplainPlan fieldName (Just "") (Just [TE.decodeUtf8 $ BL.toStrict $ J.encode $ query'])
 
 buildAction :: RQL.SourceName -> DC.SourceConfig -> IR.Q.Query -> Tracing.TraceT (ExceptT QErr IO) EncJSON
 buildAction sourceName DC.SourceConfig {..} query = do

server/src-lib/Hasura/Backends/DataConnector/Adapter/Transport.hs

@@ -9,6 +9,7 @@ import Data.Aeson qualified as J
 import Data.Text.Extended ((<>>))
 import Hasura.Backends.DataConnector.Adapter.Execute ()
 import Hasura.Backends.DataConnector.Adapter.Types (SourceConfig)
+import Hasura.Backends.DataConnector.IR.Query qualified as IR.Q
 import Hasura.Backends.DataConnector.Plan qualified as DC
 import Hasura.Base.Error (Code (NotSupported), QErr, throw400)
 import Hasura.EncJSON (EncJSON)
@@ -49,7 +50,7 @@ runDBQuery' ::
   Logger Hasura ->
   SourceConfig ->
   Tracing.TraceT (ExceptT QErr IO) a ->
-  Maybe DC.Plan ->
+  Maybe IR.Q.Query ->
   m (DiffTime, a)
 runDBQuery' requestId query fieldName _userInfo logger _sourceConfig action ir = do
   void $ HGL.logQueryLog logger $ mkQueryLog query fieldName ir requestId
@@ -61,13 +62,13 @@ runDBQuery' requestId query fieldName _userInfo logger _sourceConfig action ir =
 mkQueryLog ::
   GQLReqUnparsed ->
   RootFieldAlias ->
-  Maybe DC.Plan ->
+  Maybe IR.Q.Query ->
   RequestId ->
   HGL.QueryLog
-mkQueryLog gqlQuery fieldName maybePlan requestId =
+mkQueryLog gqlQuery fieldName maybeQuery requestId =
   HGL.QueryLog
     gqlQuery
-    ((\plan -> (fieldName, HGL.GeneratedQuery (DC.renderPlan plan) J.Null)) <$> maybePlan)
+    ((\query -> (fieldName, HGL.GeneratedQuery (DC.renderQuery query) J.Null)) <$> maybeQuery)
     requestId
     HGL.QueryLogKindDatabase
 

server/src-lib/Hasura/Backends/DataConnector/IR/Export.hs

@@ -41,6 +41,6 @@ fromField = \case
   IR.Q.Literal lit -> Left $ ExposedLiteral lit
 
 rcToAPI :: IR.Q.RelationshipContents -> Either QueryError API.Field
-rcToAPI (IR.Q.RelationshipContents joinCondition query) =
+rcToAPI (IR.Q.RelationshipContents joinCondition relType query) =
   let joinCondition' = M.mapKeys Witch.from $ fmap Witch.from joinCondition
-   in fmap (API.RelationshipField . API.RelField joinCondition') $ queryToAPI query
+   in fmap (API.RelationshipField . API.RelField joinCondition' (Witch.from relType)) $ queryToAPI query

server/src-lib/Hasura/Backends/DataConnector/IR/Query.hs

@@ -4,6 +4,7 @@ module Hasura.Backends.DataConnector.IR.Query
     Cardinality (..),
     ColumnContents (..),
     RelationshipContents (..),
+    RelType (..),
     PrimaryKey (..),
     ForeignKey (..),
   )
@@ -111,13 +112,26 @@ instance Witch.From ColumnContents API.Field where
 -- NOTE: The 'ToJSON' instance is only intended for logging purposes.
 data RelationshipContents = RelationshipContents
   { joinCondition :: HashMap PrimaryKey ForeignKey,
+    relationType :: RelType,
     query :: Query
   }
-  deriving stock (Data, Eq, Generic, Ord, Show)
+  deriving stock (Eq, Ord, Show, Generic, Data)
 
 instance ToJSON RelationshipContents where
   toJSON = J.genericToJSON J.defaultOptions
 
+-- | Relationships can either be Object (One-To-One) or Array (One-To-Many) type.
+data RelType = ObjectRelationship | ArrayRelationship
+  deriving stock (Eq, Ord, Show, Generic, Data)
+
+instance ToJSON RelType where
+  toJSON = J.genericToJSON J.defaultOptions
+
+instance Witch.From RelType API.RelType where
+  from = \case
+    ObjectRelationship -> API.ObjectRelationship
+    ArrayRelationship -> API.ArrayRelationship
+
 --------------------------------------------------------------------------------
 
 -- | TODO

server/src-lib/Hasura/Backends/DataConnector/Plan.hs

@@ -1,10 +1,7 @@
-{-# LANGUAGE NamedFieldPuns #-}
-
 module Hasura.Backends.DataConnector.Plan
   ( SourceConfig (..),
-    Plan (..),
     mkPlan,
-    renderPlan,
+    renderQuery,
     queryHasRelations,
   )
 where
@@ -12,7 +9,6 @@ where
 --------------------------------------------------------------------------------
 
 import Data.Aeson qualified as J
-import Data.Align
 import Data.ByteString.Lazy qualified as BL
 import Data.HashMap.Strict qualified as HashMap
 import Data.List.NonEmpty qualified as NE
@@ -20,9 +16,6 @@ import Data.Semigroup (Any (..), Min (..))
 import Data.Text as T
 import Data.Text.Encoding qualified as TE
 import Data.Text.Extended ((<>>))
-import Data.These
-import Data.Vector qualified as V
-import Hasura.Backends.DataConnector.API qualified as API
 import Hasura.Backends.DataConnector.Adapter.Types
 import Hasura.Backends.DataConnector.IR.Column qualified as IR.C
 import Hasura.Backends.DataConnector.IR.Export qualified as IR
@@ -43,15 +36,6 @@ import Hasura.Session
 
 --------------------------------------------------------------------------------
 
--- | A 'Plan' consists of an 'IR.Q' describing the query to be
--- performed by the Agent and a continuation for post processing the
--- response. See the 'postProcessResponseRow' haddock for more
--- information on why we need a post-processor.
-data Plan = Plan
-  { query :: IR.Q.Query,
-    postProcessor :: (API.QueryResponse -> Either ResponseError API.QueryResponse)
-  }
-
 -- | Error type for the postProcessor continuation. Failure can occur if the Agent
 -- returns bad data.
 data ResponseError
@@ -65,9 +49,9 @@ data ResponseError
 -- | Extract the 'IR.Q' from a 'Plan' and render it as 'Text'.
 --
 -- NOTE: This is for logging and debug purposes only.
-renderPlan :: Plan -> Text
-renderPlan =
-  TE.decodeUtf8 . BL.toStrict . J.encode . IR.queryToAPI . query
+renderQuery :: IR.Q.Query -> Text
+renderQuery =
+  TE.decodeUtf8 . BL.toStrict . J.encode . IR.queryToAPI
 
 -- | Map a 'QueryDB 'DataConnector' term into a 'Plan'
 mkPlan ::
@@ -76,24 +60,16 @@ mkPlan ::
   SessionVariables ->
   SourceConfig ->
   QueryDB 'DataConnector Void (UnpreparedValue 'DataConnector) ->
-  m Plan
-mkPlan session (SourceConfig {..}) ir = translateQueryDB ir
+  m IR.Q.Query
+mkPlan session (SourceConfig {}) ir = translateQueryDB ir
   where
     translateQueryDB ::
       QueryDB 'DataConnector Void (UnpreparedValue 'DataConnector) ->
-      m Plan
+      m IR.Q.Query
     translateQueryDB =
       \case
-        QDBMultipleRows s -> do
-          query <- translateAnnSelect IR.Q.Many s
-          pure $
-            Plan query $ \API.QueryResponse {getQueryResponse = response} ->
-              fmap API.QueryResponse $ traverse (postProcessResponseRow _scCapabilities query) response
-        QDBSingleRow s -> do
-          query <- translateAnnSelect IR.Q.OneOrZero s
-          pure $
-            Plan query $ \API.QueryResponse {getQueryResponse = response} ->
-              fmap API.QueryResponse $ traverse (postProcessResponseRow _scCapabilities query) response
+        QDBMultipleRows s -> translateAnnSelect IR.Q.Many s
+        QDBSingleRow s -> translateAnnSelect IR.Q.OneOrZero s
         QDBAggregation {} -> throw400 NotSupported "QDBAggregation: not supported"
 
     translateAnnSelect ::
@@ -177,6 +153,7 @@ mkPlan session (SourceConfig {..}) ir = translateQueryDB ir
         pure . Just . IR.Q.Relationship $
           IR.Q.RelationshipContents
             (HashMap.mapKeys IR.Q.PrimaryKey . fmap IR.Q.ForeignKey $ _aarColumnMapping objRel)
+            IR.Q.ObjectRelationship
             ( IR.Q.Query
                 { fields = fields,
                   from = _aosTableFrom (_aarAnnSelect objRel),
@@ -192,6 +169,7 @@ mkPlan session (SourceConfig {..}) ir = translateQueryDB ir
         pure . Just . IR.Q.Relationship $
           IR.Q.RelationshipContents
             (HashMap.mapKeys IR.Q.PrimaryKey $ fmap IR.Q.ForeignKey $ _aarColumnMapping arrRel)
+            IR.Q.ArrayRelationship
             query
       AFArrayRelation (ASAggregate _) ->
         throw400 NotSupported "translateField: AFArrayRelation ASAggregate not supported"
@@ -301,62 +279,6 @@ mkPlan session (SourceConfig {..}) ir = translateQueryDB ir
         mkApplyBinaryComparisonOperatorToScalar operator value =
           IR.E.ApplyBinaryComparisonOperator operator columnName (IR.E.ScalarValue value)
 
--- | We need to modify any JSON substructures which appear as a result
--- of fetching object relationships, to peel off the outer array sent
--- by the backend.
---
--- This function takes a response object, and the 'Plan' used to
--- fetch it, and modifies any such arrays accordingly.
-postProcessResponseRow ::
-  API.Capabilities ->
-  IR.Q.Query ->
-  J.Object ->
-  Either ResponseError J.Object
-postProcessResponseRow capabilities IR.Q.Query {fields} row =
-  sequenceA $ alignWith go fields row
-  where
-    go :: These IR.Q.Field J.Value -> Either ResponseError J.Value
-    go (This field) =
-      case field of
-        IR.Q.Literal literal ->
-          pure (J.String literal)
-        _ ->
-          Left RequiredFieldMissing
-    go That {} =
-      Left UnexpectedFields
-    go (These field value) =
-      case field of
-        IR.Q.Literal {} ->
-          Left UnexpectedFields
-        IR.Q.Column {} ->
-          pure value
-        IR.Q.Relationship (IR.Q.RelationshipContents _ subquery@IR.Q.Query {cardinality}) ->
-          case value of
-            J.Array rows -> do
-              processed <- traverse (postProcessResponseRow capabilities subquery <=< parseObject) (toList rows)
-              applyCardinalityToResponse cardinality processed
-            other
-              | API.dcRelationships capabilities ->
-                Left ExpectedArray
-              | otherwise ->
-                pure other
-
-parseObject :: J.Value -> Either ResponseError J.Object
-parseObject = \case
-  J.Object obj -> pure obj
-  _ -> Left ExpectedObject
-
--- | If a fk-to-pk lookup comes from an object relationship then we
--- expect 0 or 1 items in the response and we should return it as an object.
--- if it's an array, we have to send back all of the results
-applyCardinalityToResponse :: IR.Q.Cardinality -> [J.Object] -> Either ResponseError J.Value
-applyCardinalityToResponse IR.Q.OneOrZero = \case
-  [] -> pure J.Null
-  [x] -> pure $ J.Object x
-  _ -> Left UnexpectedResponseCardinality
-applyCardinalityToResponse IR.Q.Many =
-  pure . J.Array . V.fromList . fmap J.Object
-
 -- | Validate if a 'IR.Q' contains any relationships.
 queryHasRelations :: IR.Q.Query -> Bool
 queryHasRelations IR.Q.Query {fields} = getAny $ flip foldMap fields \case

server/src-test/Hasura/Backends/DataConnector/API/V0/QuerySpec.hs

@@ -35,9 +35,10 @@ spec = do
       let fieldMapping = Map.fromList [(PrimaryKey $ ColumnName "id", ForeignKey $ ColumnName "my_foreign_id")]
           query = Query mempty (TableName "my_table_name") Nothing Nothing Nothing Nothing
       testToFromJSONToSchema
-        (RelationshipField $ RelField fieldMapping query)
+        (RelationshipField $ RelField fieldMapping ArrayRelationship query)
         [aesonQQ|
         { "type": "relationship",
+          "relation_type": "array",
           "column_mapping": {"id": "my_foreign_id"},
           "query": {"fields": {}, "from": "my_table_name"}
         }

server/tests-dc-api/Test/QuerySpec/RelationshipsSpec.hs

@@ -57,7 +57,7 @@ albumsWithArtistQuery modifySubquery =
         HashMap.fromList
           [ ("id", columnField "id"),
             ("title", columnField "title"),
-            ("artist", RelationshipField $ RelField joinFieldMapping artistsSubquery)
+            ("artist", RelationshipField $ RelField joinFieldMapping ObjectRelationship artistsSubquery)
           ]
    in albumsQuery {fields}
 
@@ -74,7 +74,7 @@ artistsWithAlbumsQuery modifySubquery =
         HashMap.fromList
           [ ("id", columnField "id"),
             ("name", columnField "name"),
-            ("albums", RelationshipField $ RelField joinFieldMapping albumsSubquery)
+            ("albums", RelationshipField $ RelField joinFieldMapping ArrayRelationship albumsSubquery)
           ]
    in artistsQuery {fields}
 

server/tests-hspec/Test/DC/QuerySpec.hs

@@ -141,6 +141,34 @@ data:
     - id: 5
 |]
 
+  describe "Array Relationships" $ do
+    it "joins on album id" $ \(testEnvironment, _) ->
+      shouldReturnYaml
+        opts
+        ( GraphqlEngine.postGraphql
+            testEnvironment
+            [graphql|
+query getArtist {
+  artists_by_pk(id: 1) {
+    id
+    name
+    albums {
+      title
+    }
+  }
+}
+|]
+        )
+        [yaml|
+data:
+  artists_by_pk:
+    - name: AC/DC
+      id: 1
+      albums:
+        - title: For Those About To Rck We Salute You
+        - title: Let There Be Rock
+|]
+
   describe "Object Relationships" $ do
     it "joins on artist id" $ \(testEnvironment, _) ->
       shouldReturnYaml
@@ -165,7 +193,7 @@ data:
     - id: 1
       title: "For Those About To Rck We Salute You"
       artist:
-        - name: "AC/DC"
+        name: "AC/DC"
 |]
 
   describe "Where Clause Tests" $ do