content: {-# LANGUAGE CPP                 #-}
  {-# LANGUAGE DeriveGeneric       #-}
  {-# LANGUAGE PackageImports      #-}
  {-# LANGUAGE RecordWildCards     #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  {-# LANGUAGE FlexibleInstances   #-}
  {-# OPTIONS_GHC -fno-warn-orphans #-}
  module Data.Swagger.Schema.ValidationSpec where
  
  import           Control.Applicative
  import           Control.Lens                        ((&), (.~), (?~))
  import           Data.Aeson
  import           Data.Aeson.Types
  import           Data.Aeson.Key
  import qualified Data.Aeson.KeyMap                   as KM
  import           Data.Hashable                       (Hashable)
  import           Data.HashMap.Strict                 (HashMap)
  import qualified Data.HashMap.Strict                 as HashMap
  import           "unordered-containers" Data.HashSet (HashSet)
  import qualified "unordered-containers" Data.HashSet as HashSet
  import           Data.Int
  import           Data.IntMap                         (IntMap)
  import           Data.List.NonEmpty.Compat           (NonEmpty (..), nonEmpty)
  import           Data.Map                            (Map, fromList)
  import           Data.Monoid                         (mempty)
  import           Data.Proxy
  import           Data.Set                            (Set)
  import qualified Data.Text                           as T
  import qualified Data.Text.Lazy                      as TL
  import           Data.Time
  import           Data.Version                        (Version)
  import           Data.Word
  import           GHC.Generics
  
  import           Data.Swagger
  import           Data.Swagger.Declare
  
  import           Test.Hspec
  import           Test.Hspec.QuickCheck
  import           Test.QuickCheck
  import           Test.QuickCheck.Instances           ()
  
  shouldValidate :: (ToJSON a, ToSchema a) => Proxy a -> a -> Bool
  shouldValidate _ x = validateToJSON x == []
  
  shouldNotValidate :: forall a. ToSchema a => (a -> Value) -> a -> Bool
  shouldNotValidate f = not . null . validateJSON defs sch . f
    where
      (defs, sch) = runDeclare (declareSchema (Proxy :: Proxy a)) mempty
  
  spec :: Spec
  spec = do
    describe "Validation" $ do
      prop "Bool" $ shouldValidate (Proxy :: Proxy Bool)
      prop "Char" $ shouldValidate (Proxy :: Proxy Char)
      prop "Double" $ shouldValidate (Proxy :: Proxy Double)
      prop "Float" $ shouldValidate (Proxy :: Proxy Float)
      prop "Int" $ shouldValidate (Proxy :: Proxy Int)
      prop "Int8" $ shouldValidate (Proxy :: Proxy Int8)
      prop "Int16" $ shouldValidate (Proxy :: Proxy Int16)
      prop "Int32" $ shouldValidate (Proxy :: Proxy Int32)
      prop "Int64" $ shouldValidate (Proxy :: Proxy Int64)
      prop "Integer" $ shouldValidate (Proxy :: Proxy Integer)
      prop "Word" $ shouldValidate (Proxy :: Proxy Word)
      prop "Word8" $ shouldValidate (Proxy :: Proxy Word8)
      prop "Word16" $ shouldValidate (Proxy :: Proxy Word16)
      prop "Word32" $ shouldValidate (Proxy :: Proxy Word32)
      prop "Word64" $ shouldValidate (Proxy :: Proxy Word64)
      prop "String" $ shouldValidate (Proxy :: Proxy String)
      prop "()" $ shouldValidate (Proxy :: Proxy ())
      prop "ZonedTime" $ shouldValidate (Proxy :: Proxy ZonedTime)
      prop "UTCTime" $ shouldValidate (Proxy :: Proxy UTCTime)
      prop "T.Text" $ shouldValidate (Proxy :: Proxy T.Text)
      prop "TL.Text" $ shouldValidate (Proxy :: Proxy TL.Text)
      prop "[String]" $ shouldValidate (Proxy :: Proxy [String])
      -- prop "(Maybe [Int])" $ shouldValidate (Proxy :: Proxy (Maybe [Int]))
      prop "(IntMap String)" $ shouldValidate (Proxy :: Proxy (IntMap String))
      prop "(Set Bool)" $ shouldValidate (Proxy :: Proxy (Set Bool))
      prop "(NonEmpty Bool)" $ shouldValidate (Proxy :: Proxy (NonEmpty Bool))
      prop "(HashSet Bool)" $ shouldValidate (Proxy :: Proxy (HashSet Bool))
      prop "(Either Int String)" $ shouldValidate (Proxy :: Proxy (Either Int String))
      prop "(Int, String)" $ shouldValidate (Proxy :: Proxy (Int, String))
      prop "(Map String Int)" $ shouldValidate (Proxy :: Proxy (Map String Int))
      prop "(Map T.Text Int)" $ shouldValidate (Proxy :: Proxy (Map T.Text Int))
      prop "(Map TL.Text Bool)" $ shouldValidate (Proxy :: Proxy (Map TL.Text Bool))
      prop "(HashMap String Int)" $ shouldValidate (Proxy :: Proxy (HashMap String Int))
      prop "(HashMap T.Text Int)" $ shouldValidate (Proxy :: Proxy (HashMap T.Text Int))
      prop "(HashMap TL.Text Bool)" $ shouldValidate (Proxy :: Proxy (HashMap TL.Text Bool))
      prop "Object" $ shouldValidate (Proxy :: Proxy Object)
      prop "(Int, String, Double)" $ shouldValidate (Proxy :: Proxy (Int, String, Double))
      prop "(Int, String, Double, [Int])" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int]))
      prop "(Int, String, Double, [Int], Int)" $ shouldValidate (Proxy :: Proxy (Int, String, Double, [Int], Int))
      prop "Person" $ shouldValidate (Proxy :: Proxy Person)
      prop "Color" $ shouldValidate (Proxy :: Proxy Color)
      prop "Paint" $ shouldValidate (Proxy :: Proxy Paint)
      prop "MyRoseTree" $ shouldValidate (Proxy :: Proxy MyRoseTree)
      prop "Light" $ shouldValidate (Proxy :: Proxy Light)
      prop "ButtonImages" $ shouldValidate (Proxy :: Proxy ButtonImages)
      prop "Version" $ shouldValidate (Proxy :: Proxy Version)
      prop "FreeForm" $ shouldValidate (Proxy :: Proxy FreeForm)
  
    describe "invalid cases" $ do
      prop "invalidPersonToJSON"        $ shouldNotValidate invalidPersonToJSON
      prop "invalidColorToJSON"         $ shouldNotValidate invalidColorToJSON
      prop "invalidPaintToJSON"         $ shouldNotValidate invalidPaintToJSON
      prop "invalidLightToJSON"         $ shouldNotValidate invalidLightToJSON
      prop "invalidButtonImagesToJSON"  $ shouldNotValidate invalidButtonImagesToJSON
  
  main :: IO ()
  main = hspec spec
  
  -- ========================================================================
  -- Person (simple record with optional fields)
  -- ========================================================================
  data Person = Person
    { name  :: String
    , phone :: Integer
    , email :: Maybe String
    } deriving (Show, Generic)
  
  instance ToJSON Person
  instance ToSchema Person
  
  instance Arbitrary Person where
    arbitrary = Person <$> arbitrary <*> arbitrary <*> arbitrary
  
  invalidPersonToJSON :: Person -> Value
  invalidPersonToJSON Person{..} = object
    [ fromString "personName"  .= toJSON name
    , fromString "personPhone" .= toJSON phone
    , fromString "personEmail" .= toJSON email
    ]
  
  -- ========================================================================
  -- Color (enum)
  -- ========================================================================
  data Color = Red | Green | Blue deriving (Show, Generic, Bounded, Enum)
  
  instance ToJSON Color
  instance ToSchema Color
  
  instance Arbitrary Color where
    arbitrary = arbitraryBoundedEnum
  
  invalidColorToJSON :: Color -> Value
  invalidColorToJSON Red   = toJSON "red"
  invalidColorToJSON Green = toJSON "green"
  invalidColorToJSON Blue  = toJSON "blue"
  
  -- ========================================================================
  -- Paint (record with bounded enum property)
  -- ========================================================================
  
  newtype Paint = Paint { color :: Color }
    deriving (Show, Generic)
  
  instance ToJSON Paint
  instance ToSchema Paint
  
  instance Arbitrary Paint where
    arbitrary = Paint <$> arbitrary
  
  invalidPaintToJSON :: Paint -> Value
  invalidPaintToJSON = toJSON . color
  
  -- ========================================================================
  -- MyRoseTree (custom datatypeNameModifier)
  -- ========================================================================
  
  data MyRoseTree = MyRoseTree
    { root  :: String
    , trees :: [MyRoseTree]
    } deriving (Show, Generic)
  
  instance ToJSON MyRoseTree
  
  instance ToSchema MyRoseTree where
    declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
      { datatypeNameModifier = drop (length "My") }
  
  instance Arbitrary MyRoseTree where
    arbitrary = fmap (cut limit) $ MyRoseTree <$> arbitrary <*> (take limit <$> arbitrary)
      where
        limit = 4
        cut 0 (MyRoseTree x _ ) = MyRoseTree x []
        cut n (MyRoseTree x xs) = MyRoseTree x (map (cut (n - 1)) xs)
  
  -- ========================================================================
  -- Light (sum type)
  -- ========================================================================
  
  data Light = NoLight | LightFreq Double | LightColor Color deriving (Show, Generic)
  
  instance ToSchema Light where
    declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions
  
  instance ToJSON Light where
    toJSON = genericToJSON defaultOptions { sumEncoding = ObjectWithSingleField }
  
  instance Arbitrary Light where
    arbitrary = oneof
      [ return NoLight
      , LightFreq <$> arbitrary
      , LightColor <$> arbitrary
      ]
  
  invalidLightToJSON :: Light -> Value
  invalidLightToJSON = genericToJSON defaultOptions
  
  -- ========================================================================
  -- ButtonImages (bounded enum key mapping)
  -- ========================================================================
  
  data ButtonState = Neutral | Focus | Active | Hover | Disabled
    deriving (Show, Eq, Ord, Bounded, Enum, Generic)
  
  instance ToJSON ButtonState
  instance ToSchema ButtonState
  instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (T.pack . show)
  
  instance Arbitrary ButtonState where
    arbitrary = arbitraryBoundedEnum
  
  type ImageUrl = T.Text
  
  newtype ButtonImages = ButtonImages { getButtonImages :: Map ButtonState ImageUrl }
    deriving (Show, Generic)
  
  instance ToJSON ButtonImages where
    toJSON = toJSON . getButtonImages
  
  instance ToSchema ButtonImages where
    declareNamedSchema = genericDeclareNamedSchemaNewtype defaultSchemaOptions
      declareSchemaBoundedEnumKeyMapping
  
  invalidButtonImagesToJSON :: ButtonImages -> Value
  invalidButtonImagesToJSON = genericToJSON defaultOptions
  
  instance Arbitrary ButtonImages where
    arbitrary = ButtonImages <$> arbitrary
  
  -- ========================================================================
  -- FreeForm (wraps a raw JSON Value)
  -- ========================================================================
  
  data FreeForm = FreeForm { jsonContent :: Map T.Text Value }
    deriving (Show, Generic)
  
  instance ToJSON FreeForm where
    toJSON = toJSON . jsonContent
  
  instance ToSchema FreeForm where
    declareNamedSchema _ = pure $ NamedSchema (Just $ T.pack "FreeForm") $ mempty
      & type_ ?~ SwaggerObject
      & additionalProperties ?~ AdditionalPropertiesAllowed True
  
  instance Arbitrary FreeForm where
    arbitrary = FreeForm . fromList <$> genObj
      where
        genObj = listOf $ do
          k <- arbitrary
          v <- oneof [ String <$> arbitrary, Number <$> arbitrary, Bool <$> arbitrary, pure Null ]
          pure (k, v)
  
  instance Eq ZonedTime where
    ZonedTime t (TimeZone x _ _) == ZonedTime t' (TimeZone y _ _) = t == t' && x == y
  
  -- ========================================================================
  -- Arbitrary instance for Data.Aeson.Value
  -- ========================================================================
  
  #if !MIN_VERSION_aeson(2,0,3)
  instance Arbitrary Value where
    -- Weights are almost random
    -- Uniform oneof tends not to build complex objects cause of recursive call.
    arbitrary = resize 4 $ frequency
      [ (3, Object . KM.fromHashMapText <$> arbitrary)
      , (3, Array  <$> arbitrary)
      , (3, String <$> arbitrary)
      , (3, Number <$> arbitrary)
      , (3, Bool   <$> arbitrary)
      , (1, return Null) ]
  
  instance Arbitrary (KM.KeyMap Value) where
    arbitrary = KM.fromHashMapText <$> arbitrary
  #endif
  