module Network.Wai.Middleware.Stats
  ( addThreadContextFromStatsTags
  , requestStats
  ) where

import Freckle.App.Prelude

import Blammo.Logging (Pair, withThreadContext)
import Control.Lens ((^.))
import Control.Monad.Reader (runReaderT)
import Data.Aeson ((.=))
import qualified Freckle.App.Aeson as Key
import Freckle.App.Stats (HasStatsClient (..), tagsL)
import qualified Freckle.App.Stats as Stats
import Network.HTTP.Types.Status (Status (..))
import Network.Wai (Middleware, Request, requestMethod, responseStatus)

-- | Add any tags in the ambient 'StatsClient' to the logging context
addThreadContextFromStatsTags :: HasStatsClient env => env -> Middleware
addThreadContextFromStatsTags :: forall env. HasStatsClient env => env -> Middleware
addThreadContextFromStatsTags env
env Application
app Request
req Response -> IO ResponseReceived
respond = do
  let context :: [Pair]
context = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Text -> Text -> Pair
fromTag forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> env
env forall s a. s -> Getting a s a -> a
^. forall env. HasStatsClient env => Lens' env StatsClient
statsClientL forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' StatsClient [(Text, Text)]
tagsL
  forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
[Pair] -> m a -> m a
withThreadContext [Pair]
context forall a b. (a -> b) -> a -> b
$ Application
app Request
req Response -> IO ResponseReceived
respond
 where
  fromTag :: Text -> Text -> Pair
  fromTag :: Text -> Text -> Pair
fromTag Text
k Text
v = Text -> Key
Key.fromText Text
k forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
v

-- | Emit @requests@ and @response_time_ms@ metrics
requestStats
  :: HasStatsClient env => env -> (Request -> [(Text, Text)]) -> Middleware
requestStats :: forall env.
HasStatsClient env =>
env -> (Request -> [(Text, Text)]) -> Middleware
requestStats env
env Request -> [(Text, Text)]
getTags Application
app Request
req Response -> IO ResponseReceived
respond = do
  UTCTime
start <- IO UTCTime
getCurrentTime
  Application
app Request
req forall a b. (a -> b) -> a -> b
$ \Response
res -> do
    let tags :: [(Text, Text)]
tags =
          Request -> [(Text, Text)]
getTags Request
req
            forall a. Semigroup a => a -> a -> a
<> [ (Text
"method", ByteString -> Text
decodeUtf8 forall a b. (a -> b) -> a -> b
$ Request -> ByteString
requestMethod Request
req)
               , (Text
"status", String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Status -> Int
statusCode forall a b. (a -> b) -> a -> b
$ Response -> Status
responseStatus Response
res)
               ]

    forall a b c. (a -> b -> c) -> b -> a -> c
flip forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT env
env forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *) a.
(MonadReader env m, HasStatsClient env) =>
[(Text, Text)] -> m a -> m a
Stats.tagged [(Text, Text)]
tags forall a b. (a -> b) -> a -> b
$ do
      forall (m :: * -> *) env.
(MonadUnliftIO m, MonadReader env m, HasStatsClient env) =>
Text -> m ()
Stats.increment Text
"requests"
      forall (m :: * -> *) env.
(MonadUnliftIO m, MonadReader env m, HasStatsClient env) =>
Text -> UTCTime -> m ()
Stats.histogramSinceMs Text
"response_time_ms" UTCTime
start

    Response -> IO ResponseReceived
respond Response
res