Schema.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
-- For TypeErrors
{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
module Data.Swagger.Internal.Schema where

import Prelude ()
import Prelude.Compat

import Control.Lens
import Data.Data.Lens (template)

import Control.Monad
import Control.Monad.Writer hiding (First, Last)
import Data.Aeson (ToJSON (..), ToJSONKey (..), ToJSONKeyFunction (..), Value (..), Object(..))
import Data.Char
import Data.Data (Data)
import Data.Foldable (traverse_)
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 qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
import Data.Int
import Data.IntSet (IntSet)
import Data.IntMap (IntMap)
import qualified Data.List as L
import Data.List.NonEmpty.Compat (NonEmpty)
import Data.Map (Map)
import Data.Proxy
import Data.Scientific (Scientific)
import Data.Fixed (Fixed, HasResolution, Pico)
import Data.Set (Set)
import Data.Semigroup
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import Data.Time
import qualified Data.Vector as V
import qualified Data.Vector.Primitive as VP
import qualified Data.Vector.Storable as VS
import qualified Data.Vector.Unboxed as VU
import Data.Version (Version)
import Numeric.Natural.Compat (Natural)
import Data.Word
import GHC.Generics
import qualified Data.UUID.Types as UUID

import Data.Swagger.Declare
import Data.Swagger.Internal
import Data.Swagger.Internal.ParamSchema (ToParamSchema(..))
import Data.Swagger.Lens hiding (name, schema)
import qualified Data.Swagger.Lens as Swagger
import Data.Swagger.SchemaOptions
import Data.Swagger.Internal.TypeShape

import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import GHC.TypeLits (TypeError, ErrorMessage(..))
import qualified Data.Aeson.KeyMap as KM
import Data.Aeson.Key (toText)

unnamed :: Schema -> NamedSchema
unnamed schema = NamedSchema Nothing schema

named :: T.Text -> Schema -> NamedSchema
named name schema = NamedSchema (Just name) schema

plain :: Schema -> Declare (Definitions Schema) NamedSchema
plain = pure . unnamed

unname :: NamedSchema -> NamedSchema
unname (NamedSchema _ schema) = unnamed schema

rename :: Maybe T.Text -> NamedSchema -> NamedSchema
rename name (NamedSchema _ schema) = NamedSchema name schema

-- | Convert a type into @'Schema'@.
--
-- An example type and instance:
--
-- @
-- {-\# LANGUAGE OverloadedStrings \#-}   -- allows to write 'T.Text' literals
-- {-\# LANGUAGE OverloadedLists \#-}     -- allows to write 'Map' and 'HashMap' as lists
--
-- import Control.Lens
-- import Data.Proxy
-- import Data.Swagger
--
-- data Coord = Coord { x :: Double, y :: Double }
--
-- instance ToSchema Coord where
--   declareNamedSchema _ = do
--     doubleSchema <- declareSchemaRef (Proxy :: Proxy Double)
--     return $ NamedSchema (Just \"Coord\") $ mempty
--       & type_ ?~ SwaggerObject
--       & properties .~
--           [ (\"x\", doubleSchema)
--           , (\"y\", doubleSchema)
--           ]
--       & required .~ [ \"x\", \"y\" ]
-- @
--
-- Instead of manually writing your @'ToSchema'@ instance you can
-- use a default generic implementation of @'declareNamedSchema'@.
--
-- To do that, simply add @deriving 'Generic'@ clause to your datatype
-- and declare a @'ToSchema'@ instance for your datatype without
-- giving definition for @'declareNamedSchema'@.
--
-- For instance, the previous example can be simplified into this:
--
-- @
-- {-\# LANGUAGE DeriveGeneric \#-}
--
-- import GHC.Generics (Generic)
--
-- data Coord = Coord { x :: Double, y :: Double } deriving Generic
--
-- instance ToSchema Coord
-- @
class ToSchema a where
  -- | Convert a type into an optionally named schema
  -- together with all used definitions.
  -- Note that the schema itself is included in definitions
  -- only if it is recursive (and thus needs its definition in scope).
  declareNamedSchema :: Proxy a -> Declare (Definitions Schema) NamedSchema
  default declareNamedSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareNamedSchemaUnrestricted") =>
    Proxy a -> Declare (Definitions Schema) NamedSchema
  declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions

instance ToSchema TimeOfDay where
  declareNamedSchema _ = pure $ named "TimeOfDay" $ timeSchema "hh:MM:ss"
    & example ?~ toJSON (TimeOfDay 12 33 15)

-- | Convert a type into a schema and declare all used schema definitions.
declareSchema :: ToSchema a => Proxy a -> Declare (Definitions Schema) Schema
declareSchema = fmap _namedSchemaSchema . declareNamedSchema

-- | Convert a type into an optionally named schema.
--
-- >>> toNamedSchema (Proxy :: Proxy String) ^. name
-- Nothing
-- >>> encode (toNamedSchema (Proxy :: Proxy String) ^. schema)
-- "{\"type\":\"string\"}"
--
-- >>> toNamedSchema (Proxy :: Proxy Day) ^. name
-- Just "Day"
-- >>> encode (toNamedSchema (Proxy :: Proxy Day) ^. schema)
-- "{\"example\":\"2016-07-22\",\"format\":\"date\",\"type\":\"string\"}"
toNamedSchema :: ToSchema a => Proxy a -> NamedSchema
toNamedSchema = undeclare . declareNamedSchema

-- | Get type's schema name according to its @'ToSchema'@ instance.
--
-- >>> schemaName (Proxy :: Proxy Int)
-- Nothing
--
-- >>> schemaName (Proxy :: Proxy UTCTime)
-- Just "UTCTime"
schemaName :: ToSchema a => Proxy a -> Maybe T.Text
schemaName = _namedSchemaName . toNamedSchema

-- | Convert a type into a schema.
--
-- >>> encode $ toSchema (Proxy :: Proxy Int8)
-- "{\"maximum\":127,\"minimum\":-128,\"type\":\"integer\"}"
--
-- >>> encode $ toSchema (Proxy :: Proxy [Day])
-- "{\"items\":{\"$ref\":\"#/definitions/Day\"},\"type\":\"array\"}"
toSchema :: ToSchema a => Proxy a -> Schema
toSchema = _namedSchemaSchema . toNamedSchema

-- | Convert a type into a referenced schema if possible.
-- Only named schemas can be referenced, nameless schemas are inlined.
--
-- >>> encode $ toSchemaRef (Proxy :: Proxy Integer)
-- "{\"type\":\"integer\"}"
--
-- >>> encode $ toSchemaRef (Proxy :: Proxy Day)
-- "{\"$ref\":\"#/definitions/Day\"}"
toSchemaRef :: ToSchema a => Proxy a -> Referenced Schema
toSchemaRef = undeclare . declareSchemaRef

-- | Convert a type into a referenced schema if possible
-- and declare all used schema definitions.
-- Only named schemas can be referenced, nameless schemas are inlined.
--
-- Schema definitions are typically declared for every referenced schema.
-- If @'declareSchemaRef'@ returns a reference, a corresponding schema
-- will be declared (regardless of whether it is recusive or not).
declareSchemaRef :: ToSchema a => Proxy a -> Declare (Definitions Schema) (Referenced Schema)
declareSchemaRef proxy = do
  case toNamedSchema proxy of
    NamedSchema (Just name) schema -> do
      -- This check is very important as it allows generically
      -- derive used definitions for recursive schemas.
      -- Lazy Declare monad allows toNamedSchema to ignore
      -- any declarations (which would otherwise loop) and
      -- retrieve the schema and its name to check if we
      -- have already declared it.
      -- If we have, we don't need to declare anything for
      -- this schema this time and thus simply return the reference.
      known <- looks (InsOrdHashMap.member name)
      when (not known) $ do
        declare [(name, schema)]
        void $ declareNamedSchema proxy
      return $ Ref (Reference name)
    _ -> Inline <$> declareSchema proxy

-- | Inline any referenced schema if its name satisfies given predicate.
--
-- /NOTE:/ if a referenced schema is not found in definitions the predicate is ignored
-- and schema stays referenced.
--
-- __WARNING:__ @'inlineSchemasWhen'@ will produce infinite schemas
-- when inlining recursive schemas.
inlineSchemasWhen :: Data s => (T.Text -> Bool) -> (Definitions Schema) -> s -> s
inlineSchemasWhen p defs = template %~ deref
  where
    deref r@(Ref (Reference name))
      | p name =
          case InsOrdHashMap.lookup name defs of
            Just schema -> Inline (inlineSchemasWhen p defs schema)
            Nothing -> r
      | otherwise = r
    deref (Inline schema) = Inline (inlineSchemasWhen p defs schema)

-- | Inline any referenced schema if its name is in the given list.
--
-- /NOTE:/ if a referenced schema is not found in definitions
-- it stays referenced even if it appears in the list of names.
--
-- __WARNING:__ @'inlineSchemas'@ will produce infinite schemas
-- when inlining recursive schemas.
inlineSchemas :: Data s => [T.Text] -> (Definitions Schema) -> s -> s
inlineSchemas names = inlineSchemasWhen (`elem` names)

-- | Inline all schema references for which the definition
-- can be found in @'Definitions'@.
--
-- __WARNING:__ @'inlineAllSchemas'@ will produce infinite schemas
-- when inlining recursive schemas.
inlineAllSchemas :: Data s => (Definitions Schema) -> s -> s
inlineAllSchemas = inlineSchemasWhen (const True)

-- | Convert a type into a schema without references.
--
-- >>> encode $ toInlinedSchema (Proxy :: Proxy [Day])
-- "{\"items\":{\"example\":\"2016-07-22\",\"format\":\"date\",\"type\":\"string\"},\"type\":\"array\"}"
--
-- __WARNING:__ @'toInlinedSchema'@ will produce infinite schema
-- when inlining recursive schemas.
toInlinedSchema :: ToSchema a => Proxy a -> Schema
toInlinedSchema proxy = inlineAllSchemas defs schema
  where
    (defs, schema) = runDeclare (declareSchema proxy) mempty

-- | Inline all /non-recursive/ schemas for which the definition
-- can be found in @'Definitions'@.
inlineNonRecursiveSchemas :: Data s => (Definitions Schema) -> s -> s
inlineNonRecursiveSchemas defs = inlineSchemasWhen nonRecursive defs
  where
    nonRecursive name =
      case InsOrdHashMap.lookup name defs of
        Just schema -> name `notElem` execDeclare (usedNames schema) mempty
        Nothing     -> False

    usedNames schema = traverse_ schemaRefNames (schema ^.. template)

    schemaRefNames :: Referenced Schema -> Declare [T.Text] ()
    schemaRefNames ref = case ref of
      Ref (Reference name) -> do
        seen <- looks (name `elem`)
        when (not seen) $ do
          declare [name]
          traverse_ usedNames (InsOrdHashMap.lookup name defs)
      Inline subschema -> usedNames subschema

-- | Default schema for binary data (any sequence of octets).
binarySchema :: Schema
binarySchema = mempty
  & type_ ?~ SwaggerString
  & format ?~ "binary"

-- | Default schema for binary data (base64 encoded).
byteSchema :: Schema
byteSchema = mempty
  & type_ ?~ SwaggerString
  & format ?~ "byte"

-- | Default schema for password string.
-- @"password"@ format is used to hint UIs the input needs to be obscured.
passwordSchema :: Schema
passwordSchema = mempty
  & type_ ?~ SwaggerString
  & format ?~ "password"

-- | Make an unrestrictive sketch of a @'Schema'@ based on a @'ToJSON'@ instance.
-- Produced schema can be used for further refinement.
--
-- >>> encode $ sketchSchema "hello"
-- "{\"example\":\"hello\",\"type\":\"string\"}"
--
-- >>> encode $ sketchSchema (1, 2, 3)
-- "{\"example\":[1,2,3],\"items\":{\"type\":\"number\"},\"type\":\"array\"}"
--
-- >>> encode $ sketchSchema ("Jack", 25)
-- "{\"example\":[\"Jack\",25],\"items\":[{\"type\":\"string\"},{\"type\":\"number\"}],\"type\":\"array\"}"
--
-- >>> data Person = Person { name :: String, age :: Int } deriving (Generic)
-- >>> instance ToJSON Person
#if MIN_VERSION_text(2,0,0)
-- >>> encode $ sketchSchema (Person "Jack" 25)
-- "{\"required\":[\"age\",\"name\"],\"properties\":{\"name\":{\"type\":\"string\"},\"age\":{\"type\":\"number\"}},\"example\":{\"age\":25,\"name\":\"Jack\"},\"type\":\"object\"}"
#else
-- >>> encode $ sketchSchema (Person "Jack" 25)
-- "{\"required\":[\"name\",\"age\"],\"properties\":{\"name\":{\"type\":\"string\"},\"age\":{\"type\":\"number\"}},\"example\":{\"age\":25,\"name\":\"Jack\"},\"type\":\"object\"}"
#endif
sketchSchema :: ToJSON a => a -> Schema
sketchSchema = sketch . toJSON
  where
    sketch Null = go Null
    sketch js@(Bool _) = go js
    sketch js = go js & example ?~ js

    go Null       = mempty & type_ ?~ SwaggerNull
    go (Bool _)   = mempty & type_ ?~ SwaggerBoolean
    go (String _) = mempty & type_ ?~ SwaggerString
    go (Number _) = mempty & type_ ?~ SwaggerNumber
    go (Array xs) = mempty
      & type_   ?~ SwaggerArray
      & items ?~ case ischema of
          Just s -> SwaggerItemsObject (Inline s)
          _      -> SwaggerItemsArray (map Inline ys)
      where
        ys = map go (V.toList xs)
        allSame = and ((zipWith (==)) ys (tail ys))

        ischema = case ys of
          (z:_) | allSame -> Just z
          _               -> Nothing
    go (Object o') = let o = KM.toHashMapText o' in mempty
      & type_         ?~ SwaggerObject
      & required      .~ HashMap.keys o
      & properties    .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o)

-- | Make a restrictive sketch of a @'Schema'@ based on a @'ToJSON'@ instance.
-- Produced schema uses as much constraints as possible.
--
-- >>> encode $ sketchStrictSchema "hello"
-- "{\"enum\":[\"hello\"],\"maxLength\":5,\"minLength\":5,\"pattern\":\"hello\",\"type\":\"string\"}"
--
-- >>> encode $ sketchStrictSchema (1, 2, 3)
-- "{\"enum\":[[1,2,3]],\"items\":[{\"enum\":[1],\"maximum\":1,\"minimum\":1,\"multipleOf\":1,\"type\":\"number\"},{\"enum\":[2],\"maximum\":2,\"minimum\":2,\"multipleOf\":2,\"type\":\"number\"},{\"enum\":[3],\"maximum\":3,\"minimum\":3,\"multipleOf\":3,\"type\":\"number\"}],\"maxItems\":3,\"minItems\":3,\"type\":\"array\",\"uniqueItems\":true}"
--
-- >>> encode $ sketchStrictSchema ("Jack", 25)
-- "{\"enum\":[[\"Jack\",25]],\"items\":[{\"enum\":[\"Jack\"],\"maxLength\":4,\"minLength\":4,\"pattern\":\"Jack\",\"type\":\"string\"},{\"enum\":[25],\"maximum\":25,\"minimum\":25,\"multipleOf\":25,\"type\":\"number\"}],\"maxItems\":2,\"minItems\":2,\"type\":\"array\",\"uniqueItems\":true}"
--
-- >>> data Person = Person { name :: String, age :: Int } deriving (Generic)
-- >>> instance ToJSON Person
#if MIN_VERSION_text(2,0,0)
-- >>> encode $ sketchStrictSchema (Person "Jack" 25)
-- "{\"required\":[\"age\",\"name\"],\"properties\":{\"name\":{\"enum\":[\"Jack\"],\"maxLength\":4,\"minLength\":4,\"pattern\":\"Jack\",\"type\":\"string\"},\"age\":{\"enum\":[25],\"maximum\":25,\"minimum\":25,\"multipleOf\":25,\"type\":\"number\"}},\"maxProperties\":2,\"minProperties\":2,\"enum\":[{\"age\":25,\"name\":\"Jack\"}],\"type\":\"object\"}"
#else
-- >>> encode $ sketchStrictSchema (Person "Jack" 25)
-- "{\"required\":[\"name\",\"age\"],\"properties\":{\"name\":{\"enum\":[\"Jack\"],\"maxLength\":4,\"minLength\":4,\"pattern\":\"Jack\",\"type\":\"string\"},\"age\":{\"enum\":[25],\"maximum\":25,\"minimum\":25,\"multipleOf\":25,\"type\":\"number\"}},\"maxProperties\":2,\"minProperties\":2,\"enum\":[{\"age\":25,\"name\":\"Jack\"}],\"type\":\"object\"}"
#endif
sketchStrictSchema :: ToJSON a => a -> Schema
sketchStrictSchema = go . toJSON
  where
    go Null       = mempty & type_ ?~ SwaggerNull
    go js@(Bool _) = mempty
      & type_ ?~ SwaggerBoolean
      & enum_ ?~ [js]
    go js@(String s) = mempty
      & type_ ?~ SwaggerString
      & maxLength ?~ fromIntegral (T.length s)
      & minLength ?~ fromIntegral (T.length s)
      & pattern   ?~ s
      & enum_     ?~ [js]
    go js@(Number n) = mempty
      & type_       ?~ SwaggerNumber
      & maximum_    ?~ n
      & minimum_    ?~ n
      & multipleOf  ?~ n
      & enum_       ?~ [js]
    go js@(Array xs) = mempty
      & type_       ?~ SwaggerArray
      & maxItems    ?~ fromIntegral sz
      & minItems    ?~ fromIntegral sz
      & items       ?~ SwaggerItemsArray (map (Inline . go) (V.toList xs))
      & uniqueItems ?~ allUnique
      & enum_       ?~ [js]
      where
        sz = length xs
        allUnique = sz == HashSet.size (HashSet.fromList (V.toList xs))
    go js@(Object o') = let o = KM.toHashMapText o' in mempty
      & type_         ?~ SwaggerObject
      & required      .~ names
      & properties    .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o)
      & maxProperties ?~ fromIntegral (length names)
      & minProperties ?~ fromIntegral (length names)
      & enum_         ?~ [js]
      where
        names = HashMap.keys (KM.toHashMapText o')

class GToSchema (f :: * -> *) where
  gdeclareNamedSchema :: SchemaOptions -> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema

instance {-# OVERLAPPABLE #-} ToSchema a => ToSchema [a] where
  declareNamedSchema _ = do
    ref <- declareSchemaRef (Proxy :: Proxy a)
    return $ unnamed $ mempty
      & type_ ?~ SwaggerArray
      & items ?~ SwaggerItemsObject ref

instance {-# OVERLAPPING #-} ToSchema String where declareNamedSchema = plain . paramSchemaToSchema
instance ToSchema Bool    where declareNamedSchema = plain . paramSchemaToSchema
instance ToSchema Integer where declareNamedSchema = plain . paramSchemaToSchema
instance ToSchema Natural where declareNamedSchema = plain . paramSchemaToSchema
instance ToSchema Int     where declareNamedSchema = plain . paramSchemaToSchema
instance ToSchema Int8    where declareNamedSchema = plain . paramSchemaToSchema
instance ToSchema Int16   where declareNamedSchema = plain . paramSchemaToSchema
instance ToSchema Int32   where declareNamedSchema = plain . paramSchemaToSchema
instance ToSchema Int64   where declareNamedSchema = plain . paramSchemaToSchema
instance ToSchema Word    where declareNamedSchema = plain . paramSchemaToSchema
instance ToSchema Word8   where declareNamedSchema = plain . paramSchemaToSchema
instance ToSchema Word16  where declareNamedSchema = plain . paramSchemaToSchema
instance ToSchema Word32  where declareNamedSchema = plain . paramSchemaToSchema
instance ToSchema Word64  where declareNamedSchema = plain . paramSchemaToSchema

instance ToSchema Char where
  declareNamedSchema proxy = plain (paramSchemaToSchema proxy)
    & mapped.Swagger.schema.example ?~ toJSON '?'

instance ToSchema Scientific  where declareNamedSchema = plain . paramSchemaToSchema
instance ToSchema Double      where declareNamedSchema = plain . paramSchemaToSchema
instance ToSchema Float       where declareNamedSchema = plain . paramSchemaToSchema

instance HasResolution a => ToSchema (Fixed a) where declareNamedSchema = plain . paramSchemaToSchema

instance ToSchema a => ToSchema (Maybe a) where
  declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a)

instance (ToSchema a, ToSchema b) => ToSchema (Either a b)

instance ToSchema () where
  declareNamedSchema _ = pure (NamedSchema Nothing nullarySchema)

-- | For 'ToJSON' instance, see <http://hackage.haskell.org/package/uuid-aeson uuid-aeson> package.
instance ToSchema UUID.UUID where
  declareNamedSchema p = pure $ named "UUID" $ paramSchemaToSchema p
    & example ?~ toJSON (UUID.toText UUID.nil)

instance (ToSchema a, ToSchema b) => ToSchema (a, b)
instance (ToSchema a, ToSchema b, ToSchema c) => ToSchema (a, b, c)
instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d) => ToSchema (a, b, c, d)
instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e) => ToSchema (a, b, c, d, e)
instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f) => ToSchema (a, b, c, d, e, f)
instance (ToSchema a, ToSchema b, ToSchema c, ToSchema d, ToSchema e, ToSchema f, ToSchema g) => ToSchema (a, b, c, d, e, f, g)

timeSchema :: T.Text -> Schema
timeSchema fmt = mempty
  & type_ ?~ SwaggerString
  & format ?~ fmt

-- | Format @"date"@ corresponds to @yyyy-mm-dd@ format.
instance ToSchema Day where
  declareNamedSchema _ = pure $ named "Day" $ timeSchema "date"
    & example ?~ toJSON (fromGregorian 2016 7 22)

-- |
-- >>> toSchema (Proxy :: Proxy LocalTime) ^. format
-- Just "yyyy-mm-ddThh:MM:ss"
instance ToSchema LocalTime where
  declareNamedSchema _ = pure $ named "LocalTime" $ timeSchema "yyyy-mm-ddThh:MM:ss"
    & example ?~ toJSON (LocalTime (fromGregorian 2016 7 22) (TimeOfDay 7 40 0))

-- | Format @"date"@ corresponds to @yyyy-mm-ddThh:MM:ss(Z|+hh:MM)@ format.
instance ToSchema ZonedTime where
  declareNamedSchema _ = pure $ named "ZonedTime" $ timeSchema "date-time"
    & example ?~ toJSON (ZonedTime (LocalTime (fromGregorian 2016 7 22) (TimeOfDay 7 40 0)) (hoursToTimeZone 3))

instance ToSchema NominalDiffTime where
  declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy Pico)

-- |
-- >>> toSchema (Proxy :: Proxy UTCTime) ^. format
-- Just "yyyy-mm-ddThh:MM:ssZ"
instance ToSchema UTCTime where
  declareNamedSchema _ = pure $ named "UTCTime" $ timeSchema "yyyy-mm-ddThh:MM:ssZ"
    & example ?~ toJSON (UTCTime (fromGregorian 2016 7 22) 0)

instance ToSchema T.Text where declareNamedSchema = plain . paramSchemaToSchema
instance ToSchema TL.Text where declareNamedSchema = plain . paramSchemaToSchema

instance ToSchema Version where declareNamedSchema = plain . paramSchemaToSchema

type family ToSchemaByteStringError bs where
  ToSchemaByteStringError bs = TypeError
      ( Text "Impossible to have an instance " :<>: ShowType (ToSchema bs) :<>: Text "."
   :$$: Text "Please, use a newtype wrapper around " :<>: ShowType bs :<>: Text " instead."
   :$$: Text "Consider using byteSchema or binarySchema templates." )

instance ToSchemaByteStringError BS.ByteString  => ToSchema BS.ByteString  where declareNamedSchema = error "impossible"
instance ToSchemaByteStringError BSL.ByteString => ToSchema BSL.ByteString where declareNamedSchema = error "impossible"

instance ToSchema IntSet where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Set Int))

-- | NOTE: This schema does not account for the uniqueness of keys.
instance ToSchema a => ToSchema (IntMap a) where
  declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [(Int, a)])

instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (Map k v) where
  declareNamedSchema _ = case toJSONKey :: ToJSONKeyFunction k of
      ToJSONKeyText  _ _ -> declareObjectMapSchema
      ToJSONKeyValue _ _ -> declareNamedSchema (Proxy :: Proxy [(k, v)])
    where
      declareObjectMapSchema = do
        schema <- declareSchemaRef (Proxy :: Proxy v)
        return $ unnamed $ mempty
          & type_ ?~ SwaggerObject
          & additionalProperties ?~ AdditionalPropertiesSchema schema

instance (ToJSONKey k, ToSchema k, ToSchema v) => ToSchema (HashMap k v) where
  declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Map k v))

instance {-# OVERLAPPING #-} ToSchema Object where
  declareNamedSchema _ = pure $ NamedSchema (Just "Object") $ mempty
    & type_ ?~ SwaggerObject
    & description ?~ "Arbitrary JSON object."
    & additionalProperties ?~ AdditionalPropertiesAllowed True

instance ToSchema a => ToSchema (V.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])
instance ToSchema a => ToSchema (VU.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])
instance ToSchema a => ToSchema (VS.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])
instance ToSchema a => ToSchema (VP.Vector a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a])

