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  {-
  31  "good" </> "path" </> capture @Int "i"
  32                    <.> queryParams @Int "param"
  33                    <.> basicAuth @User "realm"
  34                    <.> body @Int @'[PlainText]
  35                    <.> post @Int @'[PlainText]
  36  <!>
  37  "unauthorized" </> basicAuth @UnauthorizedUser "realm"
  38                 <.> post @Int @'[PlainText]
  39  -}
  40  (capture @Int "u" <.> capture @Int "i" <.> get @String @'[PlainText])
  41  <!> (capture @String "u" <.> capture @Char "i" <.> get @String @'[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 $
  63         {-
  64         route_good :!:
  65         route_unauthorized :!:
  66         -}
  67         route_a :!:
  68         route_a'
  69         where
  70         route_good i _params User (ServerBodyArg b) = return (i+b)
  71         route_unauthorized UnauthorizedUser = return 0
  72         route_a u i = return $ show (u,i)
  73         route_a' u i = return $ show (u,i)
  74
  75 warp :: IO ()
  76 warp = Warp.run 8080 srv
  77
  78 mkBody :: Wai.Body -> Wai.MatchBody
  79 mkBody b = Wai.MatchBody $ \_ b' ->
  80         if b == b'
  81         then Nothing
  82         else Just $ TL.unpack $
  83          "expecting: "<>TL.decodeUtf8 b<>
  84          " but got: "<>TL.decodeUtf8 b'<>"\n"
  85
  86 hspec = testSpecs $ describe "Error" $ Wai.with (return srv) $ do
  87         describe "Alt" $ do
  88                 it "does not fail" $ do
  89                         Wai.get "/444/2"
  90                          `Wai.shouldRespondWith` 200 { Wai.matchBody = mkBody $ fromString "(444,\"2\")" }
  91                 it "does not fail" $ do
  92                         Wai.get "/AAA/1"
  93                          `Wai.shouldRespondWith` 200 { Wai.matchBody = mkBody $ fromString "(\"AAA\",2)" }
  94         {-
  95         describe "Path" $ do
  96                 it "checks shorter path" $ do
  97                         Wai.get "/good"
  98                          `Wai.shouldRespondWith` 404
  99                 it "checks longer path" $ do
 100                         Wai.get "/good/path/bad"
 101                          `Wai.shouldRespondWith` 404
 102         describe "BasicAuth" $ do
 103                 it "can decode username and password" $ do
 104                         Wai.request goodMethod goodURI goodHeaders goodBody
 105                          `Wai.shouldRespondWith` 200
 106                 it "checks username" $ do
 107                         Wai.request goodMethod goodURI
 108                          [ (HTTP.hAuthorization, "Basic "<>BS64.encode "no-such-user:pass")
 109                          , goodAccept
 110                          , goodContentType
 111                          ] goodBody
 112                          `Wai.shouldRespondWith` 401
 113                 it "checks password" $ do
 114                         Wai.request goodMethod goodURI
 115                          [ (HTTP.hAuthorization, "Basic "<>BS64.encode "user:wrong-pass")
 116                          , goodAccept
 117                          , goodContentType
 118                          ] goodBody
 119                          `Wai.shouldRespondWith` 401
 120                 it "can deny access" $ do
 121                         Wai.request goodMethod "/unauthorized" goodHeaders goodBody
 122                          `Wai.shouldRespondWith` 403
 123         describe "Priorities" $ do
 124                 it "has 404 as its highest priority error (path)" $ do
 125                         Wai.request badMethod badURI [badAuth, badAccept, badContentType] badBody
 126                         `Wai.shouldRespondWith` 404
 127                 it "has 405 as its second highest priority error (method)" $ do
 128                         Wai.request badMethod badParam [badAuth, badAccept, badContentType] badBody
 129                         `Wai.shouldRespondWith` 405
 130                 it "has 401 as its third highest priority error (auth)" $ do
 131                         Wai.request goodMethod badParam [badAuth, badAccept, badContentType] badBody
 132                         `Wai.shouldRespondWith` 401
 133                 it "has 406 as its fourth highest priority error (accept)" $ do
 134                         Wai.request goodMethod badParam [goodAuth, badAccept, badContentType] badBody
 135                         `Wai.shouldRespondWith` 406
 136                 it "has 415 as its fifth highest priority error (content type)" $ do
 137                         Wai.request goodMethod badParam [goodAuth, goodAccept, badContentType] badBody
 138                         `Wai.shouldRespondWith` 415
 139                 it "has 400 as its sixth highest priority error (query and body)" $ do
 140                         badParamsRes <- Wai.request goodMethod badParam goodHeaders goodBody
 141                         badBodyRes   <- Wai.request goodMethod goodURI  goodHeaders badBody
 142
 143                         -- Both bad body and bad params result in 400
 144                         return badParamsRes `Wai.shouldRespondWith` 400
 145                         return badBodyRes   `Wai.shouldRespondWith` 400
 146
 147                         -- Param check should occur before body checks
 148                         badBothRes <- Wai.request goodMethod badParam
 149                          [goodAuth, goodAccept, goodContentType] badBody
 150                         when (badBothRes /= badParamsRes) $ liftIO $
 151                                 expectationFailure $ "badParam + badBody /= badParam: "
 152                                  <> show badBothRes <> ", " <> show badParamsRes
 153                         when (badBothRes == badBodyRes) $ liftIO $
 154                                 expectationFailure $ "badParam + badBody == badBody: "
 155                                  <> show badBothRes
 156         -}
 157
 158
 159 badContentType  = (HTTP.hContentType, "application/json")
 160 badAccept       = (HTTP.hAccept, "application/json")
 161 badMethod       = HTTP.methodGet
 162 badURI          = "bad"
 163 badBody         = "bad"
 164 badAuth         = (HTTP.hAuthorization, "Basic foofoofoo")
 165 goodContentType = (HTTP.hContentType, "text/plain;charset=utf-8")
 166 goodAccept      = (HTTP.hAccept, "text/plain")
 167 goodMethod      = HTTP.methodPost
 168 goodPath        = "good/path/4"
 169 goodURI         = goodPath<>"?param=2"
 170 badParam        = goodPath<>"?param=foo"
 171 goodBody        = "42" -- {-encode-} (42::Int)
 172 goodAuth        = (HTTP.hAuthorization, "Basic "<>BS64.encode "user:pass")
 173 goodHeaders     = [goodAuth, goodAccept, goodContentType]