[pro, server] Allow response when cache limits are hit

https://github.com/hasura/graphql-engine-mono/pull/2094

GitOrigin-RevId: f8b186a7cf830f61226e7ea82631a4a9e5f269bc

server/src-lib/Hasura/App.hs

@@ -67,7 +67,8 @@ import           Hasura.GraphQL.Execute                     (ExecutionStep (..),
 import           Hasura.GraphQL.Execute.Action
 import           Hasura.GraphQL.Execute.Action.Subscription
 import           Hasura.GraphQL.Logging                     (MonadQueryLog (..))
-import           Hasura.GraphQL.Transport.HTTP              (MonadExecuteQuery (..))
+import           Hasura.GraphQL.Transport.HTTP              (CacheStoreSuccess (CacheStoreSkipped),
+                                                             MonadExecuteQuery (..))
 import           Hasura.GraphQL.Transport.HTTP.Protocol     (toParsed)
 import           Hasura.Logging
 import           Hasura.Metadata.Class
@@ -872,7 +873,7 @@ instance (MonadIO m) => HttpLog (PGMetadataStorageAppT m) where
 
 instance (Monad m) => MonadExecuteQuery (PGMetadataStorageAppT m) where
   cacheLookup _ _ _ _ = pure ([], Nothing)
-  cacheStore  _ _ _ = pure ()
+  cacheStore  _ _ _   = pure (Right CacheStoreSkipped)
 
 instance (MonadIO m, MonadBaseControl IO m) => UserAuthentication (Tracing.TraceT (PGMetadataStorageAppT m)) where
   resolveUserInfo logger manager headers authMode reqs =

server/src-lib/Hasura/GraphQL/Transport/HTTP.hs

@@ -17,7 +17,8 @@ module Hasura.GraphQL.Transport.HTTP
   , OperationName(..)
   , GQLQueryText(..)
   , ResultsFragment(..)
-
+  , CacheStoreSuccess(..)
+  , CacheStoreFailure(..)
   , SessVarPred
   , filterVariablesFromQuery
   , runSessVarPred
@@ -36,7 +37,7 @@ import qualified Language.GraphQL.Draft.Syntax                as G
 import qualified Network.HTTP.Types                           as HTTP
 import qualified Network.Wai.Extended                         as Wai
 
-import           Control.Lens                                 (Traversal', toListOf)
+import           Control.Lens                                 (Traversal', _4, toListOf)
 import           Control.Monad.Morph                          (hoist)
 import           Control.Monad.Trans.Control                  (MonadBaseControl)
 
@@ -83,6 +84,19 @@ instance J.ToJSON QueryCacheKey where
   toJSON (QueryCacheKey qs ur sess) =
     J.object ["query_string" J..= qs, "user_role" J..= ur, "session" J..= sess]
 
+type CacheStoreResponse = Either CacheStoreFailure CacheStoreSuccess
+
+data CacheStoreSuccess
+  = CacheStoreSkipped
+  | CacheStoreHit
+  deriving (Eq, Show)
+
+data CacheStoreFailure
+  = CacheStoreLimitReached
+  | CacheStoreNotEnoughCapacity
+  | CacheStoreBackendError String
+  deriving (Eq, Show)
+
 class Monad m => MonadExecuteQuery m where
   -- | This method does two things: it looks up a query result in the
   -- server-side cache, if a cache is used, and it additionally returns HTTP
@@ -119,7 +133,7 @@ class Monad m => MonadExecuteQuery m where
     -- ^ Cached Directive from GraphQL query AST
     -> EncJSON
     -- ^ Result of a query execution
-    -> TraceT (ExceptT QErr m) ()
+    -> TraceT (ExceptT QErr m) CacheStoreResponse
     -- ^ Always succeeds
 
   default cacheLookup :: (m ~ t n, MonadTrans t, MonadExecuteQuery n) =>
@@ -127,7 +141,7 @@ class Monad m => MonadExecuteQuery m where
   cacheLookup a b c d = hoist (hoist lift) $ cacheLookup a b c d
 
   default cacheStore :: (m ~ t n, MonadTrans t, MonadExecuteQuery n) =>
-    QueryCacheKey -> Maybe CachedDirective -> EncJSON -> TraceT (ExceptT QErr m) ()
+    QueryCacheKey -> Maybe CachedDirective -> EncJSON -> TraceT (ExceptT QErr m) CacheStoreResponse
   cacheStore a b c = hoist (hoist lift) $ cacheStore  a b c
 
 
@@ -288,8 +302,18 @@ runGQ env logger reqId userInfo ipAddress reqHeaders queryType reqUnparsed = do
                 buildRaw json
             out@(_, _, _, HttpResponse responseData _, _) <-
               buildResultFromFragments Telem.Query conclusion responseHeaders parameterizedQueryHash
-            Tracing.interpTraceT (liftEitherM . runExceptT) $ cacheStore cacheKey cachedDirective $ snd responseData
-            pure out
+            Tracing.interpTraceT (liftEitherM . runExceptT) do
+              cacheStoreRes <- cacheStore cacheKey cachedDirective (snd responseData)
+              let
+                headers = case cacheStoreRes of
+                  -- Note: Warning header format: "Warning: <warn-code> <warn-agent> <warn-text> [warn-date]"
+                  -- See: https://developer.mozilla.org/en-US/docs/Web/HTTP/Headers/Warning
+                  Right _                            -> []
+                  (Left CacheStoreLimitReached)      -> [("warning", "199 - cache-store-size-limit-exceeded")]
+                  (Left CacheStoreNotEnoughCapacity) -> [("warning", "199 - cache-store-capacity-exceeded")]
+                  (Left (CacheStoreBackendError _))  -> [("warning", "199 - cache-store-error")]
+                in
+                pure $ out & _4 %~ addHttpResponseHeaders headers
 
       E.MutationExecutionPlan mutationPlans -> do
         {- Note [Backwards-compatible transaction optimisation]

server/src-lib/Hasura/GraphQL/Transport/WebSocket.hs

@@ -436,8 +436,11 @@ onStart env enabledLogTypes serverEnv wsConn (StartMsg opId q) onMessageActions
               buildRaw json
           buildResultFromFragments Telem.Query timerTot requestId conclusion
           case conclusion of
-            Left _        -> pure ()
-            Right results -> Tracing.interpTraceT (withExceptT mempty) $
+            Left _ -> pure ()
+            Right results -> do
+              -- Note: The result of cacheStore is ignored here since we can't ensure that
+              --       the WS client will respond correctly to multiple messages.
+              void $ Tracing.interpTraceT (withExceptT mempty) $
                              cacheStore cacheKey cachedDirective $ encJFromInsOrdHashMap $
                              rfResponse <$> OMap.mapKeys G.unName results
       liftIO $ sendCompleted (Just requestId)

server/src-lib/Hasura/HTTP.hs

@@ -4,6 +4,7 @@ module Hasura.HTTP
   , hdrsToText
   , addDefaultHeaders
   , HttpResponse(..)
+  , addHttpResponseHeaders
   ) where
 
 import           Hasura.Prelude
@@ -70,3 +71,6 @@ data HttpResponse a
   { _hrBody    :: !a
   , _hrHeaders :: !HTTP.ResponseHeaders
   } deriving (Functor, Foldable, Traversable)
+
+addHttpResponseHeaders :: HTTP.ResponseHeaders -> HttpResponse a -> HttpResponse a
+addHttpResponseHeaders newHeaders (HttpResponse b h) = HttpResponse b (newHeaders <> h)