test/Hspec/Router/Error.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 {-# LANGUAGE TypeApplications #-}
   3 module Hspec.Router.Error where
   4 import Control.Monad (Monad(..))
   5 import Data.Int (Int)
   6 import Data.Either (Either(..))
   7 import Data.Maybe (Maybe(..))
   8 import Data.Function (($), (.))
   9 import System.IO (IO)
  10 import Text.Show (Show(..))
  11 import Text.Read (readMaybe)
  12 import Test.Hspec
  13 import Test.Hspec.Wai
  14 import Test.Tasty
  15 import Test.Tasty
  16 import Test.Tasty.Hspec
  17 import Data.Semigroup (Semigroup(..))
  18 import qualified Data.ByteString.Lazy as BSL
  19 import qualified Data.Text as Text
  20 import qualified Data.Text.Encoding as Text
  21 import qualified Data.Text.Lazy as TL
  22 import qualified Data.Text.Lazy.Encoding as TL
  23 import qualified Network.HTTP.Types as HTTP
  24 import qualified Network.Wai.Handler.Warp as Warp
  25
  26 import Symantic.HTTP
  27
  28 api = segment "good"
  29   <.> capture @Int "i"
  30   <.> query @Int "param"
  31   <.> endpoint @Int @PlainText HTTP.methodPost
  32 rtr = runRouter api $ route_good
  33         where
  34         route_good i qry (RouterEndpointArg respond) =
  35                 RouterResponse $ \_req res -> do
  36                         res $ respond status200 [] i
  37 srv :: IO ()
  38 srv = Warp.run 8080 rtr
  39 instance MimeSerialize PlainText Int where
  40         mimeSerialize _mt = BSL.fromStrict . Text.encodeUtf8 . Text.pack . show
  41 instance MimeUnserialize PlainText Int where
  42         mimeUnserialize _mt s =
  43                 case readMaybe $ TL.unpack $ TL.decodeUtf8 s of
  44                  Just n -> Right n
  45                  _ -> Left "cannot parse Int"
  46
  47 hspec =
  48         testSpec "Error order" $
  49                 with (return rtr) $ do
  50                         it "has 404 as its highest priority error" $ do
  51                                 request badMethod badURI [badAuth, badContentType, badAccept] badBody
  52                                 `shouldRespondWith` 404
  53                         it "has 405 as its second highest priority error" $ do
  54                                 request badMethod badParam [badAuth, badContentType, badAccept] badBody
  55                                 `shouldRespondWith` 405
  56                         it "has 401 as its third highest priority error (auth)" $ do
  57                                 request goodMethod badParam [badAuth, badContentType, badAccept] badBody
  58                                 `shouldRespondWith` 401
  59                         it "has 406 as its fourth highest priority error" $ do
  60                                 request goodMethod badParam [goodAuth, badContentType, badAccept] badBody
  61                                 `shouldRespondWith` 406
  62
  63
  64 badContentType  = (HTTP.hContentType, "application/json")
  65 badAccept       = (HTTP.hAccept, "text/plain")
  66 badMethod       = HTTP.methodGet
  67 badURI          = "bad"
  68 badBody         = "bad"
  69 badAuth         = (HTTP.hAuthorization, "Basic foofoofoo")
  70 goodContentType = (HTTP.hContentType, "text/plain")
  71 goodAccept      = (HTTP.hAccept, "text/plain")
  72 goodMethod      = HTTP.methodPost
  73 goodPath        = "good/4"
  74 goodURI         = goodPath<>"?param=2"
  75 badParam        = goodPath<>"?param=foo"
  76 goodBody        = {-encode-} (42::Int)
  77 -- username:password = servant:server
  78 goodAuth        = (HTTP.hAuthorization, "Basic c2VydmFudDpzZXJ2ZXI=")
  79
  80
  81 {-
  82 {-# LANGUAGE DataKinds             #-}
  83 {-# LANGUAGE MultiParamTypeClasses #-}
  84 {-# LANGUAGE OverloadedStrings     #-}
  85 {-# LANGUAGE TypeFamilies          #-}
  86 {-# LANGUAGE TypeOperators         #-}
  87 {-# OPTIONS_GHC -fno-warn-orphans #-}
  88 module Servant.Server.ErrorSpec (spec) where
  89
  90 import           Control.Monad
  91                  (when)
  92 import           Data.Aeson
  93                  (encode)
  94 import qualified Data.ByteString.Char8      as BC
  95 import qualified Data.ByteString.Lazy.Char8 as BCL
  96 import           Data.Monoid
  97                  ((<>))
  98 import           Data.Proxy
  99 import           Network.HTTP.Types
 100                  (hAccept, hAuthorization, hContentType, methodGet, methodPost,
 101                  methodPut)
 102 import           Safe
 103                  (readMay)
 104 import           Test.Hspec
 105 import           Test.Hspec.Wai
 106
 107 import           Servant
 108
 109 spec :: Spec
 110 spec = describe "HTTP Errors" $ do
 111     errorOrderSpec
 112     prioErrorsSpec
 113     errorRetrySpec
 114     errorChoiceSpec
 115
 116 -- * Auth machinery (reused throughout)
 117
 118 -- | 'BasicAuthCheck' holds the handler we'll use to verify a username and password.
 119 errorOrderAuthCheck :: BasicAuthCheck ()
 120 errorOrderAuthCheck =
 121   let check (BasicAuthData username password) =
 122         if username == "servant" && password == "server"
 123         then return (Authorized ())
 124         else return Unauthorized
 125   in BasicAuthCheck check
 126
 127 ------------------------------------------------------------------------------
 128 -- * Error Order {{{
 129
 130 type ErrorOrderApi = "home"
 131                   :> BasicAuth "error-realm" ()
 132                   :> ReqBody '[JSON] Int
 133                   :> Capture "t" Int
 134                   :> QueryParam "param" Int
 135                   :> Post '[JSON] Int
 136
 137 errorOrderApi :: Proxy ErrorOrderApi
 138 errorOrderApi = Proxy
 139
 140 errorOrderServer :: Server ErrorOrderApi
 141 errorOrderServer = \_ _ _ _ -> throwError err402
 142
 143 -- On error priorities:
 144 --
 145 -- We originally had
 146 --
 147 -- 404, 405, 401, 415, 400, 406, 402
 148 --
 149 -- but we changed this to
 150 --
 151 -- 404, 405, 401, 406, 415, 400, 402
 152 --
 153 -- for servant-0.7.
 154 --
 155 -- This change is due to the body check being irreversible (to support
 156 -- streaming). Any check done after the body check has to be made fatal,
 157 -- breaking modularity. We've therefore moved the accept check before
 158 -- the body check, to allow it being recoverable and modular, and this
 159 -- goes along with promoting the error priority of 406.
 160 errorOrderSpec :: Spec
 161 errorOrderSpec =
 162   describe "HTTP error order" $
 163     with (return $ serveWithContext errorOrderApi
 164                    (errorOrderAuthCheck :. EmptyContext)
 165                    errorOrderServer
 166          ) $ do
 167   let badContentType  = (hContentType, "text/plain")
 168       badAccept       = (hAccept, "text/plain")
 169       badMethod       = methodGet
 170       badUrl          = "nonexistent"
 171       badBody         = "nonsense"
 172       badAuth         = (hAuthorization, "Basic foofoofoo")
 173       goodContentType = (hContentType, "application/json")
 174       goodAccept      = (hAccept, "application/json")
 175       goodMethod      = methodPost
 176       goodUrl         = "home/2?param=55"
 177       badParams       = goodUrl <> "?param=foo"
 178       goodBody        = encode (5 :: Int)
 179       -- username:password = servant:server
 180       goodAuth        = (hAuthorization, "Basic c2VydmFudDpzZXJ2ZXI=")
 181
 182   it "has 404 as its highest priority error" $ do
 183     request badMethod badUrl [badAuth, badContentType, badAccept] badBody
 184       `shouldRespondWith` 404
 185
 186   it "has 405 as its second highest priority error" $ do
 187     request badMethod badParams [badAuth, badContentType, badAccept] badBody
 188       `shouldRespondWith` 405
 189
 190   it "has 401 as its third highest priority error (auth)" $ do
 191     request goodMethod badParams [badAuth, badContentType, badAccept] badBody
 192       `shouldRespondWith` 401
 193
 194   it "has 406 as its fourth highest priority error" $ do
 195     request goodMethod badParams [goodAuth, badContentType, badAccept] badBody
 196       `shouldRespondWith` 406
 197
 198   it "has 415 as its fifth highest priority error" $ do
 199     request goodMethod badParams [goodAuth, badContentType, goodAccept] badBody
 200       `shouldRespondWith` 415
 201
 202   it "has 400 as its sixth highest priority error" $ do
 203     badParamsRes <- request goodMethod badParams [goodAuth, goodContentType, goodAccept] goodBody
 204     badBodyRes <- request goodMethod goodUrl [goodAuth, goodContentType, goodAccept] badBody
 205
 206     -- Both bad body and bad params result in 400
 207     return badParamsRes `shouldRespondWith` 400
 208     return badBodyRes `shouldRespondWith` 400
 209
 210     -- Param check should occur before body checks
 211     both <- request goodMethod badParams [goodAuth, goodContentType, goodAccept ] badBody
 212     when (both /= badParamsRes) $ liftIO $
 213         expectationFailure $ "badParams + badBody /= badParams: " ++ show both ++ ", " ++ show badParamsRes
 214     when (both == badBodyRes) $ liftIO $
 215         expectationFailure $ "badParams + badBody == badBody: " ++ show both
 216
 217   it "has handler-level errors as last priority" $ do
 218     request goodMethod goodUrl [goodAuth, goodContentType, goodAccept] goodBody
 219       `shouldRespondWith` 402
 220
 221 type PrioErrorsApi = ReqBody '[JSON] Integer :> "foo" :> Get '[JSON] Integer
 222
 223 prioErrorsApi :: Proxy PrioErrorsApi
 224 prioErrorsApi = Proxy
 225
 226 -- Check whether matching continues even if a 'ReqBody' or similar construct
 227 -- is encountered early in a path. We don't want to see a complaint about the
 228 -- request body unless the path actually matches.
 229 prioErrorsSpec :: Spec
 230 prioErrorsSpec = describe "PrioErrors" $ do
 231   let server = return
 232   with (return $ serve prioErrorsApi server) $ do
 233     let check (mdescr, method) path (cdescr, ctype, body) resp =
 234           it fulldescr $
 235             Test.Hspec.Wai.request method path [(hContentType, ctype)] body
 236               `shouldRespondWith` resp
 237           where
 238             fulldescr = "returns " ++ show (matchStatus resp) ++ " on " ++ mdescr
 239                      ++ " " ++ BC.unpack path ++ " (" ++ cdescr ++ ")"
 240
 241         get' = ("GET", methodGet)
 242         put' = ("PUT", methodPut)
 243
 244         txt   = ("text"        , "text/plain;charset=utf8"      , "42"        )
 245         ijson = ("invalid json", "application/json;charset=utf8", "invalid"   )
 246         vjson = ("valid json"  , "application/json;charset=utf8", encode (5 :: Int))
 247
 248     check get' "/"    txt   404
 249     check get' "/bar" txt   404
 250     check get' "/foo" txt   415
 251     check put' "/"    txt   404
 252     check put' "/bar" txt   404
 253     check put' "/foo" txt   405
 254     check get' "/"    ijson 404
 255     check get' "/bar" ijson 404
 256     check get' "/foo" ijson 400
 257     check put' "/"    ijson 404
 258     check put' "/bar" ijson 404
 259     check put' "/foo" ijson 405
 260     check get' "/"    vjson 404
 261     check get' "/bar" vjson 404
 262     check get' "/foo" vjson 200
 263     check put' "/"    vjson 404
 264     check put' "/bar" vjson 404
 265     check put' "/foo" vjson 405
 266
 267 -- }}}
 268 ------------------------------------------------------------------------------
 269 -- * Error Retry {{{
 270
 271 type ErrorRetryApi
 272      = "a" :> ReqBody '[JSON] Int      :> Post '[JSON] Int                -- err402
 273   :<|> "a" :> ReqBody '[PlainText] Int :> Post '[JSON] Int                -- 1
 274   :<|> "a" :> ReqBody '[JSON] Int      :> Post '[PlainText] Int           -- 2
 275   :<|> "a" :> ReqBody '[JSON] String   :> Post '[JSON] Int                -- 3
 276   :<|> "a" :> ReqBody '[JSON] Int      :> Get  '[JSON] Int                -- 4
 277   :<|> "a" :> BasicAuth "bar-realm" ()
 278            :> ReqBody '[JSON] Int      :> Get  '[PlainText] Int           -- 5
 279   :<|> "a" :> ReqBody '[JSON] Int      :> Get  '[PlainText] Int           -- 6
 280
 281   :<|>        ReqBody '[JSON] Int      :> Get  '[JSON] Int                -- 7
 282   :<|>        ReqBody '[JSON] Int      :> Post '[JSON] Int                -- 8
 283
 284 errorRetryApi :: Proxy ErrorRetryApi
 285 errorRetryApi = Proxy
 286
 287 errorRetryServer :: Server ErrorRetryApi
 288 errorRetryServer
 289      = (\_ -> throwError err402)
 290   :<|> (\_ -> return 1)
 291   :<|> (\_ -> return 2)
 292   :<|> (\_ -> return 3)
 293   :<|> (\_ -> return 4)
 294   :<|> (\_ _ -> return 5)
 295   :<|> (\_ -> return 6)
 296   :<|> (\_ -> return 7)
 297   :<|> (\_ -> return 8)
 298
 299 errorRetrySpec :: Spec
 300 errorRetrySpec =
 301   describe "Handler search" $
 302     with (return $ serveWithContext errorRetryApi
 303                          (errorOrderAuthCheck :. EmptyContext)
 304                          errorRetryServer
 305          ) $ do
 306
 307   let jsonCT      = (hContentType, "application/json")
 308       jsonAccept  = (hAccept, "application/json")
 309       jsonBody    = encode (1797 :: Int)
 310
 311   it "should continue when URLs don't match" $ do
 312     request methodPost "" [jsonCT, jsonAccept] jsonBody
 313      `shouldRespondWith` 200 { matchBody = mkBody $ encode (8 :: Int) }
 314
 315   it "should continue when methods don't match" $ do
 316     request methodGet "a" [jsonCT, jsonAccept] jsonBody
 317      `shouldRespondWith` 200 { matchBody = mkBody $ encode (4 :: Int) }
 318   where
 319     mkBody b = MatchBody $ \_ b' ->
 320       if b == b'
 321         then Nothing
 322         else Just "body not correct\n"
 323
 324 -- }}}
 325 ------------------------------------------------------------------------------
 326 -- * Error Choice {{{
 327
 328 type ErrorChoiceApi
 329      = "path0" :> Get '[JSON] Int                                     -- 0
 330   :<|> "path1" :> Post '[JSON] Int                                    -- 1
 331   :<|> "path2" :> Post '[PlainText] Int                               -- 2
 332   :<|> "path3" :> ReqBody '[JSON] Int :> Post '[PlainText] Int        -- 3
 333   :<|> "path4" :> (ReqBody '[PlainText] Int :> Post '[PlainText] Int  -- 4
 334              :<|>  ReqBody '[PlainText] Int :> Post '[JSON] Int)      -- 5
 335   :<|> "path5" :> (ReqBody '[JSON] Int      :> Post '[PlainText] Int  -- 6
 336              :<|>  ReqBody '[PlainText] Int :> Post '[PlainText] Int) -- 7
 337
 338 errorChoiceApi :: Proxy ErrorChoiceApi
 339 errorChoiceApi = Proxy
 340
 341 errorChoiceServer :: Server ErrorChoiceApi
 342 errorChoiceServer = return 0
 343                :<|> return 1
 344                :<|> return 2
 345                :<|> (\_ -> return 3)
 346                :<|> ((\_ -> return 4) :<|> (\_ -> return 5))
 347                :<|> ((\_ -> return 6) :<|> (\_ -> return 7))
 348
 349
 350 errorChoiceSpec :: Spec
 351 errorChoiceSpec = describe "Multiple handlers return errors"
 352                 $ with (return $ serve errorChoiceApi errorChoiceServer) $ do
 353
 354   it "should respond with 404 if no path matches" $ do
 355     request methodGet "" [] "" `shouldRespondWith` 404
 356
 357   it "should respond with 405 if a path but not method matches" $ do
 358     request methodGet "path2" [] "" `shouldRespondWith` 405
 359
 360   it "should respond with the corresponding error if path and method match" $ do
 361     request methodPost "path3" [(hContentType, "text/plain;charset=utf-8")] ""
 362       `shouldRespondWith` 415
 363     request methodPost "path3" [(hContentType, "application/json")] ""
 364       `shouldRespondWith` 400
 365     request methodPost "path4" [(hContentType, "text/plain;charset=utf-8"),
 366                                 (hAccept, "blah")] "5"
 367       `shouldRespondWith` 406
 368   it "should respond with 415 only if none of the subservers supports the request's content type" $ do
 369     request methodPost "path5" [(hContentType, "text/plain;charset=utf-8")] "1"
 370       `shouldRespondWith` 200
 371     request methodPost "path5" [(hContentType, "application/json")] "1"
 372       `shouldRespondWith` 200
 373     request methodPost "path5" [(hContentType, "application/not-supported")] ""
 374       `shouldRespondWith` 415
 375
 376
 377 -- }}}
 378 ------------------------------------------------------------------------------
 379 -- * Instances {{{
 380
 381 instance MimeUnrender PlainText Int where
 382     mimeUnrender _ x = maybe (Left "no parse") Right (readMay $ BCL.unpack x)
 383
 384 instance MimeRender PlainText Int where
 385     mimeRender _ = BCL.pack . show
 386 -- }}}
 387 -}