instance ToSchema a => ToSchema (Set a) where
  declareNamedSchema _ = do
    schema <- declareSchema (Proxy :: Proxy [a])
    return $ unnamed $ schema
      & uniqueItems ?~ True

instance ToSchema a => ToSchema (HashSet a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Set a))

-- | @since 2.2.1
instance ToSchema a => ToSchema (NonEmpty a) where
  declareNamedSchema _ = do
    schema <- declareSchema (Proxy :: Proxy [a])
    return $ unnamed $ schema
      & minItems .~ Just 1

instance ToSchema All where declareNamedSchema = plain . paramSchemaToSchema
instance ToSchema Any where declareNamedSchema = plain . paramSchemaToSchema

instance ToSchema a => ToSchema (Sum a)     where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
instance ToSchema a => ToSchema (Product a) where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
instance ToSchema a => ToSchema (First a)   where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
instance ToSchema a => ToSchema (Last a)    where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)
instance ToSchema a => ToSchema (Dual a)    where declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a)

instance ToSchema a => ToSchema (Identity a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy a)

-- | Default schema for @'Bounded'@, @'Integral'@ types.
--
-- >>> encode $ toSchemaBoundedIntegral (Proxy :: Proxy Int16)
-- "{\"maximum\":32767,\"minimum\":-32768,\"type\":\"integer\"}"
toSchemaBoundedIntegral :: forall a. (Bounded a, Integral a) => Proxy a -> Schema
toSchemaBoundedIntegral _ = mempty
  & type_ ?~ SwaggerInteger
  & minimum_ ?~ fromInteger (toInteger (minBound :: a))
  & maximum_ ?~ fromInteger (toInteger (maxBound :: a))

