{-# LANGUAGE DataKinds #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Servant.Server.ErrorSpec (spec) where

import Control.Monad (when)
import Data.Aeson (encode)
import qualified Data.ByteString.Char8 as BC
import qualified Data.ByteString.Lazy.Char8 as BSL8
import Data.Proxy
import Network.HTTP.Types
  ( hAccept
  , hAuthorization
  , hContentType
  , methodGet
  , methodPost
  , methodPut
  )
import Safe (readMay)
import Test.Hspec
import Test.Hspec.Wai

import Servant

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

-- * Auth machinery (reused throughout)

-- | 'BasicAuthCheck' holds the handler we'll use to verify a username and password.
errorOrderAuthCheck :: BasicAuthCheck ()
errorOrderAuthCheck =
  let check (BasicAuthData username password) =
        if username == "servant" && password == "server"
          then pure (Authorized ())
          else pure Unauthorized
   in BasicAuthCheck check

------------------------------------------------------------------------------

-- * Error Order {{{

type ErrorOrderApi =
  "home"
    :> BasicAuth "error-realm" ()
    :> ReqBody '[JSON] Int
    :> Capture "t" Int
    :> QueryParam "param" Int
    :> Post '[JSON] Int

errorOrderApi :: Proxy ErrorOrderApi
errorOrderApi = Proxy

errorOrderServer :: Server ErrorOrderApi
errorOrderServer _ _ _ _ = throwError err402

-- On error priorities:
--
-- We originally had
--
-- 404, 405, 401, 415, 400, 406, 402
--
-- but we changed this to
--
-- 404, 405, 401, 406, 415, 400, 402
--
-- for servant-0.7.
--
-- This change is due to the body check being irreversible (to support
-- streaming). Any check done after the body check has to be made fatal,
-- breaking modularity. We've therefore moved the accept check before
-- the body check, to allow it being recoverable and modular, and this
-- goes along with promoting the error priority of 406.
errorOrderSpec :: Spec
errorOrderSpec =
  describe "HTTP error order"
    $ with
      ( pure $
          serveWithContext
            errorOrderApi
            (errorOrderAuthCheck :. EmptyContext)
            errorOrderServer
      )
    $ do
      let badContentType = (hContentType, "text/plain")
          badAccept = (hAccept, "text/plain")
          badMethod = methodGet
          badUrl = "nonexistent"
          badBody = "nonsense"
          badAuth = (hAuthorization, "Basic foofoofoo")
          goodContentType = (hContentType, "application/json")
          goodAccept = (hAccept, "application/json")
          goodMethod = methodPost
          goodUrl = "home/2?param=55"
          badParams = goodUrl <> "?param=foo"
          goodBody = encode (5 :: Int)
          -- username:password = servant:server
          goodAuth = (hAuthorization, "Basic c2VydmFudDpzZXJ2ZXI=")

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

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

      it "has 401 as its third highest priority error (auth)" $ do
        request goodMethod badParams [badAuth, badContentType, badAccept] badBody
          `shouldRespondWith` 401

      it "has 406 as its fourth highest priority error" $ do
        request goodMethod badParams [goodAuth, badContentType, badAccept] badBody
          `shouldRespondWith` 406

      it "has 415 as its fifth highest priority error" $ do
        request goodMethod badParams [goodAuth, badContentType, goodAccept] badBody
          `shouldRespondWith` 415

      it "has 400 as its sixth highest priority error" $ do
        badParamsRes <- request goodMethod badParams [goodAuth, goodContentType, goodAccept] goodBody
        badBodyRes <- request goodMethod goodUrl [goodAuth, goodContentType, goodAccept] badBody

        -- Both bad body and bad params result in 400
        pure badParamsRes `shouldRespondWith` 400
        pure badBodyRes `shouldRespondWith` 400

        -- Param check should occur before body checks
        both <- request goodMethod badParams [goodAuth, goodContentType, goodAccept] badBody
        when (both /= badParamsRes) $
          liftIO $
            expectationFailure $
              "badParams + badBody /= badParams: " ++ show both ++ ", " ++ show badParamsRes
        when (both == badBodyRes) $
          liftIO $
            expectationFailure $
              "badParams + badBody == badBody: " ++ show both

      it "has handler-level errors as last priority" $ do
        request goodMethod goodUrl [goodAuth, goodContentType, goodAccept] goodBody
          `shouldRespondWith` 402

type PrioErrorsApi = ReqBody '[JSON] Integer :> "foo" :> Get '[JSON] Integer

prioErrorsApi :: Proxy PrioErrorsApi
prioErrorsApi = Proxy

-- Check whether matching continues even if a 'ReqBody' or similar construct
-- is encountered early in a path. We don't want to see a complaint about the
-- request body unless the path actually matches.
prioErrorsSpec :: Spec
prioErrorsSpec = describe "PrioErrors" $ do
  let server = pure
  with (pure $ serve prioErrorsApi server) $ do
    let check (mdescr, method) path (cdescr, ctype, body) resp =
          it fulldescr $
            Test.Hspec.Wai.request method path [(hContentType, ctype)] body
              `shouldRespondWith` resp
          where
            fulldescr =
              "returns "
                ++ show (matchStatus resp)
                ++ " on "
                ++ mdescr
                ++ " "
                ++ BC.unpack path
                ++ " ("
                ++ cdescr
                ++ ")"

        get' = ("GET", methodGet)
        put' = ("PUT", methodPut)

        txt = ("text", "text/plain;charset=utf8", "42")
        ijson = ("invalid json", "application/json;charset=utf8", "invalid")
        vjson = ("valid json", "application/json;charset=utf8", encode (5 :: Int))

    check get' "/" txt 404
    check get' "/bar" txt 404
    check get' "/foo" txt 415
    check put' "/" txt 404
    check put' "/bar" txt 404
    check put' "/foo" txt 405
    check get' "/" ijson 404
    check get' "/bar" ijson 404
    check get' "/foo" ijson 400
    check put' "/" ijson 404
    check put' "/bar" ijson 404
    check put' "/foo" ijson 405
    check get' "/" vjson 404
    check get' "/bar" vjson 404
    check get' "/foo" vjson 200
    check put' "/" vjson 404
    check put' "/bar" vjson 404
    check put' "/foo" vjson 405

-- }}}
------------------------------------------------------------------------------

-- * Error Retry {{{

type ErrorRetryApi =
  "a" :> ReqBody '[JSON] Int :> Post '[JSON] Int -- err402
    :<|> "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"
      :> BasicAuth "bar-realm" ()
      :> ReqBody '[JSON] Int
      :> Get '[PlainText] Int -- 5
    :<|> "a" :> ReqBody '[JSON] Int :> Get '[PlainText] Int -- 6
    :<|> ReqBody '[JSON] Int :> Get '[JSON] Int -- 7
    :<|> ReqBody '[JSON] Int :> Post '[JSON] Int -- 8

errorRetryApi :: Proxy ErrorRetryApi
errorRetryApi = Proxy

errorRetryServer :: Server ErrorRetryApi
errorRetryServer =
  (\_ -> throwError err402)
    :<|> (\_ -> pure 1)
    :<|> (\_ -> pure 2)
    :<|> (\_ -> pure 3)
    :<|> (\_ -> pure 4)
    :<|> (\_ _ -> pure 5)
    :<|> (\_ -> pure 6)
    :<|> (\_ -> pure 7)
    :<|> (\_ -> pure 8)

errorRetrySpec :: Spec
errorRetrySpec =
  describe "Handler search"
    $ with
      ( pure $
          serveWithContext
            errorRetryApi
            (errorOrderAuthCheck :. EmptyContext)
            errorRetryServer
      )
    $ do
      let 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` 200{matchBody = mkBody $ encode (8 :: Int)}

      it "should continue when methods don't match" $ do
        request methodGet "a" [jsonCT, jsonAccept] jsonBody
          `shouldRespondWith` 200{matchBody = mkBody $ encode (4 :: Int)}
  where
    mkBody b = MatchBody $ \_ b' ->
      if b == b'
        then Nothing
        else Just "body not correct\n"

-- }}}
------------------------------------------------------------------------------

-- * 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
         )
    :<|> "path5"
      :> ( ReqBody '[JSON] Int :> Post '[PlainText] Int -- 6
             :<|> ReqBody '[PlainText] Int :> Post '[PlainText] Int -- 7
         )

errorChoiceApi :: Proxy ErrorChoiceApi
errorChoiceApi = Proxy

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

errorChoiceSpec :: Spec
errorChoiceSpec = describe "Multiple handlers return errors" $
  with (pure $ 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, "blah")
        ]
        "5"
        `shouldRespondWith` 406
    it "should respond with 415 only if none of the subservers supports the request's content type" $ do
      request methodPost "path5" [(hContentType, "text/plain;charset=utf-8")] "1"
        `shouldRespondWith` 200
      request methodPost "path5" [(hContentType, "application/json")] "1"
        `shouldRespondWith` 200
      request methodPost "path5" [(hContentType, "application/not-supported")] ""
        `shouldRespondWith` 415

-- }}}
------------------------------------------------------------------------------

-- * Custom errors {{{

customFormatter :: ErrorFormatter
customFormatter _ _ err = err400{errBody = "CUSTOM! " <> BSL8.pack err}

customFormatters :: ErrorFormatters
customFormatters =
  defaultErrorFormatters
    { bodyParserErrorFormatter = customFormatter
    , urlParseErrorFormatter = customFormatter
    , notFoundErrorFormatter = const $ err404{errBody = "CUSTOM! Not Found"}
    }

type CustomFormatterAPI =
  "query" :> QueryParam' '[Required, Strict] "param" Int :> Get '[PlainText] String
    :<|> "capture" :> Capture "cap" Bool :> Get '[PlainText] String
    :<|> "body" :> ReqBody '[JSON] Int :> Post '[PlainText] String

customFormatterAPI :: Proxy CustomFormatterAPI
customFormatterAPI = Proxy

customFormatterServer :: Server CustomFormatterAPI
customFormatterServer =
  (\_ -> pure "query")
    :<|> (\_ -> pure "capture")
    :<|> (\_ -> pure "body")

customFormattersSpec :: Spec
customFormattersSpec = describe "Custom errors from combinators" $
  with (pure $ serveWithContext customFormatterAPI (customFormatters :. EmptyContext) customFormatterServer) $ do
    let startsWithCustom =
          ResponseMatcher
            { matchStatus = 400
            , matchHeaders = []
            , matchBody = MatchBody $ \_ body ->
                if "CUSTOM!" `BSL8.isPrefixOf` body
                  then Nothing
                  else Just $ show body <> " does not start with \"CUSTOM!\""
            }

    it "formats query parse error" $ do
      request methodGet "query?param=false" [] ""
        `shouldRespondWith` startsWithCustom

    it "formats query parse error with missing param" $ do
      request methodGet "query" [] ""
        `shouldRespondWith` startsWithCustom

    it "formats capture parse error" $ do
      request methodGet "capture/42" [] ""
        `shouldRespondWith` startsWithCustom

    it "formats body parse error" $ do
      request methodPost "body" [(hContentType, "application/json")] "foo"
        `shouldRespondWith` startsWithCustom

-- }}}
------------------------------------------------------------------------------

-- * Instances {{{

instance MimeUnrender PlainText Int where
  mimeUnrender _ x = maybe (Left "no parse") Right (readMay $ BSL8.unpack x)

instance MimeRender PlainText Int where
  mimeRender _ = BSL8.pack . show

-- }}}
