servant/servant-server/test/Servant/Server/ErrorSpec.hs

{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE TypeOperators         #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Servant.Server.ErrorSpec (spec) where

import           Data.Aeson                 (encode)
import qualified Data.ByteString.Lazy.Char8 as BC
import           Data.Proxy
import           Network.HTTP.Types         (hAccept, hContentType, methodGet,
                                             methodPost)
import           Test.Hspec
import           Test.Hspec.Wai

import           Servant


-- 1) Check whether one or more endpoints have the right path. Otherwise return 404.
-- 2) Check whether the one of those have the right method. Otherwise return
-- 405. If so, pick the first. We've now commited to calling at most one handler. *
-- 3) Check whether the Content-Type is known. Otherwise return 415.
-- 4) Check whether that one deserializes the body. Otherwise return 400. If there
-- was no Content-Type, try the first one of the API content-type list.
-- 5) Check whether the request is authorized. Otherwise return a 401.
-- 6) Check whether the request is forbidden. If so return 403.
-- 7) Check whether the request has a known Accept. Otherwise return 406.
-- 8) Check whether Accept-Language, Accept-Charset and Accept-Encoding exist and
-- match. We can follow the webmachine order here.
-- 9) Call the handler. Whatever it returns, we return.

spec :: Spec
spec = describe "HTTP Errors" $ do
    errorOrderSpec
    errorRetrySpec
    errorChoiceSpec