-- | Default generic named schema for @'Bounded'@, @'Integral'@ types.
genericToNamedSchemaBoundedIntegral :: forall a d f.
  ( Bounded a, Integral a
  , Generic a, Rep a ~ D1 d f, Datatype d)
  => SchemaOptions -> Proxy a -> NamedSchema
genericToNamedSchemaBoundedIntegral opts proxy
  = genericNameSchema opts proxy (toSchemaBoundedIntegral proxy)

-- | Declare a named schema for a @newtype@ wrapper.
genericDeclareNamedSchemaNewtype :: forall a d c s i inner.
  (Generic a, Datatype d, Rep a ~ D1 d (C1 c (S1 s (K1 i inner))))
  => SchemaOptions                                          -- ^ How to derive the name.
  -> (Proxy inner -> Declare (Definitions Schema) Schema)   -- ^ How to create a schema for the wrapped type.
  -> Proxy a
  -> Declare (Definitions Schema) NamedSchema
genericDeclareNamedSchemaNewtype opts f proxy = genericNameSchema opts proxy <$> f (Proxy :: Proxy inner)

-- | Declare 'Schema' for a mapping with 'Bounded' 'Enum' keys.
-- This makes a much more useful schema when there aren't many options for key values.
--
-- >>> data ButtonState = Neutral | Focus | Active | Hover | Disabled deriving (Show, Bounded, Enum, Generic)
-- >>> instance ToJSON ButtonState
-- >>> instance ToSchema ButtonState
-- >>> instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (T.pack . show)
-- >>> type ImageUrl = T.Text
-- >>> encode $ toSchemaBoundedEnumKeyMapping (Proxy :: Proxy (Map ButtonState ImageUrl))
-- "{\"properties\":{\"Neutral\":{\"type\":\"string\"},\"Focus\":{\"type\":\"string\"},\"Active\":{\"type\":\"string\"},\"Hover\":{\"type\":\"string\"},\"Disabled\":{\"type\":\"string\"}},\"type\":\"object\"}"
--
-- Note: this is only useful when @key@ is encoded with 'ToJSONKeyText'.
-- If it is encoded with 'ToJSONKeyValue' then a regular schema for @[(key, value)]@ is used.
declareSchemaBoundedEnumKeyMapping :: forall map key value.
  (Bounded key, Enum key, ToJSONKey key, ToSchema key, ToSchema value)
  => Proxy (map key value) -> Declare (Definitions Schema) Schema
