{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Web.Spock.FrameworkSpecHelper where import Test.Hspec import Test.Hspec.Wai #if MIN_VERSION_hspec_wai(0,8,0) import Test.Hspec.Wai.Matcher #endif #if MIN_VERSION_base(4,11,0) #else import Data.Monoid #endif 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 statusBodyMatch :: Int -> BSLC.ByteString -> ResponseMatcher #if MIN_VERSION_hspec_wai(0,8,0) statusBodyMatch s b = ResponseMatcher { matchStatus = s , matchBody = bodyEquals b , matchHeaders = [] } #else statusBodyMatch s b = ResponseMatcher { matchStatus = s, matchBody = Just b, matchHeaders = [] } #endif 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 = statusBodyMatch 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 "allows access to get params" $ get "/get-params?foo=bar" `shouldRespondWith` "[(\"foo\",\"bar\")]" { matchStatus = 200 } it "supports wai app responses" $ do get "/wai/foo" `shouldRespondWith` "[\"wai\",\"foo\"]" { matchStatus = 200 } get "/wai/foo/bar" `shouldRespondWith` "[\"wai\",\"foo\",\"bar\"]" { matchStatus = 200 } it "allows access to post params" $ postHtmlForm "/post-params" [("foo", "bar")] `shouldRespondWith` "[(\"foo\",\"bar\")]" { matchStatus = 200 } it "allows access to empty post params" $ postHtmlForm "/post-params" [] `shouldRespondWith` "[]" { matchStatus = 200 } it "allows broken body for post params" $ post "/post-params" "" `shouldRespondWith` "[]" { matchStatus = 200 } it "allows json body" $ post "/json" "{ \"sampleJson\": \"foo\"}" `shouldRespondWith` "foo" { matchStatus = 200 } it "allows raw body" $ post "/raw-body" "raw" `shouldRespondWith` "raw" { matchStatus = 200 } it "allows empty raw body" $ post "/raw-body" "" `shouldRespondWith` "" { matchStatus = 200 } it "matches regardless of the VERB" $ do get "/all/verbs" `shouldRespondWith` "ok" { matchStatus = 200 } post "/all/verbs" "" `shouldRespondWith` "ok" { matchStatus = 200 } request "FIZZBUZZ" "/all/verbs" [] "" `shouldRespondWith` "ok" { matchStatus = 200 } request "NOTIFY" "/all/verbs" [] "" `shouldRespondWith` "ok" { 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 = #if MIN_VERSION_hspec_wai(0,8,0) MatchHeader $ \headers _ -> #else MatchHeader $ \headers -> #endif 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