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