declareSchemaBoundedEnumKeyMapping _ = case toJSONKey :: ToJSONKeyFunction key of
  ToJSONKeyText keyToText _ -> objectSchema keyToText
  ToJSONKeyValue _ _ -> declareSchema (Proxy :: Proxy [(key, value)])
  where
    objectSchema keyToText = do
      valueRef <- declareSchemaRef (Proxy :: Proxy value)
      let allKeys   = [minBound..maxBound :: key]
          mkPair k  = (toText $ keyToText k, valueRef)
      return $ mempty
        & type_      ?~ SwaggerObject
        & properties .~ InsOrdHashMap.fromList (map mkPair allKeys)

-- | A 'Schema' for a mapping with 'Bounded' 'Enum' keys.
-- This makes a much more useful schema when there aren't many options for key values.
--
-- >>> data ButtonState = Neutral | Focus | Active | Hover | Disabled deriving (Show, Bounded, Enum, Generic)
-- >>> instance ToJSON ButtonState
-- >>> instance ToSchema ButtonState
-- >>> instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (T.pack . show)
-- >>> type ImageUrl = T.Text
-- >>> encode $ toSchemaBoundedEnumKeyMapping (Proxy :: Proxy (Map ButtonState ImageUrl))
-- "{\"properties\":{\"Neutral\":{\"type\":\"string\"},\"Focus\":{\"type\":\"string\"},\"Active\":{\"type\":\"string\"},\"Hover\":{\"type\":\"string\"},\"Disabled\":{\"type\":\"string\"}},\"type\":\"object\"}"
--
-- Note: this is only useful when @key@ is encoded with 'ToJSONKeyText'.
-- If it is encoded with 'ToJSONKeyValue' then a regular schema for @[(key, value)]@ is used.
toSchemaBoundedEnumKeyMapping :: forall map key value.
  (Bounded key, Enum key, ToJSONKey key, ToSchema key, ToSchema value)
  => Proxy (map key value) -> Schema
