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 ((+), Integer)
   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 qualified Data.Text.Lazy as TL
  18 import qualified Data.Text.Lazy.Encoding as TL
  19 import Data.String (String)
  20 import Data.String (IsString(..))
  21 import Data.Maybe (Maybe(..))
  22 import Data.List (length)
  23 import Data.Char (Char)
  24
  25 import Symantic.HTTP
  26 import Symantic.HTTP.Server
  27 import Hspec.Utils
  28
  29 api =
  30  "good" </> "path" </> capture @Int "i"
  31                    <.> queryParams @Int "param"
  32                    <.> basicAuth @User "realm"
  33                    <.> body @Int @'[PlainText]
  34                    <.> post @Int @'[PlainText]
  35  <!>
  36  "unauthorized" </> basicAuth @UnauthorizedUser "realm"
  37                 <.> post @Int @'[PlainText]
  38
  39 data User = User
  40 instance ServerBasicAuth User where
  41         serverBasicAuth user pass =
  42                 return $
  43                         if user=="user"
  44                         then if pass=="pass"
  45                                 then BasicAuth_Authorized User
  46                                 else BasicAuth_BadPassword
  47                         else BasicAuth_NoSuchUser
  48 data UnauthorizedUser = UnauthorizedUser
  49 instance ServerBasicAuth UnauthorizedUser where
  50         serverBasicAuth user pass =
  51                 return $
  52                         if user=="user"
  53                         then if pass=="pass"
  54                                 then BasicAuth_Unauthorized
  55                                 else BasicAuth_BadPassword
  56                         else BasicAuth_NoSuchUser
  57
  58 srv = server api $
  59         route_good :!:
  60         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 mkBody :: Wai.Body -> Wai.MatchBody
  69 mkBody b = Wai.MatchBody $ \_ b' ->
  70         if b == b'
  71         then Nothing
  72         else Just $ TL.unpack $
  73          "expecting: "<>TL.decodeUtf8 b<>
  74          " but got: "<>TL.decodeUtf8 b'<>"\n"
  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 badContentType  = (HTTP.hContentType, "application/json")
 140 badAccept       = (HTTP.hAccept, "application/json")
 141 badMethod       = HTTP.methodGet
 142 badURI          = "bad"
 143 badBody         = "bad"
 144 badAuth         = (HTTP.hAuthorization, "Basic foofoofoo")
 145 goodContentType = (HTTP.hContentType, "text/plain;charset=utf-8")
 146 goodAccept      = (HTTP.hAccept, "text/plain")
 147 goodMethod      = HTTP.methodPost
 148 goodPath        = "good/path/4"
 149 goodURI         = goodPath<>"?param=2"
 150 badParam        = goodPath<>"?param=foo"
 151 goodBody        = "42" -- {-encode-} (42::Int)
 152 goodAuth        = (HTTP.hAuthorization, "Basic "<>BS64.encode "user:pass")
 153 goodHeaders     = [goodAuth, goodAccept, goodContentType]