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

import Freckle.App.Prelude

import Control.Monad.Reader (runReaderT)
import Freckle.App.Stats (HasStatsClient)
import qualified Freckle.App.Stats as Stats
import Network.HTTP.Types.Status (Status(..))
import Network.Wai (Middleware, Request, requestMethod, responseStatus)

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