toSchemaBoundedEnumKeyMapping = flip evalDeclare mempty . declareSchemaBoundedEnumKeyMapping

-- | A configurable generic @'Schema'@ creator.
genericDeclareSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareSchemaUnrestricted") =>
  SchemaOptions -> Proxy a -> Declare (Definitions Schema) Schema
genericDeclareSchema = genericDeclareSchemaUnrestricted

-- | A configurable generic @'NamedSchema'@ creator.
-- This function applied to @'defaultSchemaOptions'@
-- is used as the default for @'declareNamedSchema'@
-- when the type is an instance of @'Generic'@.
genericDeclareNamedSchema :: (Generic a, GToSchema (Rep a), TypeHasSimpleShape a "genericDeclareNamedSchemaUnrestricted") =>
  SchemaOptions -> Proxy a -> Declare (Definitions Schema) NamedSchema
genericDeclareNamedSchema = genericDeclareNamedSchemaUnrestricted

-- | A configurable generic @'Schema'@ creator.
--
-- Unlike 'genericDeclareSchema' also works for mixed sum types.
-- Use with care since some Swagger tools do not support well schemas for mixed sum types.
genericDeclareSchemaUnrestricted :: (Generic a, GToSchema (Rep a)) => SchemaOptions -> Proxy a -> Declare (Definitions Schema) Schema
genericDeclareSchemaUnrestricted opts proxy = _namedSchemaSchema <$> genericDeclareNamedSchemaUnrestricted opts proxy

