CombineHeadersSpec.hs

{-# LANGUAGE OverloadedStrings #-}

module Network.Wai.Middleware.CombineHeadersSpec (
    main,
    spec,
) where

import Data.ByteString (ByteString)
import Data.IORef (newIORef, readIORef, writeIORef)
import Network.HTTP.Types (status200)
import Network.HTTP.Types.Header
import Network.Wai
import Test.Hspec

import Network.Wai.Middleware.CombineHeaders (
    CombineSettings,
    combineHeaders,
    defaultCombineSettings,
    setRequestHeaders,
    setResponseHeaders,
 )
import Network.Wai.Test (SResponse (simpleHeaders), request, runSession)

main :: IO ()
main = hspec spec

spec :: Spec
spec = do
    let test name settings reqHeaders expectedReqHeaders resHeaders expectedResHeaders = it name $ do
            (reqHdrs, resHdrs) <- runApp settings reqHeaders resHeaders
            reqHdrs `shouldBe` expectedReqHeaders
            resHdrs `shouldBe` expectedResHeaders
        testReqHdrs name a b =
            test name defaultCombineSettings a b [] []
        testResHdrs name a b =
            test
                name
                (setRequestHeaders False $ setResponseHeaders True defaultCombineSettings)
                []
                []
                a
                b

    -- Request Headers
    testReqHdrs
        "should reorder alphabetically (request)"
        [host, userAgent, acceptHtml]
        [acceptHtml, host, userAgent]
    -- Response Headers
    testResHdrs
        "should reorder alphabetically (response)"
        [expires, location, contentTypeHtml]
        [contentTypeHtml, expires, location]

    -- Request Headers
    testReqHdrs
        "combines Accept (in order)"
        [userAgent, acceptHtml, host, acceptJSON]
        [acceptHtml `combineHdrs` acceptJSON, host, userAgent]
    -- Response Headers
    testResHdrs
        -- Using the default header map, Cache-Control is a "combineable" header, "Set-Cookie" is not
        "combines Cache-Control (in order) and keeps Set-Cookie (in order)"
        [cacheControlPublic, setCookie "2", date, cacheControlMax, setCookie "1"]
        [ cacheControlPublic `combineHdrs` cacheControlMax
        , date
        , setCookie "2"
        , setCookie "1"
        ]

    -- Request Headers
    testReqHdrs
        "KeepOnly works as expected (present | request)"
        -- "Alt-Svc" has (KeepOnly "clear")
        [date, altSvc "wrong", altSvc "clear", altSvc "wrong again", host]
        [altSvc "clear", date, host]
    testReqHdrs
        "KeepOnly works as expected ( absent | request)"
        -- "Alt-Svc" has (KeepOnly "clear"), but will combine when there's no "clear" (AND keeps order)
        [date, altSvc "wrong", altSvc "not clear", altSvc "wrong again", host]
        [altSvc "wrong, not clear, wrong again", date, host]

    -- Response Headers
    testResHdrs
        "KeepOnly works as expected (present | response)"
        -- "If-None-Match" has (KeepOnly "*")
        [date, ifNoneMatch "wrong", ifNoneMatch "*", ifNoneMatch "wrong again", host]
        [date, host, ifNoneMatch "*"]
    testResHdrs
        "KeepOnly works as expected ( absent | response)"
        -- "If-None-Match" has (KeepOnly "*"), but will combine when there's no "*" (AND keeps order)
        [ date
        , ifNoneMatch "wrong"
        , ifNoneMatch "not *"
        , ifNoneMatch "wrong again"
        , host
        ]
        [date, host, ifNoneMatch "wrong, not *, wrong again"]

    -- Request Headers
    testReqHdrs
        "Technically acceptable headers get combined correctly (request)"
        [ ifNoneMatch "correct, "
        , ifNoneMatch "something else \t"
        , ifNoneMatch "and more , "
        ]
        [ifNoneMatch "correct, something else, and more"]
    -- Response Headers
    testResHdrs
        "Technically acceptable headers get combined correctly (response)"
        [altSvc "correct\t, ", altSvc "something else", altSvc "and more, , "]
        [altSvc "correct, something else, and more"]

combineHdrs :: Header -> Header -> Header
combineHdrs (hname, h1) (_, h2) = (hname, h1 <> ", " <> h2)

acceptHtml
    , acceptJSON
    , cacheControlMax
    , cacheControlPublic
    , contentTypeHtml
    , date
    , expires
    , host
    , location
    , userAgent
        :: Header
acceptHtml = (hAccept, "text/html")
acceptJSON = (hAccept, "application/json")
altSvc :: ByteString -> Header
altSvc x = ("Alt-Svc", x)
cacheControlPublic = (hCacheControl, "public")
cacheControlMax = (hCacheControl, "public")
contentTypeHtml = (hContentType, "text/html")
date = (hDate, "Mon, 19 Aug 2022 18:18:31 GMT")
expires = (hExpires, "Mon, 19 Sep 2022 18:18:31 GMT")
host = (hHost, "google.com")
ifNoneMatch :: ByteString -> Header
ifNoneMatch x = (hIfNoneMatch, x)
location = (hLocation, "http://www.google.com/")
setCookie :: ByteString -> Header
setCookie val = (hSetCookie, val)
userAgent = (hUserAgent, "curl/7.68.0")

runApp
    :: CombineSettings
    -> RequestHeaders
    -> ResponseHeaders
    -> IO (RequestHeaders, ResponseHeaders)
runApp settings reqHeaders resHeaders = do
    reqHdrs <- newIORef $ error "IORef not set"
    sResponse <-
        runSession
            session
            $ combineHeaders settings
            $ app reqHdrs
    finalReqHeaders <- readIORef reqHdrs
    pure (finalReqHeaders, simpleHeaders sResponse)
  where
    session =
        request
            defaultRequest{requestHeaders = reqHeaders}
    app hdrRef req respond = do
        writeIORef hdrRef $ requestHeaders req
        respond $ responseLBS status200 resHeaders ""