symantic-http-test/Hspec/Server/Error.hs

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