-- | Integration of "Freckle.App" tooling with "Yesod"
module Freckle.App.Yesod
  ( makeLogger
  , messageLoggerSource

  -- * Functions for use as 'yesodMiddleware'
  , respondQueryCanceled
  , respondQueryCanceledHeaders
  ) where

import Freckle.App.Prelude

import Control.Monad.Logger
import Data.Text (pack)
import Database.PostgreSQL.Simple (SqlError(..))
import Freckle.App.Datadog (HasDogStatsClient, HasDogStatsTags)
import qualified Freckle.App.Datadog as Datadog
import Freckle.App.GlobalCache
import Freckle.App.Logging
import Network.HTTP.Types (ResponseHeaders, status503)
import qualified Network.Wai as W
import System.IO.Unsafe (unsafePerformIO)
import System.Log.FastLogger
  ( LoggerSet
  , defaultBufSize
  , newFileLoggerSet
  , newStderrLoggerSet
  , newStdoutLoggerSet
  )
import UnliftIO.Exception (handleJust)
import Yesod.Core.Handler (sendWaiResponse)
import Yesod.Core.Types (HandlerFor, Logger, loggerPutStr)
import Yesod.Default.Config2 (makeYesodLogger)

loggerSetVar :: GlobalCache LoggerSet
loggerSetVar :: GlobalCache LoggerSet
loggerSetVar = IO (GlobalCache LoggerSet) -> GlobalCache LoggerSet
forall a. IO a -> a
unsafePerformIO IO (GlobalCache LoggerSet)
forall a. IO (GlobalCache a)
newGlobalCache
{-# NOINLINE loggerSetVar #-}
{-# ANN loggerSetVar ("HLint: ignore Avoid restricted function" :: String) #-}

makeLogger :: HasLogging a => a -> IO Logger
makeLogger :: a -> IO Logger
makeLogger a
app = LoggerSet -> IO Logger
makeYesodLogger
  (LoggerSet -> IO Logger) -> IO LoggerSet -> IO Logger
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< GlobalCache LoggerSet -> IO LoggerSet -> IO LoggerSet
forall a. GlobalCache a -> IO a -> IO a
globallyCache GlobalCache LoggerSet
loggerSetVar (BufSize -> IO LoggerSet
newLoggerSet BufSize
defaultBufSize)
 where
  newLoggerSet :: BufSize -> IO LoggerSet
newLoggerSet = case a -> LogLocation
forall a. HasLogging a => a -> LogLocation
getLogLocation a
app of
    LogLocation
LogStdout -> BufSize -> IO LoggerSet
newStdoutLoggerSet
    LogLocation
LogStderr -> BufSize -> IO LoggerSet
newStderrLoggerSet
    LogFile FilePath
f -> (BufSize -> FilePath -> IO LoggerSet)
-> FilePath -> BufSize -> IO LoggerSet
forall a b c. (a -> b -> c) -> b -> a -> c
flip BufSize -> FilePath -> IO LoggerSet
newFileLoggerSet FilePath
f

messageLoggerSource
  :: HasLogging a
  => a
  -> Logger
  -> Loc
  -> LogSource
  -> LogLevel
  -> LogStr
  -> IO ()
messageLoggerSource :: a -> Logger -> Loc -> LogSource -> LogLevel -> LogStr -> IO ()
messageLoggerSource a
app Logger
logger Loc
loc LogSource
src LogLevel
level LogStr
str =
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LogLevel
level LogLevel -> LogLevel -> Bool
forall a. Ord a => a -> a -> Bool
>= a -> LogLevel
forall a. HasLogging a => a -> LogLevel
getLogLevel a
app)
    (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Logger -> LogStr -> IO ()
loggerPutStr Logger
logger
    (LogStr -> IO ()) -> LogStr -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr
    (ByteString -> LogStr) -> ByteString -> LogStr
forall a b. (a -> b) -> a -> b
$ case a -> LogFormat
forall a. HasLogging a => a -> LogFormat
getLogFormat a
app of
        LogFormat
FormatJSON -> Loc -> LogSource -> LogLevel -> LogStr -> ByteString
formatJsonLogStr Loc
loc LogSource
src LogLevel
level LogStr
str
        LogFormat
FormatTerminal ->
          Bool -> Loc -> LogSource -> LogLevel -> LogStr -> ByteString
forall a.
ToLogStr a =>
Bool -> Loc -> LogSource -> LogLevel -> a -> ByteString
formatTerminal (a -> Bool
forall a. HasLogging a => a -> Bool
getLogDefaultANSI a
app) Loc
loc LogSource
src LogLevel
level LogStr
str

-- | Catch 'SqlError' when queries are canceled due to timeout and respond 503
--
-- Also logs and increments a metric.
--
respondQueryCanceled
  :: (HasDogStatsClient site, HasDogStatsTags site)
  => HandlerFor site res
  -> HandlerFor site res
respondQueryCanceled :: HandlerFor site res -> HandlerFor site res
respondQueryCanceled = ResponseHeaders -> HandlerFor site res -> HandlerFor site res
forall site res.
(HasDogStatsClient site, HasDogStatsTags site) =>
ResponseHeaders -> HandlerFor site res -> HandlerFor site res
respondQueryCanceledHeaders []

-- | 'respondQueryCanceledHeaders' but adding headers to the 503 response
respondQueryCanceledHeaders
  :: (HasDogStatsClient site, HasDogStatsTags site)
  => ResponseHeaders
  -> HandlerFor site res
  -> HandlerFor site res
respondQueryCanceledHeaders :: ResponseHeaders -> HandlerFor site res -> HandlerFor site res
respondQueryCanceledHeaders ResponseHeaders
headers = (SqlError -> Maybe SqlError)
-> (SqlError -> HandlerFor site res)
-> HandlerFor site res
-> HandlerFor site res
forall (m :: * -> *) e b a.
(MonadUnliftIO m, Exception e) =>
(e -> Maybe b) -> (b -> m a) -> m a -> m a
handleJust SqlError -> Maybe SqlError
queryCanceled ((SqlError -> HandlerFor site res)
 -> HandlerFor site res -> HandlerFor site res)
-> (SqlError -> HandlerFor site res)
-> HandlerFor site res
-> HandlerFor site res
forall a b. (a -> b) -> a -> b
$ \SqlError
ex -> do
  LogSource -> HandlerFor site ()
forall (m :: * -> *). MonadLogger m => LogSource -> m ()
logErrorN (LogSource -> HandlerFor site ())
-> LogSource -> HandlerFor site ()
forall a b. (a -> b) -> a -> b
$ FilePath -> LogSource
pack (FilePath -> LogSource) -> FilePath -> LogSource
forall a b. (a -> b) -> a -> b
$ SqlError -> FilePath
forall a. Show a => a -> FilePath
show SqlError
ex
  LogSource -> [(LogSource, LogSource)] -> HandlerFor site ()
forall (m :: * -> *) env.
(MonadUnliftIO m, MonadReader env m, HasDogStatsClient env,
 HasDogStatsTags env) =>
LogSource -> [(LogSource, LogSource)] -> m ()
Datadog.increment LogSource
"query_canceled" []
  Response -> HandlerFor site res
forall (m :: * -> *) b. MonadHandler m => Response -> m b
sendWaiResponse (Response -> HandlerFor site res)
-> Response -> HandlerFor site res
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
W.responseLBS Status
status503 ResponseHeaders
headers ByteString
"Query canceled"

queryCanceled :: SqlError -> Maybe SqlError
queryCanceled :: SqlError -> Maybe SqlError
queryCanceled SqlError
ex = SqlError
ex SqlError -> Maybe () -> Maybe SqlError
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (SqlError -> ByteString
sqlState SqlError
ex ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"57014")