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, middleware') where

import Data.Foldable
import Data.IORef
import Data.Word
import Df1.Wai qualified
import Di.Df1 qualified as Di
import Network.Wai qualified as Wai
import System.Clock qualified as Clock
import System.IO.Unsafe

refReqId :: IORef Word64
refReqId = unsafePerformIO $ newIORef 0
{-# NOINLINE refReqId #-}

-- | Like 'middleware', but it exposes the 'Di.Df1' that includes 'Df1.Path'
-- data about 'Wai.Request' to the underlying 'Wai.Application'.
middleware'
   :: Di.Df1
   -> (Di.Df1 -> Wai.Application)
   -> Wai.Application
middleware' di0 = \fapp req respond -> do
   t0 <- Clock.getTime Clock.Monotonic
   reqId <- atomicModifyIORef' refReqId $ \ol -> (ol + 1, ol)
   let di1 =
         foldl'
            (\di (k, v) -> Di.attr k v di)
            (Di.push "http" di0)
            (("request", Di.value reqId) : Df1.Wai.request req)
   Di.info_ di1 "Request coming in"
   fapp di1 req $ \res -> do
      t1 <- Clock.getTime Clock.Monotonic
      let td = Clock.toNanoSecs t1 - Clock.toNanoSecs t0
          di2 =
            foldl'
               (\di (k, v) -> Di.attr k v di)
               di1
               (("nanoseconds", Di.value td) : Df1.Wai.response res)
      Di.info_ di2 "Response going out"
      respond res

-- | Obtain a 'Wai.Middleware' that will log incomming 'Wai.Request's
-- and outgoing 'Wai.Response's through the given 'Di.Df1'.
--
-- If your 'Wai.Application' needs access to the 'Di.Df1' uniquely tied
-- to the current 'Wai.Request', then use 'middleware'' instead.
middleware :: Di.Df1 -> Wai.Middleware
middleware di = middleware' di . const