-- |
-- Module:      Main
-- Description: Unit tests for Haskell implementation of RFC7807 style responses
-- Copyright:   (c) 2020 Peter Trško
-- License:     BSD3
--
-- Maintainer:  peter.trsko@gmail.com
-- Stability:   experimental
-- Portability: GHC specific language extensions.
--
-- Unit tests for Haskell implementation of RFC7807 style responses.
module Main
    ( main
    )
  where

import Prelude

import Control.Exception (handle, throwIO)
import Data.Maybe (isJust)
import Data.Proxy (Proxy(Proxy))

import Data.Aeson ((.=))
import qualified Data.Aeson as Aeson
import Data.Text (Text)
import Network.HTTP.Types (hContentType)
import Servant.API as Servant (JSON)
import Servant.Server as Servant
import qualified Test.HUnit.Lang as HUnit
  ( HUnitFailure(HUnitFailure)
  , formatFailureReason
  )
import qualified Test.Hspec.Expectations.Json as Json (shouldBeJson)
--import Test.QuickCheck.Instances ()
import Test.Tasty (TestName, TestTree, defaultMain, testGroup)
import Test.Tasty.HUnit
  ( Assertion
  , HasCallStack
  , assertEqual
  , assertFailure
  , testCase
  , HUnitFailure(..)
  )
--import Test.Tasty.QuickCheck (testProperty)

import Network.HTTP.RFC7807 (Rfc7807Error(..))
import Servant.Server.RFC7807 (ProblemJSON, rfc7807ServerError)


main :: IO ()
main = defaultMain $ testGroup "Tests"
    [ testGroup "Network.HTTP.RFC7807"
        [ testDefaultSerialisation
        ]

    , testGroup "Servant.Server.RFC7807"
        [ testCase "err400, JSON" do
            let actual =
                    rfc7807ServerError @(Rfc7807Error Text () ())
                        (Proxy @Servant.JSON) Servant.err400 "/errors#400" id

            assertEqual "HTTP status code hasn't changed"
                (Servant.errHTTPCode Servant.err400)
                (Servant.errHTTPCode actual)
            assertEqual "HTTP reason phrase hasn't changed"
                (Servant.errReasonPhrase Servant.err400)
                (Servant.errReasonPhrase actual)
            assertEqual "Content-Type is present and is\
                \ application/json;charset=utf-8"
                (Just "application/json;charset=utf-8")
                (hContentType `lookup` Servant.errHeaders actual)

            case Aeson.eitherDecode (Servant.errBody actual) of
                Left err ->
                    assertFailure
                        ( "HTTP response body is valid JSON, but we got:\n"
                        <> err
                        )

                Right actualJson ->
                    actualJson `shouldBeJson` Aeson.object
                    [ "type" .= Aeson.String "/errors#400"
                    , "status" .= Servant.errHTTPCode Servant.err400
                    , "title" .= Servant.errReasonPhrase Servant.err400
                    ]

        , testCase "err500, ProblemJSON" do
            let actual =
                    rfc7807ServerError @(Rfc7807Error Text () ())
                        (Proxy @ProblemJSON) Servant.err500 "/errors#500" id

            assertEqual "HTTP status code hasn't changed"
                (Servant.errHTTPCode Servant.err500)
                (Servant.errHTTPCode actual)
            assertEqual "HTTP reason phrase hasn't changed"
                (Servant.errReasonPhrase Servant.err500)
                (Servant.errReasonPhrase actual)
            assertEqual "Content-Type is present and is\
                \ application/json;charset=utf8"
                (Just "application/problem+json;charset=utf-8")
                (hContentType `lookup` Servant.errHeaders actual)

            case Aeson.eitherDecode (Servant.errBody actual) of
                Left err ->
                    assertFailure
                        ( "HTTP response body is valid JSON, but we got:\n"
                        <> err
                        )

                Right actualJson ->
                    actualJson `shouldBeJson` Aeson.object
                        [ "type" .= Aeson.String "/errors#500"
                        , "status" .= Servant.errHTTPCode Servant.err500
                        , "title" .= Servant.errReasonPhrase Servant.err500
                        ]
        ]
    ]

testDefaultSerialisation :: TestTree
testDefaultSerialisation = testGroup "Default serialisation"
    -- Reason why samples are enough is that the way the serialisation works is
    -- mostly uniform. Testing it deeper just reimplements the logic and
    -- doesn't test anything useful.
    --
    -- Optional data values do not matter either as 'ToJSON' instances are
    -- used, therefore, we cannot guarantee anything beyond it being
    -- serialisable.
    --
    -- While testing that toJSON and toEncoding correspond would be useful to
    -- catch some errors, it won't test 'toKeyValue'.  Polymorphism guarantees
    -- that the representations cannot diverge beyond ordering.
    [ testDefaultSerialisationCase "Minimal sample" Rfc7807Error
        { type_ = "https://example.com/docs/error" :: Text
        , title = Nothing
        , status = Nothing
        , detail = Nothing
        , instance_ = Nothing
        , error_ = Nothing @()
        , context = Nothing @()
        }

    , testDefaultSerialisationCase "Full sample" Rfc7807Error
        { type_ = "https://example.com/docs/error" :: Text
        , title = Just "Not so detailed error"
        , status = Just 500
        , detail = Just "Very detailed error message"
        , instance_ = Just "https://example.com/error/instance/123"
        , error_ = Just $ Aeson.object
            [ "foo" .= Aeson.String "bar"
            ]
        , context = Just $ Aeson.object
            [ "id" .= Aeson.String "1234"
            ]
        }

    -- Missing values were strategically chosen to have one among fields
    -- defined by the standard and one among the extension fields.  As the
    -- logic is uniform we are able to verify both classes at the same time.
    , testDefaultSerialisationCase "Few empty values sample" Rfc7807Error
        { type_ = "https://example.com/docs/error" :: Text
        , title = Just "Not so detailed error"
        , status = Just 500
        , detail = Just "Very detailed error message"
        , instance_ = Nothing  -- Check that field is omitted.
        , error_ = Nothing @() -- Check that field is omitted.
        , context = Just ()
        }
    ]

testDefaultSerialisationCase
    ::  ( Aeson.ToJSON errorType
        , Aeson.ToJSON errorInfo
        , Aeson.ToJSON context
        )
    => TestName
    -> Rfc7807Error errorType errorInfo context
    -> TestTree
testDefaultSerialisationCase name v@Rfc7807Error{..} = testCase name do
    Aeson.toJSON v `shouldBeJson` Aeson.object
        ( mconcat
            [ ["type" .= type_]
            , ["title" .= title | isJust title]
            , ["status" .= status | isJust status]
            , ["detail" .= detail | isJust detail]
            , ["instance" .= instance_ | isJust instance_]
            , ["error" .= error_ | isJust error_]
            , ["context" .= context | isJust context]
            ]
        )

shouldBeJson :: HasCallStack => Aeson.Value -> Aeson.Value -> Assertion
shouldBeJson actual expected = hUnitToTasty (Json.shouldBeJson actual expected)

-- | Converts @HUnit@ exception to @tasty-hunit@ exception so that formatting
-- is preserved.
hUnitToTasty :: Assertion -> Assertion
hUnitToTasty = handle \(HUnit.HUnitFailure src reason) ->
    throwIO $ HUnitFailure src (HUnit.formatFailureReason reason)