@@ -1,15 +1,19 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−{-# LANGUAGE TypeOperators #-}
3−{-# LANGUAGE DataKinds #-}
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE MultiParamTypeClasses #-}
3+{-# LANGUAGE OverloadedStrings #-}
4+{-# LANGUAGE TypeOperators #-}
5+{-# OPTIONS_GHC -fno-warn-orphans #-}
46module Servant.Server.ErrorSpec (spec) where
57
6−import Test.Hspec
7−import Data.Proxy
8−import Test.Hspec.Wai (request, with, shouldRespondWith)
9−import Network.HTTP.Types (methodGet, methodPost)
10−import Data.Aeson (encode)
8+import Data.Aeson (encode)
9+import qualified Data.ByteString.Lazy.Char8 as BC
10+import Control.Monad.Trans.Either (left)
11+import Data.Proxy
12+import Network.HTTP.Types (methodGet, methodPost)
13+import Test.Hspec
14+import Test.Hspec.Wai
1115
12−import Servant
16+import Servant
1317
1418
1519-- 1) Check whether one or more endpoints have the right path. Otherwise return 404.
@@ -26,9 +30,12 @@ import Servant
2630-- 9) Call the handler. Whatever it returns, we return.
2731
2832spec :: Spec
29−spec = do
33+spec = describe "HTTP Errors" $ do
3034 errorOrder
35+ errorRetry
3136
37+------------------------------------------------------------------------------
38+-- * Error Order {{{
3239
3340type ErrorOrderApi = "home"
3441 :> ReqBody '[JSON] Int
@@ -39,40 +46,108 @@ errorOrderApi :: Proxy ErrorOrderApi
3946errorOrderApi = Proxy
4047
4148errorOrderServer :: Server ErrorOrderApi
42−errorOrderServer = \_ _ -> return 10
49+errorOrderServer = \_ _ -> left err402
4350
4451errorOrder :: Spec
4552errorOrder = describe "HTTP error order"
4653 $ with (return $ serve errorOrderApi errorOrderServer) $ do
47− let badContentType = ("Content-Type", "text/plain")
48− badAccept = ("Accept", "text/plain")
49− badMethod = methodGet
50− badUrl = "home/nonexistent"
51− badBody = "nonsense"
52− goodContentType = ("Content-Type", "application/json")
53− goodAccept = ("Accept", "application/json")
54− goodMethod = methodPost
55− goodUrl = "home/5"
56− goodBody = encode (5 :: Int)
57−
58− it "has 404 as its highest priority error" $ do
59− request badMethod badUrl [badContentType, badAccept] badBody
60− `shouldRespondWith` 404
61−
62− it "has 405 as its second highest priority error" $ do
63− request badMethod goodUrl [badContentType, badAccept] badBody
64− `shouldRespondWith` 405
65−
66− it "has 415 as its third highest priority error" $ do
67− request goodMethod goodUrl [badContentType, badAccept] badBody
68− `shouldRespondWith` 415
69−
70− it "has 400 as its fourth highest priority error" $ do
71− request goodMethod goodUrl [goodContentType, badAccept] badBody
72− `shouldRespondWith` 400
73−
74− it "has 406 as its fifth highest priority error" $ do
75− request goodMethod goodUrl [goodContentType, badAccept] goodBody
76− `shouldRespondWith` 406
77−
78−
54+ let badContentType = ("Content-Type", "text/plain")
55+ badAccept = ("Accept", "text/plain")
56+ badMethod = methodGet
57+ badUrl = "home/nonexistent"
58+ badBody = "nonsense"
59+ goodContentType = ("Content-Type", "application/json")
60+ goodAccept = ("Accept", "application/json")
61+ goodMethod = methodPost
62+ goodUrl = "home/5"
63+ goodBody = encode (5 :: Int)
64+
65+ it "has 404 as its highest priority error" $ do
66+ request badMethod badUrl [badContentType, badAccept] badBody
67+ `shouldRespondWith` 404
68+
69+ it "has 405 as its second highest priority error" $ do
70+ request badMethod goodUrl [badContentType, badAccept] badBody
71+ `shouldRespondWith` 405
72+
73+ it "has 415 as its third highest priority error" $ do
74+ request goodMethod goodUrl [badContentType, badAccept] badBody
75+ `shouldRespondWith` 415
76+
77+ it "has 400 as its fourth highest priority error" $ do
78+ request goodMethod goodUrl [goodContentType, badAccept] badBody
79+ `shouldRespondWith` 400
80+
81+ it "has 406 as its fifth highest priority error" $ do
82+ request goodMethod goodUrl [goodContentType, badAccept] goodBody
83+ `shouldRespondWith` 406
84+
85+ it "returns handler errors as its lower priority errors" $ do
86+ request goodMethod goodUrl [goodContentType, goodAccept] goodBody
87+ `shouldRespondWith` 402
88+
89+-- }}}
90+------------------------------------------------------------------------------
91+-- * Error Retry {{{
92+
93+type ErrorRetryApi
94+ = "a" :> ReqBody '[JSON] Int :> Post '[JSON] Int -- 0
95+ :<|> "a" :> ReqBody '[PlainText] Int :> Post '[JSON] Int -- 1
96+ :<|> "a" :> ReqBody '[JSON] Int :> Post '[PlainText] Int -- 2
97+ :<|> "a" :> ReqBody '[JSON] String :> Post '[JSON] Int -- 3
98+ :<|> "a" :> ReqBody '[JSON] Int :> Get '[PlainText] Int -- 4
99+ :<|> ReqBody '[JSON] Int :> Get '[JSON] Int -- 5
100+ :<|> ReqBody '[JSON] Int :> Get '[JSON] Int -- 6
101+
102+errorRetryApi :: Proxy ErrorRetryApi
103+errorRetryApi = Proxy
104+
105+errorRetryServer :: Server ErrorRetryApi
106+errorRetryServer
107+ = (\_ -> return 0)
108+ :<|> (\_ -> return 1)
109+ :<|> (\_ -> return 2)
110+ :<|> (\_ -> return 3)
111+ :<|> (\_ -> return 4)
112+ :<|> (\_ -> return 5)
113+ :<|> (\_ -> return 6)
114+
115+errorRetry :: Spec
116+errorRetry = describe "Handler search"
117+ $ with (return $ serve errorRetryApi errorRetryServer) $ do
118+ let plainCT = ("Content-Type", "text/plain")
119+ plainAccept = ("Accept", "text/plain")
120+ jsonCT = ("Content-Type", "application/json")
121+ jsonAccept = ("Accept", "application/json")
122+ jsonBody = encode (1797 :: Int)
123+
124+ it "should continue when URLs don't match" $ do
125+ request methodPost "" [jsonCT, jsonAccept] jsonBody
126+ `shouldRespondWith` 201 { matchBody = Just $ encode (5 :: Int) }
127+
128+ it "should continue when methods don't match" $ do
129+ request methodGet "a" [jsonCT, jsonAccept] jsonBody
130+ `shouldRespondWith` 200 { matchBody = Just $ encode (4 :: Int) }
131+
132+ it "should not continue when Content-Types don't match" $ do
133+ request methodPost "a" [plainCT, jsonAccept] jsonBody
134+ `shouldRespondWith` 415
135+
136+ it "should not continue when body can't be deserialized" $ do
137+ request methodPost "a" [jsonCT, jsonAccept] (encode ("nonsense" :: String))
138+ `shouldRespondWith` 400
139+
140+ it "should not continue when Accepts don't match" $ do
141+ request methodPost "a" [jsonCT, plainAccept] jsonBody
142+ `shouldRespondWith` 406
143+
144+-- }}}
145+------------------------------------------------------------------------------
146+-- * Instances {{{
147+
148+instance MimeUnrender PlainText Int where
149+ mimeUnrender _ = Right . read . BC.unpack
150+
151+instance MimeRender PlainText Int where
152+ mimeRender _ = BC.pack . show
153+-- }}}