test/Hspec/Router/Error.hs

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