]> Git — Sourcephile - haskell/symantic-http.git/blob - test/Hspec/Server/Error.hs
Remove serverState_offset
[haskell/symantic-http.git] / 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]