test/Hspec/Server/Error.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 {-# LANGUAGE TypeApplications #-}
   3 module Hspec.Server.Error where
   4
   5 import Control.Monad (Monad(..), when)
   6 import Data.Either (Either(..))
   7 import Data.Eq (Eq(..))
   8 import Data.Function (($), (.))
   9 import Data.Int (Int)
  10 import Data.Maybe (Maybe(..))
  11 import Data.Semigroup (Semigroup(..))
  12 import Prelude ((+))
  13 import System.IO (IO)
  14 import Test.Hspec
  15 import Test.Tasty
  16 import Test.Tasty
  17 import Test.Tasty.Hspec
  18 import Test.Hspec.Wai (liftIO)
  19 import Text.Read (readMaybe)
  20 import Text.Show (Show(..))
  21 import qualified Data.ByteString.Lazy as BSL
  22 import qualified Data.Text as Text
  23 import qualified Data.Text.Encoding as Text
  24 import qualified Data.Text.Lazy as TL
  25 import qualified Data.Text.Lazy.Encoding as TL
  26 import qualified Network.HTTP.Types as HTTP
  27 import qualified Network.Wai.Handler.Warp as Warp
  28 import qualified Test.Hspec.Wai as Wai
  29
  30 import Symantic.HTTP
  31
  32 api = "good" </> "path"
  33              </> capture @Int "i"
  34              <.> queryParams @Int "param"
  35              <.> body @Int @PlainText
  36              <.> post @Int @PlainText
  37
  38 srv = server api $ route_good
  39         where
  40         route_good i params (ServerBodyArg b) (ServerResponseArg respond) =
  41                 ServerResponse $ \_req res -> do
  42                         res $ respond status200 [] (i+b)
  43
  44 warp :: IO ()
  45 warp = Warp.run 8080 srv
  46
  47 instance MimeSerialize Int PlainText where
  48         mimeSerialize _mt = BSL.fromStrict . Text.encodeUtf8 . Text.pack . show
  49 instance MimeUnserialize Int PlainText where
  50         mimeUnserialize _mt s =
  51                 case readMaybe $ TL.unpack $ TL.decodeUtf8 s of
  52                  Just n -> Right n
  53                  _ -> Left "cannot parse Int"
  54
  55 hspec = testSpecs $ describe "Error" $ Wai.with (return srv) $ do
  56         describe "Path" $ do
  57                 it "checks shorter path" $ do
  58                         Wai.get "/good"
  59                          `Wai.shouldRespondWith` 404
  60                 it "checks longer path" $ do
  61                         Wai.get "/good/path/bad"
  62                          `Wai.shouldRespondWith` 404
  63         describe "Priorities" $ do
  64                 it "has 404 as its highest priority error (path)" $ do
  65                         Wai.request badMethod badURI [badAuth, badAccept, badContentType] badBody
  66                         `Wai.shouldRespondWith` 404
  67                 it "has 405 as its second highest priority error (method)" $ do
  68                         Wai.request badMethod badParam [badAuth, badAccept, badContentType] badBody
  69                         `Wai.shouldRespondWith` 405
  70                 it "has 401 as its third highest priority error (auth)" $ do
  71                         Wai.request goodMethod badParam [badAuth, badAccept, badContentType] badBody
  72                         `Wai.shouldRespondWith` 401
  73                 it "has 406 as its fourth highest priority error (accept)" $ do
  74                         Wai.request goodMethod badParam [goodAuth, badAccept, badContentType] badBody
  75                         `Wai.shouldRespondWith` 406
  76                 it "has 415 as its fifth highest priority error (content type)" $ do
  77                         Wai.request goodMethod badParam [goodAuth, goodAccept, badContentType] badBody
  78                         `Wai.shouldRespondWith` 415
  79                 it "has 400 as its sixth highest priority error (query and body)" $ do
  80                         let goodHeaders = [goodAuth, goodAccept, goodContentType]
  81                         badParamsRes <- Wai.request goodMethod badParam goodHeaders goodBody
  82                         badBodyRes   <- Wai.request goodMethod goodURI  goodHeaders badBody
  83
  84                         -- Both bad body and bad params result in 400
  85                         return badParamsRes `Wai.shouldRespondWith` 400
  86                         return badBodyRes   `Wai.shouldRespondWith` 400
  87
  88                         -- Param check should occur before body checks
  89                         badBothRes <- Wai.request goodMethod badParam
  90                          [goodAuth, goodAccept, goodContentType] badBody
  91                         when (badBothRes /= badParamsRes) $ liftIO $
  92                                 expectationFailure $ "badParam + badBody /= badParam: "
  93                                  <> show badBothRes <> ", " <> show badParamsRes
  94                         when (badBothRes == badBodyRes) $ liftIO $
  95                                 expectationFailure $ "badParam + badBody == badBody: "
  96                                  <> show badBothRes
  97
  98
  99 badContentType  = (HTTP.hContentType, "application/json")
 100 badAccept       = (HTTP.hAccept, "application/json")
 101 badMethod       = HTTP.methodGet
 102 badURI          = "bad"
 103 badBody         = "bad"
 104 badAuth         = (HTTP.hAuthorization, "Basic foofoofoo")
 105 goodContentType = (HTTP.hContentType, "text/plain;charset=utf-8")
 106 goodAccept      = (HTTP.hAccept, "text/plain")
 107 goodMethod      = HTTP.methodPost
 108 goodPath        = "good/path/4"
 109 goodURI         = goodPath<>"?param=2"
 110 badParam        = goodPath<>"?param=foo"
 111 goodBody        = "42" -- {-encode-} (42::Int)
 112 -- username:password = user:pass
 113 goodAuth        = (HTTP.hAuthorization, "Basic XXXXXXXXXXXXXXXXXXX=")