{-# LANGUAGE ConstraintKinds     #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators       #-}
module Servant.OpenApi.Internal.Test where

import           Data.Aeson                     (ToJSON (..))
import           Data.Aeson.Encode.Pretty       (encodePretty)
import           Data.OpenApi                   (Pattern, ToSchema, toSchema)
import           Data.OpenApi.Schema.Validation
import           Data.Text                      (Text)
import qualified Data.Text.Lazy                 as TL
import qualified Data.Text.Lazy.Encoding        as TL
import           Data.Typeable
import           Test.Hspec
import           Test.Hspec.QuickCheck
import           Test.QuickCheck                (Arbitrary, Property, counterexample, property)

import           Servant.API
import           Servant.OpenApi.Internal.TypeLevel

-- $setup
-- >>> import Control.Applicative
-- >>> import GHC.Generics
-- >>> import Test.QuickCheck
-- >>> :set -XDeriveGeneric
-- >>> :set -XGeneralizedNewtypeDeriving
-- >>> :set -XDataKinds
-- >>> :set -XTypeOperators

-- | Verify that every type used with @'JSON'@ content type in a servant API
-- has compatible @'ToJSON'@ and @'ToSchema'@ instances using @'validateToJSON'@.
--
-- /NOTE:/ @'validateEveryToJSON'@ does not perform string pattern validation.
-- See @'validateEveryToJSONWithPatternChecker'@.
--
-- @'validateEveryToJSON'@ will produce one @'prop'@ specification for every type in the API.
-- Each type only gets one test, even if it occurs multiple times in the API.
--
-- >>> data User = User { name :: String, age :: Maybe Int } deriving (Show, Generic, Typeable)
-- >>> newtype UserId = UserId String deriving (Show, Generic, Typeable, ToJSON, Arbitrary)
-- >>> instance ToJSON User
-- >>> instance ToSchema User
-- >>> instance ToSchema UserId
-- >>> instance Arbitrary User where arbitrary = User <$> arbitrary <*> arbitrary
-- >>> type UserAPI = (Capture "user_id" UserId :> Get '[JSON] User) :<|> (ReqBody '[JSON] User :> Post '[JSON] UserId)
--
-- >>> hspec $ context "ToJSON matches ToSchema" $ validateEveryToJSON (Proxy :: Proxy UserAPI)
-- <BLANKLINE>
-- ToJSON matches ToSchema
--   User
-- ...
--   UserId
-- ...
-- Finished in ... seconds
-- 2 examples, 0 failures
--
-- For the test to compile all body types should have the following instances:
--
--    * @'ToJSON'@ and @'ToSchema'@ are used to perform the validation;
--    * @'Typeable'@ is used to name the test for each type;
--    * @'Show'@ is used to display value for which @'ToJSON'@ does not satisfy @'ToSchema'@.
--    * @'Arbitrary'@ is used to arbitrarily generate values.
--
-- If any of the instances is missing, you'll get a descriptive type error:
--
-- >>> data Contact = Contact { fullname :: String, phone :: Integer } deriving (Show, Generic)
-- >>> instance ToJSON Contact
-- >>> instance ToSchema Contact
-- >>> type ContactAPI = Get '[JSON] Contact
-- >>> hspec $ validateEveryToJSON (Proxy :: Proxy ContactAPI)
-- ...
-- ...No instance for (Arbitrary Contact)
-- ...  arising from a use of ‘validateEveryToJSON’
-- ...
validateEveryToJSON
  :: forall proxy api .
     TMap (Every [Typeable, Show, Arbitrary, ToJSON, ToSchema])
          (BodyTypes JSON api)
  => proxy api   -- ^ Servant API.
  -> Spec
validateEveryToJSON :: proxy api -> Spec
validateEveryToJSON proxy api
_ = Proxy '[ToJSON, ToSchema]
-> (forall x. EveryTF '[ToJSON, ToSchema] x => x -> Property)
-> Proxy (Nub (BodyTypes' JSON api))
-> Spec
forall (p :: [* -> Constraint] -> *) (p'' :: [*] -> *)
       (cs :: [* -> Constraint]) (xs :: [*]).
TMap (Every (Typeable : Show : Arbitrary : cs)) xs =>
p cs -> (forall x. EveryTF cs x => x -> Property) -> p'' xs -> Spec
props
  (Proxy '[ToJSON, ToSchema]
forall k (t :: k). Proxy t
Proxy :: Proxy [ToJSON, ToSchema])
  (Maybe String -> Property
maybeCounterExample (Maybe String -> Property) -> (x -> Maybe String) -> x -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (x -> [String]) -> x -> Maybe String
forall a.
(ToJSON a, ToSchema a) =>
(a -> [String]) -> a -> Maybe String
prettyValidateWith x -> [String]
forall a. (ToJSON a, ToSchema a) => a -> [String]
validateToJSON)
  (Proxy (Nub (BodyTypes' JSON api))
forall k (t :: k). Proxy t
Proxy :: Proxy (BodyTypes JSON api))

-- | Verify that every type used with @'JSON'@ content type in a servant API
-- has compatible @'ToJSON'@ and @'ToSchema'@ instances using @'validateToJSONWithPatternChecker'@.
--
-- For validation without patterns see @'validateEveryToJSON'@.
validateEveryToJSONWithPatternChecker :: forall proxy api. TMap (Every [Typeable, Show, Arbitrary, ToJSON, ToSchema]) (BodyTypes JSON api) =>
  (Pattern -> Text -> Bool)   -- ^ @'Pattern'@ checker.
  -> proxy api                -- ^ Servant API.
  -> Spec
validateEveryToJSONWithPatternChecker :: (Pattern -> Pattern -> Bool) -> proxy api -> Spec
validateEveryToJSONWithPatternChecker Pattern -> Pattern -> Bool
checker proxy api
_ = Proxy '[ToJSON, ToSchema]
-> (forall x. EveryTF '[ToJSON, ToSchema] x => x -> Property)
-> Proxy (Nub (BodyTypes' JSON api))
-> Spec
forall (p :: [* -> Constraint] -> *) (p'' :: [*] -> *)
       (cs :: [* -> Constraint]) (xs :: [*]).
TMap (Every (Typeable : Show : Arbitrary : cs)) xs =>
p cs -> (forall x. EveryTF cs x => x -> Property) -> p'' xs -> Spec
props
  (Proxy '[ToJSON, ToSchema]
forall k (t :: k). Proxy t
Proxy :: Proxy [ToJSON, ToSchema])
  (Maybe String -> Property
maybeCounterExample (Maybe String -> Property) -> (x -> Maybe String) -> x -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (x -> [String]) -> x -> Maybe String
forall a.
(ToJSON a, ToSchema a) =>
(a -> [String]) -> a -> Maybe String
prettyValidateWith ((Pattern -> Pattern -> Bool) -> x -> [String]
forall a.
(ToJSON a, ToSchema a) =>
(Pattern -> Pattern -> Bool) -> a -> [String]
validateToJSONWithPatternChecker Pattern -> Pattern -> Bool
checker))
  (Proxy (Nub (BodyTypes' JSON api))
forall k (t :: k). Proxy t
Proxy :: Proxy (BodyTypes JSON api))

-- * QuickCheck-related stuff

-- | Construct property tests for each type in a list.
-- The name for each property is the name of the corresponding type.
--
-- >>> :{
--  hspec $
--    context "read . show == id" $
--      props
--        (Proxy :: Proxy [Eq, Show, Read])
--        (\x -> read (show x) === x)
--        (Proxy :: Proxy [Bool, Int, String])
-- :}
-- <BLANKLINE>
-- read . show == id
--   Bool
-- ...
--   Int
-- ...
--   [Char]
-- ...
-- Finished in ... seconds
-- 3 examples, 0 failures
props :: forall p p'' cs xs. TMap (Every (Typeable ': Show ': Arbitrary ': cs)) xs =>
  p cs                                          -- ^ A list of constraints.
  -> (forall x. EveryTF cs x => x -> Property)  -- ^ Property predicate.
  -> p'' xs                                     -- ^ A list of types.
  -> Spec
props :: p cs -> (forall x. EveryTF cs x => x -> Property) -> p'' xs -> Spec
props p cs
_ forall x. EveryTF cs x => x -> Property
f p'' xs
px = [Spec] -> Spec
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [Spec]
specs
  where
    specs :: [Spec]
    specs :: [Spec]
specs = Proxy (Typeable : Show : Arbitrary : cs)
-> (forall x (p' :: * -> *).
    Every (Typeable : Show : Arbitrary : cs) x =>
    p' x -> Spec)
-> p'' xs
-> [Spec]
forall a (cs :: [* -> Constraint]) (p :: [* -> Constraint] -> *)
       (p'' :: [*] -> *) (xs :: [*]).
TMap (Every cs) xs =>
p cs
-> (forall x (p' :: * -> *). Every cs x => p' x -> a)
-> p'' xs
-> [a]
tmapEvery (Proxy (Typeable : Show : Arbitrary : cs)
forall k (t :: k). Proxy t
Proxy :: Proxy (Typeable ': Show ': Arbitrary ': cs)) forall x (p' :: * -> *).
Every (Typeable : Show : Arbitrary : cs) x =>
p' x -> Spec
forall (p' :: * -> *) a.
(EveryTF cs a, Typeable a, Show a, Arbitrary a) =>
p' a -> Spec
aprop p'' xs
px

    aprop :: forall p' a. (EveryTF cs a, Typeable a, Show a, Arbitrary a) => p' a -> Spec
    aprop :: p' a -> Spec
aprop p' a
_ = String -> (a -> Property) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop (TypeRep -> String
forall a. Show a => a -> String
show (a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf (a
forall a. HasCallStack => a
undefined :: a))) (a -> Property
forall x. EveryTF cs x => x -> Property
f :: a -> Property)

-- | Pretty print validation errors
-- together with actual JSON and OpenApi Schema
-- (using 'encodePretty').
--
-- >>> import Data.Aeson
-- >>> import Data.Foldable (traverse_)
-- >>> data Person = Person { name :: String, phone :: Integer } deriving (Generic)
-- >>> instance ToJSON Person where toJSON p = object [ "name" .= name p ]
-- >>> instance ToSchema Person
-- >>> let person = Person { name = "John", phone = 123456 }
-- >>> traverse_ putStrLn $ prettyValidateWith validateToJSON person
-- Validation against the schema fails:
--   * property "phone" is required, but not found in "{\"name\":\"John\"}"
-- <BLANKLINE>
-- JSON value:
-- {
--     "name": "John"
-- }
-- <BLANKLINE>
-- OpenApi Schema:
-- {
--     "required": [
--         "name",
--         "phone"
--     ],
--     "type": "object",
--     "properties": {
--         "phone": {
--             "type": "integer"
--         },
--         "name": {
--             "type": "string"
--         }
--     }
-- }
-- <BLANKLINE>
--
-- FIXME: this belongs in "Data.OpenApi.Schema.Validation" (in @swagger2@).
prettyValidateWith
  :: forall a. (ToJSON a, ToSchema a)
  => (a -> [ValidationError]) -> a -> Maybe String
prettyValidateWith :: (a -> [String]) -> a -> Maybe String
prettyValidateWith a -> [String]
f a
x =
  case a -> [String]
f a
x of
    []      -> Maybe String
forall a. Maybe a
Nothing
    [String]
errors  -> String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
      [ String
"Validation against the schema fails:"
      , [String] -> String
unlines ((String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"  * " String -> String -> String
forall a. [a] -> [a] -> [a]
++) [String]
errors)
      , String
"JSON value:"
      , Value -> String
ppJSONString Value
json
      , String
""
      , String
"OpenApi Schema:"
      , Value -> String
ppJSONString (Schema -> Value
forall a. ToJSON a => a -> Value
toJSON Schema
schema)
      ]
  where
    ppJSONString :: Value -> String
ppJSONString = Text -> String
TL.unpack (Text -> String) -> (Value -> Text) -> Value -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
TL.decodeUtf8 (ByteString -> Text) -> (Value -> ByteString) -> Value -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ByteString
forall a. ToJSON a => a -> ByteString
encodePretty

    json :: Value
json   = a -> Value
forall a. ToJSON a => a -> Value
toJSON a
x
    schema :: Schema
schema = Proxy a -> Schema
forall a. ToSchema a => Proxy a -> Schema
toSchema (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)

-- | Provide a counterexample if there is any.
maybeCounterExample :: Maybe String -> Property
maybeCounterExample :: Maybe String -> Property
maybeCounterExample Maybe String
Nothing  = Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
maybeCounterExample (Just String
s) = String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
s (Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False)