{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Web.Spock.FrameworkSpecHelper where #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 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 Data.Word import Network.HTTP.Types.Header import Network.HTTP.Types.Method import qualified Network.Wai as Wai import Test.Hspec import Test.Hspec.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 (st, 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 (st, 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 (st, 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 (st, 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