WAI Middleware to modify request headers

Middleware.hs

{-# LANGUAGE OverloadedStrings #-}

module Middlware where

import Control.Monad ((<=<))

import qualified Data.ByteString as B
import Network.HTTP.Types
import Network.Wai

data RemoteUserLookup = RemoteUserLookup
  HeaderName
  (B.ByteString -> Maybe B.ByteString)

remoteUserLookupX509 :: RemoteUserLookup
remoteUserLookupX509 = RemoteUserLookup "SSL_CLIENT_CERT" (const Nothing)

lookupRemoteUser :: RemoteUserLookup -> Request -> Maybe B.ByteString
lookupRemoteUser (RemoteUserLookup k f) =
  f <=< lookup k . requestHeaders

remoteUserLookupMiddleware :: RemoteUserLookup -> Middleware
remoteUserLookupMiddleware a = (. modreq)
  where
  modreq req = case lookupRemoteUser a req of
    Nothing -> req
    Just s ->
      req { requestHeaders = ("REMOTE_USER", s) : requestHeaders req }