FrameworkSpecHelper.hs

{-# LANGUAGE OverloadedStrings #-}
module Web.Spock.FrameworkSpecHelper where

import Test.Hspec
import Test.Hspec.Wai

import Data.Monoid
import Data.Word
import Network.HTTP.Types.Header
import Network.HTTP.Types.Method
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Lazy.Char8 as BSLC
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Network.Wai as Wai

sizeLimitSpec :: (Word64 -> IO Wai.Application) -> Spec
sizeLimitSpec app =
    with (app maxSize) $
    describe "Request size limit" $
    do it "allows small enough requests the way" $
          do post "/size" okBs `shouldRespondWith` matcher 200 okBs
             post "/size" okBs2 `shouldRespondWith` matcher 200 okBs2
       it "denys large requests the way" $
          post "/size" tooLongBs `shouldRespondWith` 413
    where
      matcher s b =
          ResponseMatcher
          { matchStatus = s
          , matchBody = Just b
          , matchHeaders = []
          }
      maxSize = 1024
      okBs = BSLC.replicate (fromIntegral maxSize - 50) 'i'
      okBs2 = BSLC.replicate (fromIntegral maxSize) 'j'
      tooLongBs = BSLC.replicate (fromIntegral maxSize + 100) 'k'


frameworkSpec :: IO Wai.Application -> Spec
frameworkSpec app =
    with app $
    do routingSpec
       actionSpec
       headerTest
       cookieTest

routingSpec :: SpecWith Wai.Application
routingSpec =
    describe "Routing Framework" $
      do it "allows root actions" $
            get "/" `shouldRespondWith` "root" { matchStatus = 200 }
         it "routes different HTTP-verbs to different actions" $
            do verbTest get "GET"
               verbTest (`post` "") "POST"
               verbTest (`put` "") "PUT"
               verbTest delete "DELETE"
               verbTest (`patch` "") "PATCH"
               verbTestGp get "GETPOST"
               verbTestGp (`post` "") "GETPOST"
         it "can extract params from routes" $
            get "/param-test/42" `shouldRespondWith` "int42" { matchStatus = 200 }
         it "can handle multiple matching routes" $
            get "/param-test/static" `shouldRespondWith` "static" { matchStatus = 200 }
         it "ignores trailing slashes" $
            get "/param-test/static/" `shouldRespondWith` "static" { matchStatus = 200 }
         it "works with subcomponents" $
            do get "/subcomponent/foo" `shouldRespondWith` "foo" { matchStatus = 200 }
               get "/subcomponent/subcomponent2/bar" `shouldRespondWith` "bar" { matchStatus = 200 }
         it "allows the definition of a fallback handler" $
            get "/askldjas/aklsdj" `shouldRespondWith` "askldjas/aklsdj" { matchStatus = 200 }
         it "allows the definition of a fallback handler for custom verb" $
            request "MYVERB" "/askldjas/aklsdj" [] "" `shouldRespondWith` "askldjas/aklsdj" { matchStatus = 200 }
         it "detected the preferred format" $
            request "GET" "/preferred-format" [("Accept", "text/html,application/xml;q=0.9,image/webp,*/*;q=0.8")] "" `shouldRespondWith` "html" { matchStatus = 200 }
         it "/test-slash and test-noslash are the same thing" $
            do get "/test-slash" `shouldRespondWith` "ok" { matchStatus = 200 }
               get "test-slash" `shouldRespondWith` "ok" { matchStatus = 200 }
               get "/test-noslash" `shouldRespondWith` "ok" { matchStatus = 200 }
               get "test-noslash" `shouldRespondWith` "ok" { matchStatus = 200 }
         it "allows custom verbs" $
            request "NOTIFY" "/notify/itnotifies" [] "" `shouldRespondWith` "itnotifies" { matchStatus = 200 }
    where
      verbTestGp verb verbVerbose =
          verb "/verb-test-gp" `shouldRespondWith` (verbVerbose { matchStatus = 200 })
      verbTest verb verbVerbose =
          verb "/verb-test" `shouldRespondWith` (verbVerbose { matchStatus = 200 })

errorHandlerSpec :: IO Wai.Application -> Spec
errorHandlerSpec app =
    with app $ describe "Error Handler" $
        do it "handles non-existing routes correctly" $
            do get "/non/existing/route" `shouldRespondWith` "NOT FOUND" { matchStatus = 404 }
               post "/non/existing/route" "" `shouldRespondWith` "NOT FOUND" { matchStatus = 404 }
               put "/non/existing/route" "" `shouldRespondWith` "NOT FOUND" { matchStatus = 404 }
               patch "/non/existing/route" "" `shouldRespondWith` "NOT FOUND" { matchStatus = 404 }
           it "handles server errors correctly" $
               get "/failing/route" `shouldRespondWith` "SERVER ERROR" { matchStatus = 500 }
           it "does not interfere with user emitted errors" $
               get "/user/error" `shouldRespondWith` "UNAUTHORIZED" { matchStatus = 403 }


actionSpec :: SpecWith Wai.Application
actionSpec =
    describe "Action Framework" $
      do it "handles auth correctly" $
            do request methodGet "/auth/user/pass" [mkAuthHeader "user" "pass"] "" `shouldRespondWith` "ok" { matchStatus = 200 }
               request methodGet "/auth/user/pass" [mkAuthHeader "user" ""] "" `shouldRespondWith` "err" { matchStatus = 401 }
               request methodGet "/auth/user/pass" [mkAuthHeader "" ""] "" `shouldRespondWith` "err" { matchStatus = 401 }
               request methodGet "/auth/user/pass" [mkAuthHeader "asd" "asd"] "" `shouldRespondWith` "err" { matchStatus = 401 }
               request methodGet "/auth/user/pass" [] "" `shouldRespondWith` "Authentication required. " { matchStatus = 401 }
    where
      mkAuthHeader :: BS.ByteString -> BS.ByteString -> Header
      mkAuthHeader user pass =
          ("Authorization", "Basic " <> (B64.encode $ user <> ":" <> pass))

cookieTest :: SpecWith Wai.Application
cookieTest =
    describe "Cookies" $
    do it "sets single cookies correctly" $
          get "/cookie/single" `shouldRespondWith`
                  "set"
                  { matchStatus = 200
                  , matchHeaders =
                      [ matchCookie "single" "test"
                      ]
                  }
       it "sets multiple cookies correctly" $
          get "/cookie/multiple" `shouldRespondWith`
                  "set"
                  { matchStatus = 200
                  , matchHeaders =
                      [ matchCookie "multiple1" "test1"
                      , matchCookie "multiple2" "test2"
                      ]
                  }
headerTest :: SpecWith Wai.Application
headerTest =
    describe "Headers" $
    do it "supports custom headers" $
          get "/set-header" `shouldRespondWith`
                  "ok"
                  { matchStatus = 200
                  , matchHeaders =
                      [ "X-FooBar" <:> "Baz"
                      ]
                  }
       it "supports multi headers" $
          get "/set-multi-header" `shouldRespondWith`
                  "ok"
                  { matchStatus = 200
                  , matchHeaders =
                      [ "Content-Language" <:> "de"
                      , "Content-Language" <:> "en"
                      ]
                  }

matchCookie :: T.Text -> T.Text -> MatchHeader
matchCookie name val =
    MatchHeader $ \headers ->
        let relevantHeaders = filter (\h -> fst h == "Set-Cookie") headers
            loop [] =
                Just ("No cookie named " ++ T.unpack name ++ " with value "
                      ++ T.unpack val ++ " found")
            loop (x:xs) =
                let (cname, cval) = T.breakOn "=" $ fst $ T.breakOn ";" $ T.decodeUtf8 $ snd x
                in if cname == name && cval == "=" <> val
                   then Nothing
                   else loop xs
        in loop relevantHeaders