From 51fc10479369af37f741c255c27e950638928887 Mon Sep 17 00:00:00 2001
From: Auke Booij <aukebb@hasura.io>
Date: Tue, 13 Dec 2022 10:55:11 +0100
Subject: [PATCH] server: don't let query collection validation prevent engine
 startup

Generate more Metadata Inconsistencies instead of startup failures. Specifically this means that
- errors retrieving the main query of an executable GraphQL document, and
- errors during fragment inlining

no longer fail irrecoverably.

This also makes more parts of `buildSchemaCacheRule` into pure code, which is always nice.

PR-URL: https://github.com/hasura/graphql-engine-mono/pull/7234
GitOrigin-RevId: aebf636c2fb1aad1c2df9a37f7d0b67c1ee40c42
---
 server/src-lib/Hasura/RQL/DDL/Schema/Cache.hs |  2 +-
 .../Hasura/RQL/Types/SchemaCache/Build.hs     | 37 ++++++++-----------
 2 files changed, 16 insertions(+), 23 deletions(-)

diff --git a/server/src-lib/Hasura/RQL/DDL/Schema/Cache.hs b/server/src-lib/Hasura/RQL/DDL/Schema/Cache.hs
index 01328dd8635..142d516048d 100644
--- a/server/src-lib/Hasura/RQL/DDL/Schema/Cache.hs
+++ b/server/src-lib/Hasura/RQL/DDL/Schema/Cache.hs
@@ -367,7 +367,7 @@ buildSchemaCacheRule logger env = proc (metadataNoDefaults, invalidationKeys) ->
       -- OpenTelemerty doesn't generate any dependencies
       openTelemetryInconsistencies = either id absurd <$> toList openTelemetryCollectedInfo
 
-  inconsistentQueryCollections <- bindA -< do getInconsistentQueryCollections adminIntrospection _metaQueryCollections listedQueryObjects endpoints globalAllowLists
+      inconsistentQueryCollections = getInconsistentQueryCollections adminIntrospection _metaQueryCollections listedQueryObjects endpoints globalAllowLists
 
   returnA
     -<
diff --git a/server/src-lib/Hasura/RQL/Types/SchemaCache/Build.hs b/server/src-lib/Hasura/RQL/Types/SchemaCache/Build.hs
index 0d069640308..06953f5a8f1 100644
--- a/server/src-lib/Hasura/RQL/Types/SchemaCache/Build.hs
+++ b/server/src-lib/Hasura/RQL/Types/SchemaCache/Build.hs
@@ -29,7 +29,6 @@ module Hasura.RQL.Types.SchemaCache.Build
 where
 
 import Control.Arrow.Extended
-import Control.Lens
 import Control.Monad.Morph
 import Control.Monad.Trans.Control (MonadBaseControl)
 import Data.Aeson (Value, toJSON)
@@ -327,17 +326,17 @@ withNewInconsistentObjsCheck action = do
 -- static analysis over the saved queries and reports any inconsistenties
 -- with the current schema.
 getInconsistentQueryCollections ::
-  (MonadError QErr m) =>
   G.SchemaIntrospection ->
   QueryCollections ->
   ((CollectionName, ListedQuery) -> MetadataObject) ->
   EndpointTrie GQLQueryWithText ->
   [NormalizedQuery] ->
-  m [InconsistentMetadata]
-getInconsistentQueryCollections rs qcs lqToMetadataObj restEndpoints allowLst = do
-  inconsistentMetaObjs <- lefts <$> traverse (validateQuery rs (lqToMetadataObj) formatError) lqLst
-  pure $ map (\(o, t) -> InconsistentObject t Nothing o) inconsistentMetaObjs
+  [InconsistentMetadata]
+getInconsistentQueryCollections rs qcs lqToMetadataObj restEndpoints allowLst =
+  map (\(o, t) -> InconsistentObject t Nothing o) inconsistentMetaObjs
   where
+    inconsistentMetaObjs = lefts $ validateQuery <$> lqLst
+
     zipLQwithDef :: (CollectionName, CreateCollection) -> [((CollectionName, ListedQuery), [G.ExecutableDefinition G.Name])]
     zipLQwithDef (cName, cc) = map (\lq -> ((cName, lq), (G.getExecutableDefinitions . unGQLQuery . getGQLQuery . _lqQuery $ lq))) lqs
       where
@@ -370,21 +369,15 @@ getInconsistentQueryCollections rs qcs lqToMetadataObj restEndpoints allowLst =
 
         isInAllowList = if inAllowList allowLst lq then ". This query is in allowlist." else ""
 
-validateQuery ::
-  (MonadError QErr m) =>
-  G.SchemaIntrospection ->
-  (a -> MetadataObject) ->
-  (a -> [Text] -> Text) ->
-  (a, [G.ExecutableDefinition G.Name]) ->
-  m (Either (MetadataObject, Text) ())
-validateQuery rSchema getMetaObj formatError (eMeta, eDefs) = do
-  -- create the gql request object
-  let gqlRequest = GQLReq Nothing (GQLExecDoc eDefs) Nothing
+    validateQuery (eMeta, eDefs) = do
+      -- create the gql request object
+      let gqlRequest = GQLReq Nothing (GQLExecDoc eDefs) Nothing
 
-  -- @getSingleOperation@ will do the fragment inlining
-  singleOperation <- getSingleOperation gqlRequest
+      -- @getSingleOperation@ will do the fragment inlining
+      singleOperation <- case getSingleOperation gqlRequest of
+        Left err -> throwError (lqToMetadataObj eMeta, formatError eMeta [qeError err])
+        Right singleOp -> Right singleOp
 
-  -- perform the validation
-  pure $ case diagnoseGraphQLQuery rSchema singleOperation of
-    Nothing -> Right ()
-    Just errors -> Left (getMetaObj eMeta, formatError eMeta errors)
+      -- perform the validation
+      for_ (diagnoseGraphQLQuery rs singleOperation) \errors ->
+        throwError (lqToMetadataObj eMeta, formatError eMeta errors)