SelectSpec.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}

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

import Data.ByteString (ByteString)
#if __GLASGOW_HASKELL__ < 804
import Data.Monoid ((<>))
#endif
import Network.HTTP.Types (Status, status200, status401, status500)
import Network.Wai
import Network.Wai.Middleware.Select
import Network.Wai.Test (SResponse (simpleStatus), request, runSession)
import Test.Hspec

main :: IO ()
main = hspec spec

spec :: Spec
spec = describe "Select" $ do
    it "With empty select should passthrough" $
        runApp (selectMiddleware mempty) "/" `shouldReturn` status200
    it "With other path select should passthrough" $
        runApp (selectMiddleware $ selectOverride "/_" status401) "/"
            `shouldReturn` status200
    it "With path select should hit override" $
        runApp (selectMiddleware $ selectOverride "/_" status401) "/_"
            `shouldReturn` status401
    it "With twice path select should hit first override" $
        runApp
            ( selectMiddleware $
                selectOverride "/_" status401 <> selectOverride "/_" status500
            )
            "/_"
            `shouldReturn` status401
    it "With two paths select should hit first matching (first)" $
        runApp
            ( selectMiddleware $
                selectOverride "/_" status401 <> selectOverride "/-" status500
            )
            "/_"
            `shouldReturn` status401
    it "With two paths select should hit first matching (last)" $
        runApp
            ( selectMiddleware $
                selectOverride "/_" status401 <> selectOverride "/-" status500
            )
            "/-"
            `shouldReturn` status500
    it "With other two paths select should passthrough" $
        runApp
            ( selectMiddleware $
                selectOverride "/_" status401 <> selectOverride "/-" status500
            )
            "/"
            `shouldReturn` status200
    it "With mempty then the path select should hit the pass" $
        runApp (selectMiddleware $ mempty <> selectOverride "/-" status500) "/-"
            `shouldReturn` status500

runApp :: Middleware -> ByteString -> IO Status
runApp mw path =
    fmap simpleStatus
        $ runSession
            (request $ defaultRequest{rawPathInfo = path})
        $ mw app

app :: Application
app = constApp status200

constApp :: Status -> Application
constApp status _ respond = respond $ responseLBS status [] ""

overrideMiddleware :: Application -> Middleware
overrideMiddleware = const

selectOverride :: ByteString -> Status -> MiddlewareSelection
selectOverride path status = selectMiddlewareOnRawPathInfo path $ overrideMiddleware $ constApp status