module Freckle.App.Yesod
( makeLogger
, messageLoggerSource
, 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
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
:: (HasDogStatsClient site, HasDogStatsTags site)
=> ResponseHeaders
-> HandlerFor site res
-> HandlerFor site res
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")