------------------------------------------------------------------------------
-- * Error Order {{{

type ErrorOrderApi = "home"
                  :> ReqBody '[JSON] Int
                  :> Capture "t" Int
                  :> Post '[JSON] Int


errorOrderApi :: Proxy ErrorOrderApi
errorOrderApi = Proxy

errorOrderServer :: Server ErrorOrderApi
errorOrderServer = \_ _ -> return 5

errorOrderSpec :: Spec
errorOrderSpec = describe "HTTP error order"
           $ with (return $ serve errorOrderApi errorOrderServer) $ do
  let badContentType  = (hContentType, "text/plain")
      badAccept       = (hAccept, "text/plain")
      badMethod       = methodGet
      badUrl          = "home/nonexistent"
      badBody         = "nonsense"
      goodContentType = (hContentType, "application/json")
      goodMethod      = methodPost
      goodUrl         = "home/2"
      goodBody        = encode (5 :: Int)

  it "has 404 as its highest priority error" $ do
    request badMethod badUrl [badContentType, badAccept] badBody
      `shouldRespondWith` 404

  it "has 405 as its second highest priority error" $ do
    request badMethod goodUrl [badContentType, badAccept] badBody
      `shouldRespondWith` 405

  it "has 415 as its third highest priority error" $ do
    request goodMethod goodUrl [badContentType, badAccept] badBody
      `shouldRespondWith` 415

  it "has 400 as its fourth highest priority error" $ do
    request goodMethod goodUrl [goodContentType, badAccept] badBody
      `shouldRespondWith` 400

  it "has 406 as its fifth highest priority error" $ do
    request goodMethod goodUrl [goodContentType, badAccept] goodBody
      `shouldRespondWith` 406

-- }}}
------------------------------------------------------------------------------
-- * Error Retry {{{

type ErrorRetryApi
     = "a" :> ReqBody '[JSON] Int      :> Post '[JSON] Int                -- 0
  :<|> "a" :> ReqBody '[PlainText] Int :> Post '[JSON] Int                -- 1
  :<|> "a" :> ReqBody '[JSON] Int      :> Post '[PlainText] Int           -- 2
  :<|> "a" :> ReqBody '[JSON] String   :> Post '[JSON] Int                -- 3
  :<|> "a" :> ReqBody '[JSON] Int      :> Get  '[JSON] Int                -- 4
  :<|> "a" :> ReqBody '[JSON] Int      :> Get  '[PlainText] Int           -- 5
  :<|>        ReqBody '[JSON] Int      :> Get  '[JSON] Int                -- 6
  :<|>        ReqBody '[JSON] Int      :> Post '[JSON] Int                -- 7

errorRetryApi :: Proxy ErrorRetryApi
errorRetryApi = Proxy

errorRetryServer :: Server ErrorRetryApi
errorRetryServer
     = (\_ -> return 0)
  :<|> (\_ -> return 1)
  :<|> (\_ -> return 2)
  :<|> (\_ -> return 3)
  :<|> (\_ -> return 4)
  :<|> (\_ -> return 5)
  :<|> (\_ -> return 6)
  :<|> (\_ -> return 7)

errorRetrySpec :: Spec
errorRetrySpec = describe "Handler search"
           $ with (return $ serve errorRetryApi errorRetryServer) $ do

  let plainCT     = (hContentType, "text/plain")
      plainAccept = (hAccept, "text/plain")
      jsonCT      = (hContentType, "application/json")
      jsonAccept  = (hAccept, "application/json")
      jsonBody    = encode (1797 :: Int)

  it "should continue when URLs don't match" $ do
    request methodPost "" [jsonCT, jsonAccept] jsonBody
     `shouldRespondWith` 201 { matchBody = Just $ encode (7 :: Int) }

  it "should continue when methods don't match" $ do
    request methodGet "a" [jsonCT, jsonAccept] jsonBody
     `shouldRespondWith` 200 { matchBody = Just $ encode (4 :: Int) }

  it "should not continue when Content-Types don't match" $ do
    request methodPost "a" [plainCT, jsonAccept] jsonBody
     `shouldRespondWith` 415

  it "should not continue when body can't be deserialized" $ do
    request methodPost "a" [jsonCT, jsonAccept] (encode ("nonsense" :: String))
     `shouldRespondWith` 400

  it "should not continue when Accepts don't match" $ do
    request methodPost "a" [jsonCT, plainAccept] jsonBody
     `shouldRespondWith` 406

-- }}}
------------------------------------------------------------------------------
-- * Error Choice {{{

type ErrorChoiceApi
     = "path0" :> Get '[JSON] Int                                     -- 0
  :<|> "path1" :> Post '[JSON] Int                                    -- 1
  :<|> "path2" :> Post '[PlainText] Int                               -- 2
  :<|> "path3" :> ReqBody '[JSON] Int :> Post '[PlainText] Int        -- 3
  :<|> "path4" :> (ReqBody '[PlainText] Int :> Post '[PlainText] Int  -- 4
             :<|>  ReqBody '[PlainText] Int :> Post '[JSON] Int)      -- 5

errorChoiceApi :: Proxy ErrorChoiceApi
errorChoiceApi = Proxy

errorChoiceServer :: Server ErrorChoiceApi
errorChoiceServer = return 0
               :<|> return 1
               :<|> return 2
               :<|> (\_ -> return 3)
               :<|> (\_ -> return 4)
               :<|> (\_ -> return 5)


errorChoiceSpec :: Spec
errorChoiceSpec = describe "Multiple handlers return errors"
                $ with (return $ serve errorChoiceApi errorChoiceServer) $ do

  it "should respond with 404 if no path matches" $ do
    request methodGet "" [] "" `shouldRespondWith` 404

  it "should respond with 405 if a path but not method matches" $ do
    request methodGet "path2" [] "" `shouldRespondWith` 405

  it "should respond with the corresponding error if path and method match" $ do
    request methodPost "path3" [(hContentType, "text/plain;charset=utf-8")] ""
      `shouldRespondWith` 415
    request methodPost "path3" [(hContentType, "application/json")] ""
      `shouldRespondWith` 400
    request methodPost "path4" [(hContentType, "text/plain;charset=utf-8"),
                                (hAccept, "application/json")] ""
      `shouldRespondWith` 406


-- }}}
------------------------------------------------------------------------------
-- * Instances {{{

instance MimeUnrender PlainText Int where
    mimeUnrender _ = Right . read . BC.unpack

instance MimeRender PlainText Int where
    mimeRender _ = BC.pack . show
-- }}}