server: fix scheduled events not showing up on console when the payload construction is failed

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

server/lib/api-tests/api-tests.cabal

@@ -204,6 +204,7 @@ library
     Test.Regression.StreamConflictSpec
     Test.Regression.UsingTheSameFunctionForRootFieldAndComputedField8643Spec
     Test.Regression.SqlServerIdentifierQuotingSpec
+    Test.ScheduledEvents.ScheduledEventsInvalidEnvVarSpec
     Test.Schema.ComputedFields.ScalarSpec
     Test.Schema.ComputedFields.TableSpec
     Test.Schema.ConflictsSpec

server/lib/api-tests/src/Test/ScheduledEvents/ScheduledEventsInvalidEnvVarSpec.hs

@@ -0,0 +1,131 @@
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE ViewPatterns #-}
+
+-- | Test that scheduled triggers with invalid/missing env vars adds (errored) invocation logs
+module Test.ScheduledEvents.ScheduledEventsInvalidEnvVarSpec (spec) where
+
+import Control.Concurrent.Extended (sleep)
+import Data.Aeson
+import Data.Aeson.KeyMap qualified as KM
+import Data.List.NonEmpty qualified as NE
+import Harness.Backend.Postgres qualified as Postgres
+import Harness.GraphqlEngine qualified as GraphqlEngine
+import Harness.Quoter.Yaml
+import Harness.Test.Fixture qualified as Fixture
+import Harness.Test.Schema (Table (..), table)
+import Harness.Test.Schema qualified as Schema
+import Harness.Test.SetupAction (SetupAction (..), permitTeardownFail)
+import Harness.TestEnvironment (GlobalTestEnvironment, TestEnvironment)
+import Harness.Webhook qualified as Webhook
+import Harness.Yaml (fromObject)
+import Hasura.Prelude
+import Test.Hspec (SpecWith, describe, it, shouldBe)
+
+--------------------------------------------------------------------------------
+-- Preamble
+
+spec :: SpecWith GlobalTestEnvironment
+spec =
+  Fixture.runWithLocalTestEnvironment
+    ( NE.fromList
+        [ (Fixture.fixture $ Fixture.Backend Postgres.backendTypeMetadata)
+            { -- setup the webhook server as the local test environment,
+              -- so that the server can be referenced while testing
+              Fixture.mkLocalTestEnvironment = const Webhook.run,
+              Fixture.setupTeardown = \(testEnvironment, (webhookServer, _)) ->
+                [ permitTeardownFail (setupTableAction' testEnvironment),
+                  Fixture.SetupAction
+                    { Fixture.setupAction = postgresSetup testEnvironment webhookServer,
+                      Fixture.teardownAction = \_ -> pure ()
+                    }
+                ]
+            }
+        ]
+    )
+    tests
+  where
+    setupTableAction' testEnvironment =
+      -- setup a source named "default" and create and then track the "authors"
+      -- table in it.
+      SetupAction
+        ( do
+            GraphqlEngine.setSource testEnvironment (Postgres.defaultNamedSourceMetadata testEnvironment) Nothing
+            Postgres.createTable testEnvironment (authorsTable "authors")
+            Schema.trackTable "default" (authorsTable "authors") testEnvironment
+        )
+        (const $ GraphqlEngine.setSources testEnvironment mempty Nothing)
+
+--------------------------------------------------------------------------------
+
+-- * Backend
+
+authorsTable :: Text -> Schema.Table
+authorsTable tableName =
+  (table tableName)
+    { tableColumns =
+        [ Schema.column "id" Schema.TInt,
+          Schema.column "name" Schema.TStr
+        ],
+      tablePrimaryKey = ["id"],
+      tableData =
+        [ [Schema.VInt 1, Schema.VStr "Author 1"],
+          [Schema.VInt 2, Schema.VStr "Author 2"]
+        ]
+    }
+
+--------------------------------------------------------------------------------
+-- Tests
+
+tests :: Fixture.Options -> SpecWith (TestEnvironment, (GraphqlEngine.Server, Webhook.EventsQueue))
+tests _opts = do
+  scheduledEventsWithInvalidEnvVar
+
+scheduledEventsWithInvalidEnvVar :: SpecWith (TestEnvironment, (GraphqlEngine.Server, Webhook.EventsQueue))
+scheduledEventsWithInvalidEnvVar =
+  describe "creating a scheduled event with invalid env var should add a failed invocation log" do
+    it "check the invocation log requests added for failed request corresponding to invalid header" $
+      \(testEnvironment, (_, _)) -> do
+        -- get all the scheduled event invocations
+        let getScheduledEventInvocationsQuery =
+              [yaml|
+              type: get_scheduled_event_invocations
+              args:
+                type: one_off
+            |]
+
+        -- wait for all scheduled event retries to complete
+        sleep $ seconds 20
+
+        apiRes <- GraphqlEngine.postMetadata testEnvironment getScheduledEventInvocationsQuery
+
+        -- get the number of invocations present
+        let resArray = KM.lookup "invocations" $ fromObject apiRes
+            resLength = case resArray of
+              Just (Array arr) -> length arr
+              _ -> 0
+
+        -- a scheduled event with 1 retry (and invalid header) should add 2 invocation logs
+        resLength `shouldBe` 2
+
+--------------------------------------------------------------------------------
+
+-- ** Setup override
+
+postgresSetup :: TestEnvironment -> GraphqlEngine.Server -> IO ()
+postgresSetup testEnvironment webhookServer = do
+  let webhookServerEchoEndpoint = GraphqlEngine.serverUrl webhookServer ++ "/echo"
+  GraphqlEngine.postMetadata_ testEnvironment $
+    [interpolateYaml|
+      type: create_scheduled_event
+      args:
+        webhook: #{webhookServerEchoEndpoint}
+        schedule_at: '2023-03-06T13:36:00Z'
+        payload:
+          test: 1
+        headers:
+          - name: test_header
+            value_from_env: invalid_envvar3
+        retry_conf:
+          num_retries: 1
+          retry_interval_seconds: 5
+    |]

server/src-lib/Data/URL/Template.hs

@@ -66,15 +66,11 @@ parseURLTemplate t = parseOnly parseTemplate t
     parseVariable =
       string "{{" *> (Variable . T.pack <$> manyTill anyChar (string "}}"))
 
-renderURLTemplate :: Env.Environment -> URLTemplate -> Either String Text
+renderURLTemplate :: Env.Environment -> URLTemplate -> Either Text Text
 renderURLTemplate env template =
   case errorVariables of
     [] -> Right $ T.concat $ rights eitherResults
-    _ ->
-      Left $
-        T.unpack $
-          "Value for environment variables not found: "
-            <> commaSeparated errorVariables
+    _ -> Left (commaSeparated errorVariables)
   where
     eitherResults = map renderTemplateItem $ unURLTemplate template
     errorVariables = lefts eitherResults

server/src-lib/Hasura/Eventing/ScheduledTrigger.hs

@@ -132,7 +132,9 @@ import Data.Int (Int64)
 import Data.List.NonEmpty qualified as NE
 import Data.SerializableBlob qualified as SB
 import Data.Set qualified as Set
-import Data.Text.Extended ((<<>))
+import Data.Text qualified as T
+import Data.Text.Extended (ToTxt (..), (<<>))
+import Data.These
 import Data.Time.Clock
 import Data.URL.Template (printURLTemplate)
 import Database.PG.Query qualified as PG
@@ -147,7 +149,7 @@ import Hasura.HTTP (getHTTPExceptionStatus)
 import Hasura.Logging qualified as L
 import Hasura.Metadata.Class
 import Hasura.Prelude
-import Hasura.RQL.DDL.EventTrigger (getHeaderInfosFromConf)
+import Hasura.RQL.DDL.EventTrigger (ResolveHeaderError, getHeaderInfosFromConfEither)
 import Hasura.RQL.DDL.Headers
 import Hasura.RQL.DDL.Webhook.Transform
 import Hasura.RQL.Types.Common
@@ -305,9 +307,6 @@ processOneOffScheduledEvents
     saveLockedEvents (map _ooseId oneOffEvents) lockedOneOffScheduledEvents
     for_ oneOffEvents $ \OneOffScheduledEvent {..} -> do
       (either logInternalError pure) =<< runExceptT do
-        webhookInfo <- resolveWebhook env _ooseWebhookConf
-        headerInfo <- getHeaderInfosFromConf env _ooseHeaderConf
-
         let payload =
               ScheduledEventWebhookPayload
                 _ooseId
@@ -319,13 +318,43 @@ processOneOffScheduledEvents
                 _ooseRequestTransform
                 _ooseResponseTransform
             retryCtx = RetryContext _ooseTries _ooseRetryConf
-            webhookEnvRecord = EnvRecord (getTemplateFromUrl _ooseWebhookConf) webhookInfo
-        flip runReaderT (logger, httpMgr) $
-          processScheduledEvent prometheusMetrics _ooseId headerInfo retryCtx payload webhookEnvRecord OneOff
-        removeEventFromLockedEvents _ooseId lockedOneOffScheduledEvents
+            resolvedWebhookInfoEither = resolveWebhookEither env _ooseWebhookConf
+            resolvedHeaderInfoEither = getHeaderInfosFromConfEither env _ooseHeaderConf
+            -- `webhookAndHeaderInfo` returns webhook and header info (and errors)
+            webhookAndHeaderInfo = case (resolvedWebhookInfoEither, resolvedHeaderInfoEither) of
+              (Right resolvedEventWebhookInfo, Right resolvedEventHeaderInfo) -> do
+                let resolvedWebhookEnvRecord = EnvRecord (getTemplateFromUrl _ooseWebhookConf) resolvedEventWebhookInfo
+                Right (resolvedWebhookEnvRecord, resolvedEventHeaderInfo)
+              (Left eventWebhookErrorVars, Right _) -> Left $ This eventWebhookErrorVars
+              (Right _, Left eventHeaderErrorVars) -> Left $ That eventHeaderErrorVars
+              (Left eventWebhookErrors, Left eventHeaderErrorVars) -> Left $ These eventWebhookErrors eventHeaderErrorVars
+        case webhookAndHeaderInfo of
+          Right (webhookEnvRecord, eventHeaderInfo) -> do
+            flip runReaderT (logger, httpMgr) $
+              processScheduledEvent prometheusMetrics _ooseId eventHeaderInfo retryCtx payload webhookEnvRecord OneOff
+            removeEventFromLockedEvents _ooseId lockedOneOffScheduledEvents
+          Left envVarError ->
+            processError
+              _ooseId
+              retryCtx
+              []
+              OneOff
+              (mkErrorObject $ mkInvalidEnvVarErrMsg envVarError)
+              (HOther $ T.unpack $ qeError (err400 NotFound (mkInvalidEnvVarErrMsg envVarError)))
     where
       logInternalError err = liftIO . L.unLogger logger $ ScheduledTriggerInternalErr err
       getTemplateFromUrl url = printURLTemplate $ unInputWebhook url
+      mkInvalidEnvVarErrMsg envVarErrorValues = "The value for environment variables not found: " <> (getInvalidEnvVarText envVarErrorValues)
+      mkErrorObject envVarNameText =
+        J.object
+          [ "error"
+              J..= ( "Error creating the request. " <> envVarNameText
+                   )
+          ]
+      getInvalidEnvVarText :: These ResolveWebhookError ResolveHeaderError -> Text
+      getInvalidEnvVarText (This a) = toTxt a
+      getInvalidEnvVarText (That b) = toTxt b
+      getInvalidEnvVarText (These a b) = toTxt a <> ", " <> toTxt b
 
 processScheduledTriggers ::
   ( MonadIO m,

server/src-lib/Hasura/RQL/DDL/EventTrigger.hs

@@ -11,7 +11,9 @@ module Hasura.RQL.DDL.EventTrigger
     InvokeEventTriggerQuery,
     runInvokeEventTrigger,
     -- TODO(from master): review
+    ResolveHeaderError (..),
     getHeaderInfosFromConf,
+    getHeaderInfosFromConfEither,
     getWebhookInfoFromConf,
     buildEventTriggerInfo,
     getSourceTableAndTriggers,
@@ -46,6 +48,7 @@ where
 
 import Control.Lens (ifor_, makeLenses, (.~))
 import Data.Aeson
+import Data.Either.Combinators
 import Data.Environment qualified as Env
 import Data.Has (Has)
 import Data.HashMap.Strict qualified as HM
@@ -452,6 +455,12 @@ askEventTriggerInfo sourceName triggerName = do
 maxTriggerNameLength :: Int
 maxTriggerNameLength = 42
 
+-- Consists of a list of environment variables with invalid/missing values
+newtype ResolveHeaderError = ResolveHeaderError {unResolveHeaderError :: [Text]} deriving (Show)
+
+instance ToTxt ResolveHeaderError where
+  toTxt = commaSeparated . unResolveHeaderError
+
 getHeaderInfosFromConf ::
   QErrM m =>
   Env.Environment ->
@@ -466,6 +475,24 @@ getHeaderInfosFromConf env = mapM getHeader
         envVal <- getEnv env val
         return $ EventHeaderInfo hconf envVal
 
+-- This is similar to `getHeaderInfosFromConf` but it doesn't fail when an env var is invalid
+getHeaderInfosFromConfEither ::
+  Env.Environment ->
+  [HeaderConf] ->
+  Either ResolveHeaderError [EventHeaderInfo]
+getHeaderInfosFromConfEither env hConfList =
+  if isHeaderError
+    then Left (ResolveHeaderError $ lefts headerInfoList)
+    else Right (rights headerInfoList)
+  where
+    isHeaderError = any isLeft headerInfoList
+    headerInfoList = map getHeader hConfList
+    getHeader :: HeaderConf -> Either Text EventHeaderInfo
+    getHeader hconf = case hconf of
+      (HeaderConf _ (HVValue val)) -> Right $ EventHeaderInfo hconf val
+      (HeaderConf _ (HVEnv val)) ->
+        (Right . EventHeaderInfo hconf) =<< getEnvEither env val
+
 getWebhookInfoFromConf ::
   QErrM m =>
   Env.Environment ->

server/src-lib/Hasura/RQL/Types/Common.hs

@@ -19,12 +19,15 @@ module Hasura.RQL.Types.Common
     failureMsg,
     InputWebhook (..),
     ResolvedWebhook (..),
+    ResolveWebhookError (..),
     resolveWebhook,
+    resolveWebhookEither,
     Timeout (..),
     defaultActionTimeoutSecs,
     UrlConf (..),
     resolveUrlConf,
     getEnv,
+    getEnvEither,
     SourceName (..),
     defaultSource,
     sourceNameToText,
@@ -341,13 +344,20 @@ instance PG.FromCol InputWebhook where
     urlTemplate <- parseURLTemplate <$> PG.fromCol bs
     bimap (\e -> "Parsing URL template failed: " <> T.pack e) InputWebhook urlTemplate
 
+-- Consists of the environment variable name with missing/invalid value
+newtype ResolveWebhookError = ResolveWebhookError {unResolveWebhookError :: Text} deriving (Show, ToTxt)
+
 resolveWebhook :: QErrM m => Env.Environment -> InputWebhook -> m ResolvedWebhook
-resolveWebhook env (InputWebhook urlTemplate) = do
-  let eitherRenderedTemplate = renderURLTemplate env urlTemplate
-  either
-    (throw400 Unexpected . T.pack)
-    (pure . ResolvedWebhook)
+resolveWebhook env inputWebhook = do
+  let eitherRenderedTemplate = resolveWebhookEither env inputWebhook
+  onLeft
     eitherRenderedTemplate
+    (throw400 Unexpected . ("Value for environment variables not found: " <>) . unResolveWebhookError)
+
+-- This is similar to `resolveWebhook` but it doesn't fail when an env var is invalid
+resolveWebhookEither :: Env.Environment -> InputWebhook -> Either ResolveWebhookError ResolvedWebhook
+resolveWebhookEither env (InputWebhook urlTemplate) =
+  bimap ResolveWebhookError ResolvedWebhook (renderURLTemplate env urlTemplate)
 
 newtype Timeout = Timeout {unTimeout :: Int}
   deriving (Show, Eq, ToJSON, Generic, NFData)
@@ -546,10 +556,17 @@ resolveUrlConf env = \case
 
 getEnv :: QErrM m => Env.Environment -> Text -> m Text
 getEnv env k = do
-  let mEnv = Env.lookupEnv env (T.unpack k)
-  case mEnv of
-    Nothing -> throw400 NotFound $ "environment variable '" <> k <> "' not set"
-    Just envVal -> return (T.pack envVal)
+  let eitherEnv = getEnvEither env k
+  onLeft
+    eitherEnv
+    (\_ -> throw400 NotFound $ "environment variable '" <> k <> "' not set")
+
+-- This is similar to `getEnv` but it doesn't fail when the env var is invalid
+getEnvEither :: Env.Environment -> Text -> Either Text Text
+getEnvEither env k =
+  case Env.lookupEnv env (T.unpack k) of
+    Nothing -> Left k
+    Just envVal -> Right (T.pack envVal)
 
 -- | Various user-controlled configuration for metrics used by Pro
 data MetricsConfig = MetricsConfig