-- | A configurable generic @'NamedSchema'@ creator.
--
-- Unlike 'genericDeclareNamedSchema' also works for mixed sum types.
-- Use with care since some Swagger tools do not support well schemas for mixed sum types.
genericDeclareNamedSchemaUnrestricted :: forall a. (Generic a, GToSchema (Rep a)) =>
  SchemaOptions -> Proxy a -> Declare (Definitions Schema) NamedSchema
genericDeclareNamedSchemaUnrestricted opts _ = gdeclareNamedSchema opts (Proxy :: Proxy (Rep a)) mempty

-- | Derive a 'Generic'-based name for a datatype and assign it to a given 'Schema'.
genericNameSchema :: forall a d f.
  (Generic a, Rep a ~ D1 d f, Datatype d)
  => SchemaOptions -> Proxy a -> Schema -> NamedSchema
genericNameSchema opts _ = NamedSchema (gdatatypeSchemaName opts (Proxy :: Proxy d))

gdatatypeSchemaName :: forall d. Datatype d => SchemaOptions -> Proxy d -> Maybe T.Text
gdatatypeSchemaName opts _ = case orig of
  dtn   | L.isPrefixOf "Tuple" dtn -> Nothing -- special case for new TupleNNN types in GHC 9.8
  (c:_) | isAlpha c && isUpper c -> Just (T.pack name)
  _ -> Nothing
  where
    orig = datatypeName (Proxy3 :: Proxy3 d f a)
    name = datatypeNameModifier opts orig

