{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
module Network.Wai.Middleware.Clacks
( clacks
, Clacks(..)
, gnuTerryPratchett
, clacksHeaderName
)
where
import Prelude.Compat
import Data.List.NonEmpty.Compat ( NonEmpty(..)
, toList
)
import Data.Text.Encoding ( encodeUtf8 )
import Network.HTTP.Types.Header ( ResponseHeaders
, HeaderName
)
import Network.Wai ( Middleware
, modifyResponse
, mapResponseHeaders
)
import qualified Data.ByteString as BS
import qualified Data.CaseInsensitive as CI
import qualified Data.List as L
import qualified Data.Text as T
clacks :: Clacks -> Middleware
clacks settings = modifyResponse $ mapResponseHeaders addHeader
where
headerContents :: BS.ByteString
headerContents =
encodeUtf8 . T.intercalate "," . toList $ clacksMessages settings
addHeader :: ResponseHeaders -> ResponseHeaders
addHeader hs = case L.find ((== clacksHeaderName) . fst) hs of
Nothing -> (clacksHeaderName, headerContents) : hs
Just (_, "") -> (clacksHeaderName, headerContents) : hs
Just (name, contents) ->
(name, contents <> "," <> headerContents)
: filter ((/= clacksHeaderName) . fst) hs
newtype Clacks =
Clacks
{ clacksMessages :: NonEmpty T.Text
} deriving (Show, Read, Eq)
gnuTerryPratchett :: Clacks
gnuTerryPratchett = Clacks $ "GNU Terry Pratchett" :| []
clacksHeaderName :: HeaderName
clacksHeaderName = CI.mk "X-Clacks-Overhead"