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

import           Data.Aeson                     (ToJSON (..))
import qualified Data.Aeson.Encode.Pretty       as P
import qualified Data.ByteString.Lazy           as BSL
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 :: forall (proxy :: * -> *) api.
TMap
  (Every '[Typeable, Show, Arbitrary, ToJSON, ToSchema])
  (BodyTypes JSON api) =>
proxy api -> Spec
validateEveryToJSON proxy api
_ = 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
  (forall {k} (t :: k). Proxy t
Proxy :: Proxy [ToJSON, ToSchema])
  (Maybe String -> Property
maybeCounterExample forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
(ToJSON a, ToSchema a) =>
(a -> [String]) -> a -> Maybe String
prettyValidateWith forall a. (ToJSON a, ToSchema a) => a -> [String]
validateToJSON)
  (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 :: forall (proxy :: * -> *) api.
TMap
  (Every '[Typeable, Show, Arbitrary, ToJSON, ToSchema])
  (BodyTypes JSON api) =>
(Pattern -> Pattern -> Bool) -> proxy api -> Spec
validateEveryToJSONWithPatternChecker Pattern -> Pattern -> Bool
checker proxy api
_ = 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
  (forall {k} (t :: k). Proxy t
Proxy :: Proxy [ToJSON, ToSchema])
  (Maybe String -> Property
maybeCounterExample forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
(ToJSON a, ToSchema a) =>
(a -> [String]) -> a -> Maybe String
prettyValidateWith (forall a.
(ToJSON a, ToSchema a) =>
(Pattern -> Pattern -> Bool) -> a -> [String]
validateToJSONWithPatternChecker Pattern -> Pattern -> Bool
checker))
  (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 :: 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 p cs
_ forall x. EveryTF cs x => x -> Property
f p'' xs
px = forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [Spec]
specs
  where
    specs :: [Spec]
    specs :: [Spec]
specs = 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 (forall {k} (t :: k). Proxy t
Proxy :: Proxy (Typeable ': Show ': Arbitrary ': cs)) 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 :: forall (p' :: * -> *) a.
(EveryTF cs a, Typeable a, Show a, Arbitrary a) =>
p' a -> Spec
aprop p' a
_ = forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop (forall a. Show a => a -> String
show (forall a. Typeable a => a -> TypeRep
typeOf (forall a. HasCallStack => a
undefined :: a))) (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:
-- {
--     "properties": {
--         "name": {
--             "type": "string"
--         },
--         "phone": {
--             "type": "integer"
--         }
--     },
--     "required": [
--         "name",
--         "phone"
--     ],
--     "type": "object"
-- }
-- <BLANKLINE>
--
-- FIXME: this belongs in "Data.OpenApi.Schema.Validation" (in @swagger2@).
prettyValidateWith
  :: forall a. (ToJSON a, ToSchema a)
  => (a -> [ValidationError]) -> a -> Maybe String
prettyValidateWith :: forall a.
(ToJSON a, ToSchema a) =>
(a -> [String]) -> a -> Maybe String
prettyValidateWith a -> [String]
f a
x =
  case a -> [String]
f a
x of
    []      -> forall a. Maybe a
Nothing
    [String]
errors  -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
      [ String
"Validation against the schema fails:"
      , [String] -> String
unlines (forall a b. (a -> b) -> [a] -> [b]
map (String
"  * " forall a. [a] -> [a] -> [a]
++) [String]
errors)
      , String
"JSON value:"
      , Value -> String
ppJSONString Value
json
      , String
""
      , String
"OpenApi Schema:"
      , Value -> String
ppJSONString (forall a. ToJSON a => a -> Value
toJSON Schema
schema)
      ]
  where
    ppJSONString :: Value -> String
ppJSONString = Text -> String
TL.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
TL.decodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> ByteString
encodePretty

    json :: Value
json   = forall a. ToJSON a => a -> Value
toJSON a
x
    schema :: Schema
schema = forall a. ToSchema a => Proxy a -> Schema
toSchema (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  = forall prop. Testable prop => prop -> Property
property Bool
True
maybeCounterExample (Just String
s) = forall prop. Testable prop => String -> prop -> Property
counterexample String
s (forall prop. Testable prop => prop -> Property
property Bool
False)

encodePretty :: ToJSON a => a -> BSL.ByteString
encodePretty :: forall a. ToJSON a => a -> ByteString
encodePretty = forall a. ToJSON a => Config -> a -> ByteString
P.encodePretty' forall a b. (a -> b) -> a -> b
$ Config
P.defConfig { confCompare :: Pattern -> Pattern -> Ordering
P.confCompare = forall a. Ord a => a -> a -> Ordering
P.compare }