test/Hspec/Server/Error.hs

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