-- | 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 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")