Wai.hs

{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wno-orphans #-}

-- | This module is designed to be imported as follows:
--
-- @
-- import qualified "Di.Wai"
-- @
module Di.Wai (middleware) where

import Control.Monad.IO.Class
import Data.Foldable
import Data.IORef
import Data.Vault.Lazy qualified as V
import Data.Word
import Df1.Wai qualified
import Di.Df1 qualified
import Network.Wai qualified as Wai
import System.Clock qualified as Clock

-- | Obtain a 'Wai.Middleware' that will log incomming 'Wai.Request's
-- and outgoing 'Wai.Response's.
--
-- @
-- do (__middleware__, __lookup__) <- "Di.Wai".'middleware' di
-- @
--
-- * The obtained @__middleware__@ shall be applied to your 'Wai.Application'.
--
-- * The obtained @__lookup__@ function can be used to obtain the 'Di.Df1.Df1'
-- that includes 'Df1.Path' data about 'Wai.Request'. It returns 'Nothing' if
-- this particular @__middleware__@ was not used on the given 'Wai.Request'.
middleware
   :: (MonadIO m)
   => Di.Df1.Df1
   -> m (Wai.Middleware, Wai.Request -> Maybe Di.Df1.Df1)
middleware di0 = liftIO $ do
   ref :: IORef Word64 <- newIORef 0
   vk :: V.Key Di.Df1.Df1 <- V.newKey
   pure
      ( \app req respond -> do
         t0 <- Clock.getTime Clock.Monotonic
         reqId <- atomicModifyIORef' ref $ \ol -> (ol + 1, ol)
         let di1 =
               foldl'
                  (\di (k, v) -> Di.Df1.attr k v di)
                  (Di.Df1.push "http" di0)
                  (("request", Di.Df1.value reqId) : Df1.Wai.request req)
         Di.Df1.info_ di1 "Request coming in"
         app (req{Wai.vault = V.insert vk di1 (Wai.vault req)}) $ \res -> do
            t1 <- Clock.getTime Clock.Monotonic
            let td = Clock.toNanoSecs t1 - Clock.toNanoSecs t0
                di2 =
                  foldl'
                     (\di (k, v) -> Di.Df1.attr k v di)
                     di1
                     (("nanoseconds", Di.Df1.value td) : Df1.Wai.response res)
            Di.Df1.info_ di2 "Response going out"
            respond res
      , \req -> V.lookup vk (Wai.vault req)
      )