GeneratorSpec.hs

{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}

module Data.OpenApi.Schema.GeneratorSpec where

import Control.Lens.Operators
import Data.Aeson
import Data.HashMap.Strict (HashMap)
import Data.HashMap.Strict qualified as HashMap
import Data.Hashable (Hashable)
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.OpenApi
import Data.OpenApi.Schema.Generator
import Data.Proxy
import Data.Set (Set)
import Data.Text qualified as T
import Data.Text.Lazy qualified as TL
import Data.Time
import Data.Version (Version)
import Data.Word
import GHC.Generics
import Prelude.Compat
import Test.Hspec
import Test.Hspec.QuickCheck
import Test.QuickCheck
import "unordered-containers" Data.HashSet (HashSet)
import "unordered-containers" Data.HashSet qualified as HashSet
import Prelude ()

shouldValidate :: (FromJSON a, ToSchema a) => Proxy a -> Property
shouldValidate = validateFromJSON

shouldNotValidate :: (FromJSON a, ToSchema a) => Proxy a -> Property
shouldNotValidate = expectFailure . shouldValidate

spec :: Spec
spec = do
  describe "FromJSON 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]))
    -- Heterogeneous tuples (and @IntMap@, which derives via @[(Int, a)]@) derive to
    -- positional @prefixItems@ + @items: false@, so the generator reconstructs each
    -- member's type and these round-trips hold.
    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))
  describe "Invalid FromJSON validation" $ do
    prop "WrongType" $ shouldNotValidate (Proxy :: Proxy WrongType)
    prop "MissingRequired" $ shouldNotValidate (Proxy :: Proxy MissingRequired)
    prop "MissingProperty" $ shouldNotValidate (Proxy :: Proxy MissingProperty)
    prop "WrongPropType" $ shouldNotValidate (Proxy :: Proxy WrongPropType)

-- =============================
-- Data types and bunk instances
-- =============================

data WrongType = WrongType Bool

instance FromJSON WrongType where
  parseJSON = withBool "WrongType" $ return . WrongType

instance ToSchema WrongType where
  declareNamedSchema _ =
    return
      . NamedSchema (Just "WrongType")
      $ mempty
      & type_ ?~ OpenApiTypeSingle OpenApiObject

data MissingRequired = MissingRequired
  { propA :: String,
    propB :: Bool
  }

instance FromJSON MissingRequired where
  parseJSON = withObject "MissingRequired" $ \o ->
    MissingRequired
      <$> o
      .: "propA"
      <*> o
      .: "propB"

instance ToSchema MissingRequired where
  declareNamedSchema _ = do
    stringSchema <- declareSchemaRef (Proxy :: Proxy String)
    boolSchema <- declareSchemaRef (Proxy :: Proxy Bool)
    return
      . NamedSchema (Just "MissingRequired")
      $ mempty
      & type_ ?~ OpenApiTypeSingle OpenApiObject
      & properties
        .~ [ ("propA", stringSchema),
             ("propB", boolSchema)
           ]
      & required .~ ["propA"]

data MissingProperty = MissingProperty
  { propC :: String,
    propD :: Bool
  }

instance FromJSON MissingProperty where
  parseJSON = withObject "MissingProperty" $ \o ->
    MissingProperty
      <$> o
      .: "propC"
      <*> o
      .: "propD"

instance ToSchema MissingProperty where
  declareNamedSchema _ = do
    stringSchema <- declareSchemaRef (Proxy :: Proxy String)
    return
      . NamedSchema (Just "MissingProperty")
      $ mempty
      & type_ ?~ OpenApiTypeSingle OpenApiObject
      & properties .~ [("propC", stringSchema)]
      & required .~ ["propC"]

data WrongPropType = WrongPropType
  { propE :: String
  }

instance FromJSON WrongPropType where
  parseJSON = withObject "WrongPropType" $ \o ->
    WrongPropType
      <$> o
      .: "propE"

instance ToSchema WrongPropType where
  declareNamedSchema _ = do
    boolSchema <- declareSchemaRef (Proxy :: Proxy Bool)
    return
      . NamedSchema (Just "WrongPropType")
      $ mempty
      & type_ ?~ OpenApiTypeSingle OpenApiObject
      & properties .~ [("propE", boolSchema)]
      & required .~ ["propE"]