test/Hspec/Server/Error.hs

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