Move query validation into the schema cache building code

[NDAT-707]: https://hasurahq.atlassian.net/browse/NDAT-707?atlOrigin=eyJpIjoiNWRkNTljNzYxNjVmNDY3MDlhMDU5Y2ZhYzA5YTRkZjUiLCJwIjoiZ2l0aHViLWNvbS1KU1cifQ

PR-URL: https://github.com/hasura/graphql-engine-mono/pull/9510
Co-authored-by: Gil Mizrahi <8547573+soupi@users.noreply.github.com>
GitOrigin-RevId: 11474498c75bfe1eb1173fed1073cc0206d290a1

server/lib/arrows-extra/src/Control/Arrow/Interpret.hs

@@ -62,6 +62,7 @@
 -- monadically using this technique.
 module Control.Arrow.Interpret
   ( interpretWriter,
+    interpretWriterT,
   )
 where
 
@@ -83,3 +84,10 @@ interpretWriter = proc m -> do
   let (a, w) = runWriter m
   tellA -< w
   returnA -< a
+
+-- | 'interpretWriter' for some Kleisli arrow.
+interpretWriterT :: (ArrowKleisli m arr, ArrowWriter w arr) => WriterT w m a `arr` a
+interpretWriterT = proc m -> do
+  (a, w) <- bindA -< runWriterT m
+  tellA -< w
+  returnA -< a

server/src-lib/Hasura/Backends/Postgres/Instances/NativeQueries.hs

@@ -26,8 +26,8 @@ import Hasura.Backends.Postgres.Connection.Connect (withPostgresDB)
 import Hasura.Backends.Postgres.Instances.Types ()
 import Hasura.Backends.Postgres.SQL.Types (PGScalarType (..), pgScalarTypeToText)
 import Hasura.Base.Error
+import Hasura.LogicalModel.Cache (LogicalModelInfo (..))
 import Hasura.LogicalModel.Common (columnsFromFields)
