server: throw broken invariant on data loader error

PR-URL: https://github.com/hasura/graphql-engine-mono/pull/3010
GitOrigin-RevId: 3b09a7d61343d406d1ecc5d6aaab866564c9dff8

server/graphql-engine.cabal

@@ -810,6 +810,7 @@ test-suite graphql-engine-tests
     Data.Text.RawString
     Data.TimeSpec
     Database.MSSQL.TransactionSpec
+    Hasura.Backends.MySQL.DataLoader.ExecuteTests
     Hasura.EventingSpec
     Hasura.Generator
     Hasura.Generator.Common

server/src-lib/Hasura/Backends/MySQL/DataLoader/Execute.hs

@@ -6,8 +6,12 @@
 module Hasura.Backends.MySQL.DataLoader.Execute
   ( OutputValue (..),
     RecordSet (..),
+    ExecuteProblem (..),
     execute,
     runExecute,
+    -- for testing
+    joinObjectRows,
+    leftObjectJoin,
   )
 where
 
@@ -23,10 +27,22 @@ import Data.Vector (Vector)
 import Data.Vector qualified as V
 import GHC.TypeLits qualified
 import Hasura.Backends.MySQL.Connection (runQueryYieldingRows)
-import Hasura.Backends.MySQL.DataLoader.Plan hiding
-  ( Join (wantedFields),
-    Relationship (leftRecordSet),
-    Select,
+import Hasura.Backends.MySQL.DataLoader.Plan
+  ( Action (..),
+    FieldName (..),
+    HeadAndTail (..),
+    Join
+      ( joinFieldName,
+        joinRhsOffset,
+        joinRhsTop,
+        joinType,
+        leftRecordSet,
+        rightRecordSet
+      ),
+    PlannedAction (..),
+    Ref,
+    selectQuery,
+    toFieldName,
   )
 import Hasura.Backends.MySQL.DataLoader.Plan qualified as DataLoaderPlan
 import Hasura.Backends.MySQL.DataLoader.Plan qualified as Plan
@@ -79,6 +95,7 @@ data ExecuteProblem
   | JoinProblem ExecuteProblem
   | UnsupportedJoinBug JoinType
   | MissingRecordSetBug Ref
+  | BrokenJoinInvariant [DataLoaderPlan.FieldName]
   deriving (Show)
 
 -- | Execute monad; as queries are performed, the record sets are
@@ -157,25 +174,23 @@ fetchRecordSetForAction =
       right <- getRecordSet rightRecordSet
       case joinType' of
         ArrayJoin fields ->
-          case leftArrayJoin
+          leftArrayJoin
             wantedFields
             fieldName
             (toFieldNames fields)
             joinRhsTop
             joinRhsOffset
             left
-            right of
-            Left problem -> throwError (JoinProblem problem)
-            Right recordSet -> pure recordSet
+            right
+            `onLeft` (throwError . JoinProblem)
         ObjectJoin fields ->
-          case leftObjectJoin
+          leftObjectJoin
             wantedFields
             fieldName
             (toFieldNames fields)
             left
-            right of
-            Left problem -> throwError (JoinProblem problem)
-            Right recordSet -> pure recordSet
+            right
+            `onLeft` (throwError . JoinProblem)
         _ -> throwError (UnsupportedJoinBug joinType')
   where
     toFieldNames = fmap (bimap toFieldName toFieldName)
@@ -199,9 +214,7 @@ getRecordSet :: Ref -> Execute RecordSet
 getRecordSet ref = do
   recordSetsRef <- asks recordSets
   hash <- liftIO (readIORef recordSetsRef)
-  case OMap.lookup ref hash of
-    Nothing -> throwError (MissingRecordSetBug ref)
-    Just re -> pure re
+  OMap.lookup ref hash `onNothing` throwError (MissingRecordSetBug ref)
 
 -- | See documentation for 'HeadAndTail'.
 getFinalRecordSet :: HeadAndTail -> Execute RecordSet
@@ -215,12 +228,10 @@ getFinalRecordSet HeadAndTail {..} = do
     tailSet
       { rows =
           fmap
-            ( \row ->
-                OMap.filterWithKey
-                  ( \(FieldName k) _ ->
-                      maybe True (elem k) (wantedFields headSet)
-                  )
-                  row
+            ( OMap.filterWithKey
+                ( \(FieldName k) _ ->
+                    maybe True (elem k) (wantedFields headSet)
+                )
             )
             (rows tailSet)
       }
@@ -258,36 +269,36 @@ leftObjectJoin ::
   RecordSet ->
   RecordSet ->
   Either ExecuteProblem RecordSet
-leftObjectJoin wantedFields joinAlias joinFields left right =
+leftObjectJoin wantedFields joinAlias joinFields left right = do
+  rows' <- fmap V.fromList . traverse makeRows . toList $ rows left
   pure
     RecordSet
       { origin = Nothing,
         wantedFields = Nothing,
-        rows =
-          V.fromList
-            [ joinObjectRows wantedFields joinAlias leftRow rightRows
-              | leftRow <- toList (rows left),
-                let rightRows =
-                      V.fromList
-                        [ rightRow
-                          | rightRow <- toList (rows right),
-                            not (null joinFields),
-                            all
-                              ( \(rightField, leftField) ->
-                                  fromMaybe
-                                    False
-                                    ( do
-                                        leftValue <-
-                                          OMap.lookup leftField leftRow
-                                        rightValue <-
-                                          OMap.lookup rightField rightRow
-                                        pure (leftValue == rightValue)
-                                    )
-                              )
-                              joinFields
-                        ]
-            ]
+        rows = rows'
       }
+  where
+    makeRows :: InsOrdHashMap FieldName OutputValue -> Either ExecuteProblem (InsOrdHashMap FieldName OutputValue)
+    makeRows leftRow =
+      let rightRows =
+            V.fromList
+              [ rightRow
+                | not (null joinFields),
+                  rightRow <- toList (rows right),
+                  all
+                    ( \(rightField, leftField) ->
+                        Just True
+                          == ( do
+                                 leftValue <- OMap.lookup leftField leftRow
+                                 rightValue <- OMap.lookup rightField rightRow
+                                 pure (leftValue == rightValue)
+                             )
+                    )
+                    joinFields
+              ]
+       in -- The line below will return Left is rightRows has more than one element.
+          -- Consider moving the check here if it makes sense in the future.
+          joinObjectRows wantedFields joinAlias leftRow rightRows
 
 -- | A naive, exponential reference implementation of a left join. It
 -- serves as a trivial sample implementation for correctness checking
@@ -315,19 +326,16 @@ leftArrayJoin wantedFields joinAlias joinFields rhsTop rhsOffset left right =
                         ( limit
                             ( offset
                                 [ rightRow
-                                  | rightRow <- toList (rows right),
-                                    not (null joinFields),
+                                  | not (null joinFields),
+                                    rightRow <- toList (rows right),
                                     all
                                       ( \(rightField, leftField) ->
-                                          fromMaybe
-                                            False
-                                            ( do
-                                                leftValue <-
-                                                  OMap.lookup leftField leftRow
-                                                rightValue <-
-                                                  OMap.lookup rightField rightRow
-                                                pure (leftValue == rightValue)
-                                            )
+                                          Just True
+                                            == ( do
+                                                   leftValue <- OMap.lookup leftField leftRow
+                                                   rightValue <- OMap.lookup rightField rightRow
+                                                   pure (leftValue == rightValue)
+                                               )
                                       )
                                       joinFields
                                 ]
@@ -367,26 +375,24 @@ joinArrayRows wantedFields fieldName leftRow rightRow =
 
 -- | Join a row with another as an object join.
 --
--- We expect rightRow to consist of a single row, but don't complain
--- if this is violated. TODO: Change?
+-- If rightRow is not a single row, we throw 'BrokenJoinInvariant'.
 joinObjectRows ::
   Maybe [Text] ->
   Text ->
   InsOrdHashMap DataLoaderPlan.FieldName OutputValue ->
   Vector (InsOrdHashMap DataLoaderPlan.FieldName OutputValue) ->
-  InsOrdHashMap DataLoaderPlan.FieldName OutputValue
-joinObjectRows wantedFields fieldName leftRow rightRows =
-  foldl'
-    ( \left row ->
-        OMap.insert
-          (DataLoaderPlan.FieldName fieldName)
-          ( RecordOutputValue
-              ( OMap.filterWithKey
-                  (\(DataLoaderPlan.FieldName k) _ -> maybe True (elem k) wantedFields)
-                  row
-              )
-          )
-          left
-    )
-    leftRow
-    rightRows
+  Either ExecuteProblem (InsOrdHashMap DataLoaderPlan.FieldName OutputValue)
+joinObjectRows wantedFields fieldName leftRow rightRows
+  | V.length rightRows /= 1 = Left . BrokenJoinInvariant . foldMap OMap.keys $ rightRows
+  | otherwise =
+    let row = V.head rightRows
+     in pure $
+          OMap.insert
+            (DataLoaderPlan.FieldName fieldName)
+            ( RecordOutputValue
+                ( OMap.filterWithKey
+                    (\(DataLoaderPlan.FieldName k) _ -> maybe True (elem k) wantedFields)
+                    row
+                )
+            )
+            leftRow

server/src-test/Hasura/Backends/MySQL/DataLoader/ExecuteTests.hs

@@ -0,0 +1,79 @@
+module Hasura.Backends.MySQL.DataLoader.ExecuteTests
+  ( spec,
+  )
+where
+
+import Data.HashMap.Strict.InsOrd qualified as HMS
+import Data.Vector qualified as V
+import Hasura.Backends.MySQL.DataLoader.Execute
+import Hasura.Prelude
+import Hedgehog
+import Hedgehog.Gen
+import Hedgehog.Range
+import Test.Hspec
+import Test.Hspec.Hedgehog
+
+spec :: Spec
+spec = do
+  describe "joinObjectRows" $ do
+    joinObjectRowsThrowsIfRightRowsIsEmpty
+    joinObjectRowsThrowsIfRightRowsIsLargerThanOne
+  describe "leftObjectJoin" $ do
+    leftObjectJoinThrowsIfRightRowsIsEmpty
+    leftObjectJoinThrowsIfRightRowsIsLargerThanOne
+
+joinObjectRowsThrowsIfRightRowsIsEmpty :: Spec
+joinObjectRowsThrowsIfRightRowsIsEmpty =
+  it "throws if rightRows is empty" $
+    joinObjectRows
+      Nothing
+      ""
+      HMS.empty
+      empty
+      `shouldSatisfy` invariant
+
+joinObjectRowsThrowsIfRightRowsIsLargerThanOne :: Spec
+joinObjectRowsThrowsIfRightRowsIsLargerThanOne = do
+  it "throws if rightRows is two or more"
+    . hedgehog
+    $ do
+      size <- forAll $ integral (linear 2 100)
+      let result =
+            joinObjectRows
+              Nothing
+              ""
+              HMS.empty
+              (V.replicate size HMS.empty)
+      assert $ invariant result
+
+leftObjectJoinThrowsIfRightRowsIsEmpty :: Spec
+leftObjectJoinThrowsIfRightRowsIsEmpty =
+  it "throws if rightRows is empty" $
+    leftObjectJoin
+      Nothing
+      ""
+      []
+      (RecordSet Nothing (V.singleton HMS.empty) Nothing)
+      (RecordSet Nothing mempty Nothing)
+      `shouldSatisfy` invariant
+
+leftObjectJoinThrowsIfRightRowsIsLargerThanOne :: Spec
+leftObjectJoinThrowsIfRightRowsIsLargerThanOne =
+  it "throws if rightRows is two or more"
+    . hedgehog
+    $ do
+      size <- forAll $ integral (linear 2 100)
+      let result =
+            leftObjectJoin
+              Nothing
+              ""
+              []
+              (RecordSet Nothing (V.singleton HMS.empty) Nothing)
+              (RecordSet Nothing (V.replicate size HMS.empty) Nothing)
+      assert $ invariant result
+
+invariant :: Either ExecuteProblem a -> Bool
+invariant =
+  \case
+    Left (BrokenJoinInvariant _) -> True
+    _ -> False

server/src-test/Main.hs

@@ -20,6 +20,7 @@ import Hasura.App
   ( PGMetadataStorageAppT (..),
     mkPgSourceResolver,
   )
+import Hasura.Backends.MySQL.DataLoader.ExecuteTests qualified as MySQLDataLoader
 import Hasura.EventingSpec qualified as EventingSpec
 import Hasura.GraphQL.NamespaceSpec qualified as NamespaceSpec
 import Hasura.GraphQL.Parser.DirectivesTest qualified as GraphQLDirectivesSpec
@@ -82,6 +83,7 @@ unitSpecs = do
   describe "Data.Parser.CacheControl" CacheControlParser.spec
   describe "Data.Parser.JSONPath" JsonPath.spec
   describe "Data.Time" TimeSpec.spec
+  describe "Hasura.Backends.MySQL.DataLoader.ExecuteTests" MySQLDataLoader.spec
   describe "Hasura.Eventing" EventingSpec.spec
   describe "Hasura.GraphQL.Parser.Directives" GraphQLDirectivesSpec.spec
   describe "Hasura.GraphQL.Schema.Remote" GraphRemoteSchemaSpec.spec