Repository: hasura/graphql-engine
File: server/src-lib/Hasura/Eventing/ScheduledTrigger.hs (Haskell)

Code before:
                    scheduledEvent = ScheduledEventFull id'
                                                        Nothing
                                                        scheduledTime
                                                        tries
                                                        webhook
                                                        payload'
                                                        retryConf
                                                        headerInfo'
                                                        comment
                finally <- runExceptT $
                  runReaderT (processScheduledEvent logEnv pgpool scheduledEvent StandAloneEvent) $
                                 (logger, httpMgr)
                removeEventFromLockedEvents id'
                either logInternalError pure finally

              Left headerInfoErr -> logInternalError headerInfoErr

          Left webhookInfoErr -> logInternalError webhookInfoErr

    Left standAloneScheduledEventsErr -> logInternalError standAloneScheduledEventsErr
  where
    logInternalError err = L.unLogger logger $ ScheduledTriggerInternalErr err

    saveLockedStandAloneEvents :: [StandAloneScheduledEvent] -> IO ()
    saveLockedStandAloneEvents standAloneEvents =
      liftIO $ atomically $ do
        lockedEvents <- readTVar lockedStandAloneEvents
        let ids = map saseId standAloneEvents
        writeTVar lockedStandAloneEvents $!
          Set.union lockedEvents $ Set.fromList ids

    removeEventFromLockedEvents :: ScheduledEventId -> IO ()
    removeEventFromLockedEvents eventId =
      liftIO $ atomically $ do
        lockedEvents <- readTVar lockedStandAloneEvents
        writeTVar lockedStandAloneEvents $! Set.delete eventId lockedEvents

processScheduledTriggers
  :: HasVersion
  => L.Logger L.Hasura
  -> LogEnvHeaders
  -> HTTP.Manager
  -> Q.PGPool
  -> IO SchemaCache
  -> LockedScheduledEventsCtx
  -> IO void
processScheduledTriggers logger logEnv httpMgr pgpool getSC LockedScheduledEventsCtx {..} =
  forever $ do
    processCronEvents logger logEnv httpMgr pgpool getSC lseCronEvents
    processStandAloneEvents logger logEnv httpMgr pgpool lseStandAloneEvents
    sleep (minutes 1)

Review comment (suggestion):
No need to use `liftIO` here if you’re just in plain old `IO`—`liftIO` is only necessary if you are in some other monad that wraps `IO`.

Code after:
  -> LockedEventsCtx
  -> IO void
processScheduledTriggers logger logEnv httpMgr pgpool getSC LockedEventsCtx {..} =
  forever $ do
    processCronEvents logger logEnv httpMgr pgpool getSC leCronEvents
    processStandAloneEvents logger logEnv httpMgr pgpool leStandAloneEvents
    sleep (minutes 1)

processScheduledEvent ::
  ( MonadReader r m
  , Has HTTP.Manager r
  , Has (L.Logger L.Hasura) r
  , HasVersion
  , MonadIO m
  , MonadError QErr m
  )
  => LogEnvHeaders
  -> Q.PGPool
  -> ScheduledEventFull
  -> ScheduledEventType
  -> m ()
processScheduledEvent
  logEnv pgpool se@ScheduledEventFull {..} type' = do
  currentTime <- liftIO getCurrentTime
  if convertDuration (diffUTCTime currentTime sefScheduledTime)
    > unNonNegativeDiffTime (strcToleranceSeconds sefRetryConf)
    then processDead pgpool se type'
    else do
      let timeoutSeconds = round $ unNonNegativeDiffTime
                             $ strcTimeoutSeconds sefRetryConf
          httpTimeout = HTTP.responseTimeoutMicro (timeoutSeconds * 1000000)
          headers = addDefaultHeaders $ map encodeHeader sefHeaders
          extraLogCtx = ExtraLogContext (Just currentTime) sefId
      res <- runExceptT $ tryWebhook headers httpTimeout sefPayload (T.unpack sefWebhook)
      logHTTPForST res extraLogCtx
      let decodedHeaders = map (decodeHeader logEnv sefHeaders) headers
      either
        (processError pgpool se decodedHeaders type')
        (processSuccess pgpool se decodedHeaders type')
        res

processError
  :: (MonadIO m, MonadError QErr m)
  => Q.PGPool -> ScheduledEventFull -> [HeaderConf] -> ScheduledEventType -> HTTPErr a  -> m ()
processError pgpool se decodedHeaders type' err = do
  let invocation = case err of
        HClient excp -> do
          let errMsg = TBS.fromLBS $ J.encode $ show excp
          mkInvocation se 1000 decodedHeaders errMsg []
        HParse _ detail -> do
          let errMsg = TBS.fromLBS $ J.encode detail