-import Hasura.LogicalModel.Metadata (LogicalModelMetadata (..))
 import Hasura.NativeQuery.Metadata
   ( ArgumentName,
     InterpolatedItem (..),
@@ -46,14 +46,14 @@ validateNativeQuery ::
   InsOrdHashMap.InsOrdHashMap PGScalarType PQ.Oid ->
   Env.Environment ->
   PG.PostgresConnConfiguration ->
-  LogicalModelMetadata ('Postgres pgKind) ->
+  LogicalModelInfo ('Postgres pgKind) ->
   NativeQueryMetadata ('Postgres pgKind) ->
   m ()
 validateNativeQuery pgTypeOidMapping env connConf logicalModel model = do
   validateArgumentDeclaration model
   (prepname, preparedQuery) <- nativeQueryToPreparedStatement logicalModel model
   description <- runCheck prepname (PG.fromText preparedQuery)
-  let returnColumns = bimap toTxt nstType <$> InsOrdHashMap.toList (columnsFromFields $ _lmmFields logicalModel)
+  let returnColumns = bimap toTxt nstType <$> InsOrdHashMap.toList (columnsFromFields $ _lmiFields logicalModel)
 
   for_ (toList returnColumns) (matchTypes description)
   where
@@ -205,7 +205,7 @@ renderIQ (InterpolatedQuery items) = foldMap printItem items
 nativeQueryToPreparedStatement ::
   forall m pgKind.
   (MonadError QErr m) =>
-  LogicalModelMetadata ('Postgres pgKind) ->
+  LogicalModelInfo ('Postgres pgKind) ->
   NativeQueryMetadata ('Postgres pgKind) ->
   m (BS.ByteString, Text)
 nativeQueryToPreparedStatement logicalModel model = do
@@ -228,7 +228,7 @@ nativeQueryToPreparedStatement logicalModel model = do
 
       returnedColumnNames :: Text
       returnedColumnNames =
-        dquoteList $ InsOrdHashMap.keys (columnsFromFields $ _lmmFields logicalModel)
+        dquoteList $ InsOrdHashMap.keys (columnsFromFields $ _lmiFields logicalModel)
 
       wrapInCTE :: Text -> Text
       wrapInCTE query =

server/src-lib/Hasura/NativeQuery/API.hs

@@ -19,18 +19,16 @@ import Autodocodec (HasCodec)
 import Autodocodec qualified as AC
 import Control.Lens (Traversal', has, preview, (^?))
 import Data.Aeson
-import Data.Environment qualified as Env
 import Data.HashMap.Strict.InsOrd.Extended qualified as InsOrdHashMap
 import Data.Text.Extended (toTxt, (<<>))
 import Hasura.Base.Error
 import Hasura.EncJSON
-import Hasura.LogicalModel.API (getCustomTypes)
 import Hasura.LogicalModel.Metadata (LogicalModelName)
 import Hasura.LogicalModelResolver.Codec (nativeQueryRelationshipsCodec)
 import Hasura.NativeQuery.Metadata (ArgumentName, NativeQueryMetadata (..), parseInterpolatedQuery)
 import Hasura.NativeQuery.Types (NativeQueryName, NullableScalarType)
 import Hasura.Prelude
-import Hasura.RQL.Types.Backend (Backend, SourceConnConfiguration)
+import Hasura.RQL.Types.Backend (Backend)
 import Hasura.RQL.Types.BackendTag
 import Hasura.RQL.Types.BackendType
 import Hasura.RQL.Types.Common
@@ -105,38 +103,23 @@ deriving via
 -- | Validate a native query and extract the native query info from the request.
 nativeQueryTrackToMetadata ::
   forall b m.
-  ( BackendMetadata b,
-    MonadError QErr m,
-    MonadIO m,
-    MetadataM m
+  ( MonadError QErr m
   ) =>
-  Env.Environment ->
-  SourceConnConfiguration b ->
   TrackNativeQuery b ->
   m (NativeQueryMetadata b)
-nativeQueryTrackToMetadata env sourceConnConfig TrackNativeQuery {..} = do
+nativeQueryTrackToMetadata TrackNativeQuery {..} = do
   code <- parseInterpolatedQuery tnqCode `onLeft` \e -> throw400 ParseFailed e
 
-  let nativeQueryMetadata =
-        NativeQueryMetadata
-          { _nqmRootFieldName = tnqRootFieldName,
-            _nqmCode = code,
-            _nqmReturns = tnqReturns,
-            _nqmArguments = tnqArguments,
-            _nqmArrayRelationships = tnqArrayRelationships,
-            _nqmObjectRelationships = tnqObjectRelationships,
-            _nqmDescription = tnqDescription
-          }
-
-  metadata <- getMetadata
-
-  -- lookup logical model in existing metadata
-  case metadata ^? getCustomTypes tnqSource . ix tnqReturns of
-    Just logicalModel ->
-      validateNativeQuery @b env sourceConnConfig logicalModel nativeQueryMetadata
-    Nothing -> throw400 NotFound ("Logical model " <> tnqReturns <<> " not found.")
-
-  pure nativeQueryMetadata
+  pure
+    NativeQueryMetadata
+      { _nqmRootFieldName = tnqRootFieldName,
+        _nqmCode = code,
+        _nqmReturns = tnqReturns,
+        _nqmArguments = tnqArguments,
+        _nqmArrayRelationships = tnqArrayRelationships,
+        _nqmObjectRelationships = tnqObjectRelationships,
+        _nqmDescription = tnqDescription
+      }
 
 -- | API payload for the 'get_native_query' endpoint.
 data GetNativeQuery (b :: BackendType) = GetNativeQuery
@@ -196,16 +179,14 @@ runTrackNativeQuery ::
   forall b m.
   ( BackendMetadata b,
     MonadError QErr m,
-    MonadIO m,
     CacheRWM m,
     MetadataM m,
     HasFeatureFlagChecker m
   ) =>
-  Env.Environment ->
   TrackNativeQuery b ->
   m EncJSON
-runTrackNativeQuery env trackNativeQueryRequest = do
-  (obj, modifier) <- execTrackNativeQuery env trackNativeQueryRequest
+runTrackNativeQuery trackNativeQueryRequest = do
+  (obj, modifier) <- execTrackNativeQuery trackNativeQueryRequest
   buildSchemaCacheFor obj modifier
   pure successMsg
 
@@ -216,14 +197,12 @@ execTrackNativeQuery ::
   forall b m.
   ( BackendMetadata b,
     MonadError QErr m,
-    MonadIO m,
     MetadataM m,
     HasFeatureFlagChecker m
   ) =>
-  Env.Environment ->
   TrackNativeQuery b ->
   m (MetadataObjId, MetadataModifier)
-execTrackNativeQuery env trackNativeQueryRequest = do
+execTrackNativeQuery trackNativeQueryRequest = do
   throwIfFeatureDisabled
 
   sourceMetadata <-
@@ -238,10 +217,9 @@ execTrackNativeQuery env trackNativeQueryRequest = do
       pure
       . preview (metaSources . ix source . toSourceMetadata @b)
       =<< getMetadata
-  let sourceConnConfig = _smConfiguration sourceMetadata
 
   (metadata :: NativeQueryMetadata b) <- do
-    nativeQueryTrackToMetadata @b env sourceConnConfig trackNativeQueryRequest
+    nativeQueryTrackToMetadata @b trackNativeQueryRequest
 
   let fieldName = _nqmRootFieldName metadata
       metadataObj =

server/src-lib/Hasura/RQL/DDL/Schema/Cache.hs

@@ -770,6 +770,7 @@ buildSchemaCacheRule logger env mSchemaRegistryContext = proc (MetadataWithResou
         ArrowWriter (Seq CollectItem) arr,
         MonadError QErr m,
         HasCacheStaticConfig m,
+        MonadIO m,
         BackendMetadata b,
         GetAggregationPredicatesDeps b
       ) =>
@@ -906,7 +907,7 @@ buildSchemaCacheRule logger env mSchemaRegistryContext = proc (MetadataWithResou
           logicalModelsCache = mapFromL _lmiName (catMaybes logicalModelCacheMaybes)
 
       nativeQueryCacheMaybes <-
-        interpretWriter
+        interpretWriterT
           -< for
             (InsOrdHashMap.elems nativeQueries)
             \nqm@NativeQueryMetadata {..} -> do
@@ -944,6 +945,8 @@ buildSchemaCacheRule logger env mSchemaRegistryContext = proc (MetadataWithResou
                     (HashMap.lookup _nqmReturns logicalModelsCache)
                     (throw400 InvalidConfiguration ("The logical model " <> toTxt _nqmReturns <> " could not be found"))
 
+                validateNativeQuery @b env (_smConfiguration sourceMetadata) logicalModel NativeQueryMetadata {..}
+
                 recordDependenciesM metadataObject schemaObjId
                   $ Seq.singleton dependency
 

server/src-lib/Hasura/RQL/Types/Metadata/Backend.hs

@@ -12,6 +12,7 @@ import Hasura.Base.Error
 import Hasura.Function.Cache
 import Hasura.Incremental qualified as Inc
 import Hasura.Logging (Hasura, Logger)
+import Hasura.LogicalModel.Cache (LogicalModelInfo)
 import Hasura.LogicalModel.Metadata (LogicalModelMetadata)
 import Hasura.NativeQuery.Metadata (NativeQueryMetadata)
 import Hasura.Prelude
@@ -237,7 +238,7 @@ class
     (MonadIO m, MonadError QErr m) =>
     Env.Environment ->
     SourceConnConfiguration b ->
-    LogicalModelMetadata b ->
+    LogicalModelInfo b ->
     NativeQueryMetadata b ->
     m ()
   validateNativeQuery _ _ _ _ =

server/src-lib/Hasura/Server/API/Metadata.hs

@@ -430,7 +430,7 @@ runMetadataQueryV1M env checkFeatureFlag remoteSchemaPerms currentResourceVersio
   RMDropComputedField q -> dispatchMetadata runDropComputedField q
   RMTestConnectionTemplate q -> dispatchMetadata runTestConnectionTemplate q
   RMGetNativeQuery q -> dispatchMetadata NativeQueries.runGetNativeQuery q
-  RMTrackNativeQuery q -> dispatchMetadata (NativeQueries.runTrackNativeQuery env) q
+  RMTrackNativeQuery q -> dispatchMetadata NativeQueries.runTrackNativeQuery q
   RMUntrackNativeQuery q -> dispatchMetadata NativeQueries.runUntrackNativeQuery q
   RMGetStoredProcedure q -> dispatchMetadata StoredProcedures.runGetStoredProcedure q
   RMTrackStoredProcedure q -> dispatchMetadata (StoredProcedures.runTrackStoredProcedure env) q
@@ -546,7 +546,7 @@ runMetadataQueryV1M env checkFeatureFlag remoteSchemaPerms currentResourceVersio
           `catchError` \qerr -> pure (encJFromJValue qerr)
 
     pure (encJFromList results)
-  RMBulkAtomic commands -> runBulkAtomic env commands
+  RMBulkAtomic commands -> runBulkAtomic commands
   where
     dispatchEventTrigger :: (forall b. (BackendEventTrigger b) => i b -> a) -> AnyBackend i -> a
     dispatchEventTrigger f x = dispatchAnyBackend @BackendEventTrigger x f
@@ -569,15 +569,13 @@ dispatchMetadata f x = dispatchAnyBackend @BackendMetadata x f
 -- re-add commands to do edits, or add two interdependent items at once.
 runBulkAtomic ::
   ( HasFeatureFlagChecker m,
-    MonadIO m,
     MonadError QErr m,
     CacheRWM m,
     MetadataM m
   ) =>
-  Env.Environment ->
   [RQLMetadataRequest] ->
   m EncJSON
-runBulkAtomic env cmds = do
+runBulkAtomic cmds = do
   -- get the metadata modifiers for all our commands
   results <- traverse getMetadataModifierForCommand cmds
   -- build the schema cache using the combined modifiers
@@ -587,7 +585,7 @@ runBulkAtomic env cmds = do
   where
     getMetadataModifierForCommand = \case
       RMV1 v -> case v of
-        RMTrackNativeQuery q -> dispatchMetadata (NativeQueries.execTrackNativeQuery env) q
+        RMTrackNativeQuery q -> dispatchMetadata NativeQueries.execTrackNativeQuery q
         RMUntrackNativeQuery q -> dispatchMetadata NativeQueries.execUntrackNativeQuery q
         RMTrackLogicalModel q -> dispatchMetadata LogicalModel.execTrackLogicalModel q
         RMUntrackLogicalModel q -> dispatchMetadata LogicalModel.execUntrackLogicalModel q

server/src-test/Hasura/Backends/Postgres/NativeQueries/NativeQueriesSpec.hs

@@ -12,6 +12,7 @@ import Data.HashMap.Strict qualified as HashMap
 import Hasura.Backends.Postgres.Instances.NativeQueries
 import Hasura.Backends.Postgres.SQL.Types
 import Hasura.Base.Error
+import Hasura.LogicalModel.Cache (LogicalModelInfo (..))
 import Hasura.LogicalModel.Metadata
 import Hasura.NativeQuery.Metadata
 import Hasura.Prelude hiding (first)
@@ -66,12 +67,12 @@ spec = do
       parseInterpolatedQuery rawSQL `shouldBe` Left "Found '{{' without a matching closing '}}'"
 
   describe "Validation" do
-    let lmm =
-          LogicalModelMetadata
-            { _lmmName = LogicalModelName (G.unsafeMkName "logical_model_name"),
-              _lmmFields = mempty,
-              _lmmDescription = Nothing,
-              _lmmSelectPermissions = mempty
+    let lmi =
+          LogicalModelInfo
+            { _lmiName = LogicalModelName (G.unsafeMkName "logical_model_name"),
+              _lmiFields = mempty,
+              _lmiDescription = Nothing,
+              _lmiPermissions = mempty
             }
 
         nqm =
@@ -87,7 +88,7 @@ spec = do
 
     it "Rejects undeclared variables" do
       let Right code = parseInterpolatedQuery "SELECT {{hey}}"
-      let actual :: Either QErr Text = fmap snd $ runExcept $ nativeQueryToPreparedStatement lmm nqm {_nqmCode = code}
+      let actual :: Either QErr Text = fmap snd $ runExcept $ nativeQueryToPreparedStatement lmi nqm {_nqmCode = code}
 
       (first showQErr actual) `shouldSatisfy` isLeft
       let Left err = actual
@@ -99,7 +100,7 @@ spec = do
             fmap snd
               $ runExcept
               $ nativeQueryToPreparedStatement
-                lmm
+                lmi
                 nqm
                   { _nqmCode = code,
                     _nqmArguments =
@@ -119,7 +120,7 @@ spec = do
             fmap snd
               $ runExcept
               $ nativeQueryToPreparedStatement
-                lmm
+                lmi
                 nqm
                   { _nqmCode = code,
                     _nqmArguments =