-- | Lift a plain @'ParamSchema'@ into a model @'NamedSchema'@.
paramSchemaToNamedSchema :: (ToParamSchema a, Generic a, Rep a ~ D1 d f, Datatype d) =>
  SchemaOptions -> Proxy a -> NamedSchema
paramSchemaToNamedSchema opts proxy = genericNameSchema opts proxy (paramSchemaToSchema proxy)

-- | Lift a plain @'ParamSchema'@ into a model @'Schema'@.
paramSchemaToSchema :: ToParamSchema a => Proxy a -> Schema
paramSchemaToSchema proxy = mempty & paramSchema .~ toParamSchema proxy

nullarySchema :: Schema
nullarySchema = mempty
  & type_ ?~ SwaggerArray
  & items ?~ SwaggerItemsArray []

gtoNamedSchema :: GToSchema f => SchemaOptions -> Proxy f -> NamedSchema
gtoNamedSchema opts proxy = undeclare $ gdeclareNamedSchema opts proxy mempty

gdeclareSchema :: GToSchema f => SchemaOptions -> Proxy f -> Declare (Definitions Schema) Schema
gdeclareSchema opts proxy = _namedSchemaSchema <$> gdeclareNamedSchema opts proxy mempty

instance (GToSchema f, GToSchema g) => GToSchema (f :*: g) where
  gdeclareNamedSchema opts _ schema = do
    NamedSchema _ gschema <- gdeclareNamedSchema opts (Proxy :: Proxy f) schema
    gdeclareNamedSchema opts (Proxy :: Proxy g) gschema

instance (Datatype d, GToSchema f) => GToSchema (D1 d f) where
  gdeclareNamedSchema opts _ s = rename name <$> gdeclareNamedSchema opts (Proxy :: Proxy f) s
    where
      name = gdatatypeSchemaName opts (Proxy :: Proxy d)

