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.Bool
   7 import Data.Either (Either(..))
   8 import Data.Eq (Eq(..))
   9 import Data.Function (($), (.))
  10 import Data.Int (Int)
  11 import Data.Maybe (Maybe(..))
  12 import Data.Semigroup (Semigroup(..))
  13 import Data.String (String)
  14 import Prelude ((+))
  15 import System.IO (IO)
  16 import Test.Hspec
  17 import Test.Tasty
  18 import Test.Tasty.Hspec
  19 import Test.Hspec.Wai (liftIO)
  20 import Text.Read (readMaybe)
  21 import Text.Show (Show(..))
  22 import qualified Data.ByteString.Base64 as BS64
  23 import qualified Data.ByteString.Lazy as BSL
  24 import qualified Data.Text as Text
  25 import qualified Data.Text.Encoding as Text
  26 import qualified Data.Text.Lazy as TL
  27 import qualified Data.Text.Lazy.Encoding as TL
  28 import qualified Network.HTTP.Types as HTTP
  29 import qualified Network.Wai.Handler.Warp as Warp
  30 import qualified Test.Hspec.Wai as Wai
  31
  32 import Symantic.HTTP
  33
  34 api = "good" </> "path" </> capture @Int "i"
  35                         <.> queryParams @Int "param"
  36                         <.> basicAuth @User "realm" ("authorized"::String)
  37                         <.> body @Int @PlainText
  38                         <.> post @Int @PlainText
  39     <!> "unauthorized"  </> basicAuth @User "realm" ("unauthorized"::String)
  40                         <.> post @Int @PlainText
  41
  42 data User = User
  43 instance ServerBasicAuthable String User where
  44         serverBasicAuthable context user pass =
  45                 return $
  46                         if user=="user"
  47                         then if pass=="pass"
  48                                 then if context=="authorized"
  49                                         then BasicAuth_Authorized User
  50                                         else BasicAuth_Unauthorized
  51                                 else BasicAuth_BadPassword
  52                         else BasicAuth_NoSuchUser
  53
  54 srv = server api $ route_good :!: route_unauthorized
  55         where
  56         route_good i params User (ServerBodyArg b) (ServerResponseArg respond) =
  57                 ServerResponse $ \_req res -> do
  58                         res $ respond status200 [] (i+b)
  59         route_unauthorized User (ServerResponseArg respond) =
  60                 ServerResponse $ \_req res -> do
  61                         res $ respond status200 [] 0
  62
  63 warp :: IO ()
  64 warp = Warp.run 8080 srv
  65
  66 instance MimeSerialize Int PlainText where
  67         mimeSerialize _mt = BSL.fromStrict . Text.encodeUtf8 . Text.pack . show
  68 instance MimeUnserialize Int PlainText where
  69         mimeUnserialize _mt s =
  70                 case readMaybe $ TL.unpack $ TL.decodeUtf8 s of
  71                  Just n -> Right n
  72                  _ -> Left "cannot parse Int"
  73
  74 hspec = testSpecs $ describe "Error" $ Wai.with (return srv) $ do
  75         describe "Path" $ do
  76                 it "checks shorter path" $ do
  77                         Wai.get "/good"
  78                          `Wai.shouldRespondWith` 404
  79                 it "checks longer path" $ do
  80                         Wai.get "/good/path/bad"
  81                          `Wai.shouldRespondWith` 404
  82         describe "BasicAuth" $ do
  83                 it "can decode username and password" $ do
  84                         Wai.request goodMethod goodURI goodHeaders goodBody
  85                          `Wai.shouldRespondWith` 200
  86                 it "checks username" $ do
  87                         Wai.request goodMethod goodURI
  88                          [ (HTTP.hAuthorization, "Basic "<>BS64.encode "no-such-user:pass")
  89                          , goodAccept
  90                          , goodContentType
  91                          ] goodBody
  92                          `Wai.shouldRespondWith` 401
  93                 it "checks password" $ do
  94                         Wai.request goodMethod goodURI
  95                          [ (HTTP.hAuthorization, "Basic "<>BS64.encode "user:wrong-pass")
  96                          , goodAccept
  97                          , goodContentType
  98                          ] goodBody
  99                          `Wai.shouldRespondWith` 401
 100                 it "can return Unauthorized" $ do
 101                         Wai.request goodMethod "/unauthorized" goodHeaders goodBody
 102                          `Wai.shouldRespondWith` 403
 103         describe "Priorities" $ do
 104                 it "has 404 as its highest priority error (path)" $ do
 105                         Wai.request badMethod badURI [badAuth, badAccept, badContentType] badBody
 106                         `Wai.shouldRespondWith` 404
 107                 it "has 405 as its second highest priority error (method)" $ do
 108                         Wai.request badMethod badParam [badAuth, badAccept, badContentType] badBody
 109                         `Wai.shouldRespondWith` 405
 110                 it "has 401 as its third highest priority error (auth)" $ do
 111                         Wai.request goodMethod badParam [badAuth, badAccept, badContentType] badBody
 112                         `Wai.shouldRespondWith` 401
 113                 it "has 406 as its fourth highest priority error (accept)" $ do
 114                         Wai.request goodMethod badParam [goodAuth, badAccept, badContentType] badBody
 115                         `Wai.shouldRespondWith` 406
 116                 it "has 415 as its fifth highest priority error (content type)" $ do
 117                         Wai.request goodMethod badParam [goodAuth, goodAccept, badContentType] badBody
 118                         `Wai.shouldRespondWith` 415
 119                 it "has 400 as its sixth highest priority error (query and body)" $ do
 120                         badParamsRes <- Wai.request goodMethod badParam goodHeaders goodBody
 121                         badBodyRes   <- Wai.request goodMethod goodURI  goodHeaders badBody
 122
 123                         -- Both bad body and bad params result in 400
 124                         return badParamsRes `Wai.shouldRespondWith` 400
 125                         return badBodyRes   `Wai.shouldRespondWith` 400
 126
 127                         -- Param check should occur before body checks
 128                         badBothRes <- Wai.request goodMethod badParam
 129                          [goodAuth, goodAccept, goodContentType] badBody
 130                         when (badBothRes /= badParamsRes) $ liftIO $
 131                                 expectationFailure $ "badParam + badBody /= badParam: "
 132                                  <> show badBothRes <> ", " <> show badParamsRes
 133                         when (badBothRes == badBodyRes) $ liftIO $
 134                                 expectationFailure $ "badParam + badBody == badBody: "
 135                                  <> show badBothRes
 136
 137
 138 badContentType  = (HTTP.hContentType, "application/json")
 139 badAccept       = (HTTP.hAccept, "application/json")
 140 badMethod       = HTTP.methodGet
 141 badURI          = "bad"
 142 badBody         = "bad"
 143 badAuth         = (HTTP.hAuthorization, "Basic foofoofoo")
 144 goodContentType = (HTTP.hContentType, "text/plain;charset=utf-8")
 145 goodAccept      = (HTTP.hAccept, "text/plain")
 146 goodMethod      = HTTP.methodPost
 147 goodPath        = "good/path/4"
 148 goodURI         = goodPath<>"?param=2"
 149 badParam        = goodPath<>"?param=foo"
 150 goodBody        = "42" -- {-encode-} (42::Int)
 151 goodAuth        = (HTTP.hAuthorization, "Basic "<>BS64.encode "user:pass")
 152 goodHeaders     = [goodAuth, goodAccept, goodContentType]