instance {-# OVERLAPPABLE #-} GToSchema f => GToSchema (C1 c f) where
  gdeclareNamedSchema opts _ = gdeclareNamedSchema opts (Proxy :: Proxy f)

instance {-# OVERLAPPING #-} Constructor c => GToSchema (C1 c U1) where
  gdeclareNamedSchema = gdeclareNamedSumSchema

-- | Single field constructor.
instance (Selector s, GToSchema f, GToSchema (S1 s f)) => GToSchema (C1 c (S1 s f)) where
  gdeclareNamedSchema opts _ s
    | unwrapUnaryRecords opts = fieldSchema
    | otherwise =
        case schema ^. items of
          Just (SwaggerItemsArray [_]) -> fieldSchema
          _ -> do
            declare defs
            return (unnamed schema)
    where
      (defs, NamedSchema _ schema) = runDeclare recordSchema mempty
      recordSchema = gdeclareNamedSchema opts (Proxy :: Proxy (S1 s f)) s
      fieldSchema  = gdeclareNamedSchema opts (Proxy :: Proxy f) s

gdeclareSchemaRef :: GToSchema a => SchemaOptions -> Proxy a -> Declare (Definitions Schema) (Referenced Schema)
gdeclareSchemaRef opts proxy = do
  case gtoNamedSchema opts proxy of
    NamedSchema (Just name) schema -> do
      -- This check is very important as it allows generically
      -- derive used definitions for recursive schemas.
      -- Lazy Declare monad allows toNamedSchema to ignore
      -- any declarations (which would otherwise loop) and
      -- retrieve the schema and its name to check if we
      -- have already declared it.
      -- If we have, we don't need to declare anything for
      -- this schema this time and thus simply return the reference.
      known <- looks (InsOrdHashMap.member name)
      when (not known) $ do
        declare [(name, schema)]
        void $ gdeclareNamedSchema opts proxy mempty
      return $ Ref (Reference name)
    _ -> Inline <$> gdeclareSchema opts proxy

appendItem :: Referenced Schema -> Maybe (SwaggerItems 'SwaggerKindSchema) -> Maybe (SwaggerItems 'SwaggerKindSchema)
appendItem x Nothing = Just (SwaggerItemsArray [x])
appendItem x (Just (SwaggerItemsArray xs)) = Just (SwaggerItemsArray (xs ++ [x]))
appendItem _ _ = error "GToSchema.appendItem: cannot append to SwaggerItemsObject"

withFieldSchema :: forall proxy s f. (Selector s, GToSchema f) =>
  SchemaOptions -> proxy s f -> Bool -> Schema -> Declare (Definitions Schema) Schema
withFieldSchema opts _ isRequiredField schema = do
  ref <- gdeclareSchemaRef opts (Proxy :: Proxy f)
  return $
    if T.null fname
      then schema
        & type_ ?~ SwaggerArray
        & items %~ appendItem ref
        & maxItems %~ Just . maybe 1 (+1)   -- increment maxItems
        & minItems %~ Just . maybe 1 (+1)   -- increment minItems
      else schema
        & type_ ?~ SwaggerObject
        & properties . at fname ?~ ref
        & if isRequiredField
            then required %~ (++ [fname])
            else id
  where
    fname = T.pack (fieldLabelModifier opts (selName (Proxy3 :: Proxy3 s f p)))

-- | Optional record fields.
instance {-# OVERLAPPING #-} (Selector s, ToSchema c) => GToSchema (S1 s (K1 i (Maybe c))) where
  gdeclareNamedSchema opts _ = fmap unnamed . withFieldSchema opts (Proxy2 :: Proxy2 s (K1 i (Maybe c))) False

-- | Record fields.
instance {-# OVERLAPPABLE #-} (Selector s, GToSchema f) => GToSchema (S1 s f) where
  gdeclareNamedSchema opts _ = fmap unnamed . withFieldSchema opts (Proxy2 :: Proxy2 s f) True

instance {-# OVERLAPPING #-} ToSchema c => GToSchema (K1 i (Maybe c)) where
  gdeclareNamedSchema _ _ _ = declareNamedSchema (Proxy :: Proxy c)

instance {-# OVERLAPPABLE #-} ToSchema c => GToSchema (K1 i c) where
  gdeclareNamedSchema _ _ _ = declareNamedSchema (Proxy :: Proxy c)

instance ( GSumToSchema f
         , GSumToSchema g
         ) => GToSchema (f :+: g)
   where
  gdeclareNamedSchema = gdeclareNamedSumSchema

gdeclareNamedSumSchema :: GSumToSchema f => SchemaOptions -> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
gdeclareNamedSumSchema opts proxy s
  | allNullaryToStringTag opts && allNullary = pure $ unnamed (toStringTag sumSchema)
  | otherwise = (unnamed . fst) <$> runWriterT declareSumSchema
  where
    declareSumSchema = gsumToSchema opts proxy s
    (sumSchema, All allNullary) = undeclare (runWriterT declareSumSchema)

    toStringTag schema = mempty
      & type_ ?~ SwaggerString
      & enum_ ?~ map toJSON  (schema ^.. properties.ifolded.asIndex)

type AllNullary = All

class GSumToSchema (f :: * -> *)  where
  gsumToSchema :: SchemaOptions -> Proxy f -> Schema -> WriterT AllNullary (Declare (Definitions Schema)) Schema

instance (GSumToSchema f, GSumToSchema g) => GSumToSchema (f :+: g) where
  gsumToSchema opts _ = gsumToSchema opts (Proxy :: Proxy f) >=> gsumToSchema opts (Proxy :: Proxy g)

gsumConToSchemaWith :: forall c f. (GToSchema (C1 c f), Constructor c) =>
  Referenced Schema -> SchemaOptions -> Proxy (C1 c f) -> Schema -> Schema
gsumConToSchemaWith ref opts _ schema = schema
  & type_ ?~ SwaggerObject
  & properties . at tag ?~ ref
  & maxProperties ?~ 1
  & minProperties ?~ 1
  where
    tag = T.pack (constructorTagModifier opts (conName (Proxy3 :: Proxy3 c f p)))

gsumConToSchema :: (GToSchema (C1 c f), Constructor c) =>
  SchemaOptions -> Proxy (C1 c f) -> Schema -> Declare (Definitions Schema) Schema
gsumConToSchema opts proxy schema = do
  ref <- gdeclareSchemaRef opts proxy
  return $ gsumConToSchemaWith ref opts proxy schema

instance {-# OVERLAPPABLE #-} (Constructor c, GToSchema f) => GSumToSchema (C1 c f) where
  gsumToSchema opts proxy schema = do
    tell (All False)
    lift $ gsumConToSchema opts proxy schema

instance (Constructor c, Selector s, GToSchema f) => GSumToSchema (C1 c (S1 s f)) where
  gsumToSchema opts proxy schema = do
    tell (All False)
    lift $ gsumConToSchema opts proxy schema

instance Constructor c => GSumToSchema (C1 c U1) where
  gsumToSchema opts proxy = pure . gsumConToSchemaWith (Inline nullarySchema) opts proxy

data Proxy2 a b = Proxy2

data Proxy3 a b c = Proxy3

-- $setup
-- >>> import Data.Swagger
-- >>> import Data.Aeson (encode)
-- >>> import Data.Aeson.Types (toJSONKeyText)