{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

{-|
  This module provides tools for integrating the type-level JSON
  'Specification' with the "openapi" package.

  You can use 'toOpenApiSchema' as a low-level tool to transform @json-spec@
  'Specification's into @openapi3@ 'Schema's directly, irrespective of any
  particular business data type.

  More likely you will want to use @-XDerivingVia@ along with 'EncodingSchema'
  or 'DecodingSchema' to derive 'ToSchema' instances for your data types.

  Example, given this data type:

  > data User = User
  >   {      name :: Text
  >   , lastLogin :: UTCTime
  >   }
  >   deriving ToSchema via (EncodingSchema User) -- <-- ToSchema instance defined here
  > instance HasJsonEncodingSpec User where
  >   type EncodingSpec User =
  >     JsonObject
  >       '[ '("name", JsonString)
  >        , '("last-login", JsonDateTime)
  >        ]
  >   toJSONStructure user =
  >     (Field @"name" (name user),
  >     (Field @"last-login" (lastLogin user),
  >     ()))

  Calling @'Data.Aeson.encode' ('Data.OpenApi3.toSchema' ('Proxy' :: 'Proxy' User))@
  will produce the following Schema:

  > {
  >   "additionalProperties": false,
  >   "properties": {
  >     "last-login": {
  >       "format": "date-time",
  >       "type": "string"
  >     },
  >     "name": {
  >       "type": "string"
  >     }
  >   },
  >   "required": [
  >     "name",
  >     "last-login"
  >   ],
  >   "type": "object"
  > }

  If you needed more control over the content of the schema you might also
  consider doing something like this, e.g. in the case where you would like to
  allow additional properties:

  > data User = User
  >   {      name :: Text
  >   , lastLogin :: UTCTime
  >   }
  > instance HasJsonEncodingSpec User where
  >   type EncodingSpec User =
  >     JsonObject
  >       '[ '("name", JsonString)
  >        , '("last-login", JsonDateTime)
  >        ]
  >   toJSONStructure user =
  >     (Field @"name" (name user),
  >     (Field @"last-login" (lastLogin user),
  >     ()))
  > instance ToSchema User where
  >   declareNamedSchema _proxy =
  >       pure $
  >         NamedSchema
  >           Nothing
  >           (
  >             toOpenApiSchema (EncodingSpec User)
  >               & set
  >                   additionalProperties
  >                   (Just (AdditionalPropertiesAllowed True))
  >           )

-}
module Data.JsonSpec.OpenApi (
  toOpenApiSchema,
  EncodingSchema(..),
  DecodingSchema(..),
) where


import Control.Lens (At(at), (&), over, set)
import Data.Aeson (ToJSON(toJSON))
import Data.JsonSpec (HasJsonDecodingSpec(DecodingSpec),
  HasJsonEncodingSpec(EncodingSpec), Specification(JsonArray, JsonBool,
  JsonDateTime, JsonEither, JsonInt, JsonNum, JsonObject, JsonString,
  JsonTag))
import Data.OpenApi (AdditionalProperties(AdditionalPropertiesAllowed),
  HasAdditionalProperties(additionalProperties), HasEnum(enum_),
  HasFormat(format), HasItems(items), HasOneOf(oneOf),
  HasProperties(properties), HasRequired(required), HasType(type_),
  NamedSchema(NamedSchema), OpenApiItems(OpenApiItemsObject),
  OpenApiType(OpenApiArray, OpenApiBoolean, OpenApiInteger,
  OpenApiNumber, OpenApiObject, OpenApiString), Referenced(Inline),
  ToSchema(declareNamedSchema), Schema)
import Data.String (IsString(fromString))
import Data.Text (Text)
import Data.Typeable (Proxy(Proxy), Typeable)
import GHC.TypeLits (KnownSymbol, symbolVal)
import Prelude (Applicative(pure), Bool(False), Maybe(Just, Nothing),
  Monoid(mempty), ($))


{-|
  Convert a 'Specification' into an OpenAPI 'Schema'. The type class
  'Internal' is an internal and opaque implementation detail and not
  something you should have to worry about. It /should/ already have an
  instance for every possible 'Specification' that can be constructed. If
  it does not, then that is a bug. Please report it! :-)
-}
toOpenApiSchema
  :: (Internal spec)
  => Proxy (spec :: Specification)
  -> Schema
toOpenApiSchema :: forall (spec :: Specification).
Internal spec =>
Proxy spec -> Schema
toOpenApiSchema = Proxy spec -> Schema
forall (spec :: Specification).
Internal spec =>
Proxy spec -> Schema
internal


class Internal (spec :: Specification) where
  {-|
    Given a `Specification`, produce an OpenApi schema equivalent to
    the specification. Usually you will want to use this in conjunction with
    `HasJsonEncodingSpec` or `HasJsonDecodingSpec`.

    Example:

    > data MyType = ...
    > instance HasJsonEncodingSpec MyType where
    >   type EncodingSpec MyType = ...
    >
    > schema :: Schema
    > schema = toOpenApiSchema (Proxy :: Proxy (EncodingSpec MyType))

  -}
  internal :: Proxy spec -> Schema
instance (KnownSymbol tag) => Internal ('JsonTag tag) where
  internal :: Proxy ('JsonTag tag) -> Schema
internal Proxy ('JsonTag tag)
_ =
    Schema
forall a. Monoid a => a
mempty Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& ASetter Schema Schema (Maybe [Value]) (Maybe [Value])
-> Maybe [Value] -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Schema Schema (Maybe [Value]) (Maybe [Value])
forall s a. HasEnum s a => Lens' s a
Lens' Schema (Maybe [Value])
enum_ ([Value] -> Maybe [Value]
forall a. a -> Maybe a
Just [Text -> Value
forall a. ToJSON a => a -> Value
toJSON (forall (a :: Symbol) b. (IsString b, KnownSymbol a) => b
sym @tag :: Text)])

instance Internal 'JsonString where
  internal :: Proxy 'JsonString -> Schema
internal Proxy 'JsonString
_ =
    Schema
forall a. Monoid a => a
mempty Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& ASetter Schema Schema (Maybe OpenApiType) (Maybe OpenApiType)
-> Maybe OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Schema Schema (Maybe OpenApiType) (Maybe OpenApiType)
forall s a. HasType s a => Lens' s a
Lens' Schema (Maybe OpenApiType)
type_ (OpenApiType -> Maybe OpenApiType
forall a. a -> Maybe a
Just OpenApiType
OpenApiString)
instance (Internal left, Internal right) => Internal ('JsonEither left right) where
  internal :: Proxy ('JsonEither left right) -> Schema
internal Proxy ('JsonEither left right)
_ =
    Schema
forall a. Monoid a => a
mempty
      Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& ASetter
  Schema
  Schema
  (Maybe [Referenced Schema])
  (Maybe [Referenced Schema])
-> Maybe [Referenced Schema] -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter
  Schema
  Schema
  (Maybe [Referenced Schema])
  (Maybe [Referenced Schema])
forall s a. HasOneOf s a => Lens' s a
Lens' Schema (Maybe [Referenced Schema])
oneOf ([Referenced Schema] -> Maybe [Referenced Schema]
forall a. a -> Maybe a
Just
          [ Schema -> Referenced Schema
forall a. a -> Referenced a
Inline (Proxy left -> Schema
forall (spec :: Specification).
Internal spec =>
Proxy spec -> Schema
internal (forall {k} (t :: k). Proxy t
forall (t :: Specification). Proxy t
Proxy @left))
          , Schema -> Referenced Schema
forall a. a -> Referenced a
Inline (Proxy right -> Schema
forall (spec :: Specification).
Internal spec =>
Proxy spec -> Schema
internal (forall {k} (t :: k). Proxy t
forall (t :: Specification). Proxy t
Proxy @right))
          ]
      )
instance Internal 'JsonNum where
  internal :: Proxy 'JsonNum -> Schema
internal Proxy 'JsonNum
_ =
    Schema
forall a. Monoid a => a
mempty Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& ASetter Schema Schema (Maybe OpenApiType) (Maybe OpenApiType)
-> Maybe OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Schema Schema (Maybe OpenApiType) (Maybe OpenApiType)
forall s a. HasType s a => Lens' s a
Lens' Schema (Maybe OpenApiType)
type_ (OpenApiType -> Maybe OpenApiType
forall a. a -> Maybe a
Just OpenApiType
OpenApiNumber)
instance Internal 'JsonInt where
  internal :: Proxy 'JsonInt -> Schema
internal Proxy 'JsonInt
_ =
    Schema
forall a. Monoid a => a
mempty Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& ASetter Schema Schema (Maybe OpenApiType) (Maybe OpenApiType)
-> Maybe OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Schema Schema (Maybe OpenApiType) (Maybe OpenApiType)
forall s a. HasType s a => Lens' s a
Lens' Schema (Maybe OpenApiType)
type_ (OpenApiType -> Maybe OpenApiType
forall a. a -> Maybe a
Just OpenApiType
OpenApiInteger)
instance Internal ('JsonObject '[]) where
  internal :: Proxy ('JsonObject '[]) -> Schema
internal Proxy ('JsonObject '[])
_ =
    Schema
forall a. Monoid a => a
mempty
      Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& ASetter Schema Schema (Maybe OpenApiType) (Maybe OpenApiType)
-> Maybe OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Schema Schema (Maybe OpenApiType) (Maybe OpenApiType)
forall s a. HasType s a => Lens' s a
Lens' Schema (Maybe OpenApiType)
type_ (OpenApiType -> Maybe OpenApiType
forall a. a -> Maybe a
Just OpenApiType
OpenApiObject)
      Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& ASetter
  Schema
  Schema
  (Maybe AdditionalProperties)
  (Maybe AdditionalProperties)
-> Maybe AdditionalProperties -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter
  Schema
  Schema
  (Maybe AdditionalProperties)
  (Maybe AdditionalProperties)
forall s a. HasAdditionalProperties s a => Lens' s a
Lens' Schema (Maybe AdditionalProperties)
additionalProperties (AdditionalProperties -> Maybe AdditionalProperties
forall a. a -> Maybe a
Just (Bool -> AdditionalProperties
AdditionalPropertiesAllowed Bool
False))
instance (KnownSymbol key, Internal spec, Internal ('JsonObject more)) => Internal ('JsonObject ( '(key, spec) : more )) where
  internal :: Proxy ('JsonObject ('(key, spec) : more)) -> Schema
internal Proxy ('JsonObject ('(key, spec) : more))
_ =
    let
      propertyName :: Text
      propertyName :: Text
propertyName = forall (a :: Symbol) b. (IsString b, KnownSymbol a) => b
sym @key

      propertySchema :: Schema
      propertySchema :: Schema
propertySchema = Proxy spec -> Schema
forall (spec :: Specification).
Internal spec =>
Proxy spec -> Schema
internal (forall {k} (t :: k). Proxy t
forall (t :: Specification). Proxy t
Proxy @spec)
    in
      Proxy ('JsonObject more) -> Schema
forall (spec :: Specification).
Internal spec =>
Proxy spec -> Schema
internal (forall {k} (t :: k). Proxy t
forall (t :: Specification). Proxy t
Proxy @('JsonObject more))
        Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& ASetter
  Schema
  Schema
  (InsOrdHashMap Text (Referenced Schema))
  (InsOrdHashMap Text (Referenced Schema))
-> (InsOrdHashMap Text (Referenced Schema)
    -> InsOrdHashMap Text (Referenced Schema))
-> Schema
-> Schema
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter
  Schema
  Schema
  (InsOrdHashMap Text (Referenced Schema))
  (InsOrdHashMap Text (Referenced Schema))
forall s a. HasProperties s a => Lens' s a
Lens' Schema (InsOrdHashMap Text (Referenced Schema))
properties (ASetter
  (InsOrdHashMap Text (Referenced Schema))
  (InsOrdHashMap Text (Referenced Schema))
  (Maybe (IxValue (InsOrdHashMap Text (Referenced Schema))))
  (Maybe (Referenced Schema))
-> Maybe (Referenced Schema)
-> InsOrdHashMap Text (Referenced Schema)
-> InsOrdHashMap Text (Referenced Schema)
forall s t a b. ASetter s t a b -> b -> s -> t
set (Index (InsOrdHashMap Text (Referenced Schema))
-> Lens'
     (InsOrdHashMap Text (Referenced Schema))
     (Maybe (IxValue (InsOrdHashMap Text (Referenced Schema))))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Text
Index (InsOrdHashMap Text (Referenced Schema))
propertyName) (Referenced Schema -> Maybe (Referenced Schema)
forall a. a -> Maybe a
Just (Schema -> Referenced Schema
forall a. a -> Referenced a
Inline Schema
propertySchema)))
        Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& ASetter Schema Schema [Text] [Text]
-> ([Text] -> [Text]) -> Schema -> Schema
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter Schema Schema [Text] [Text]
forall s a. HasRequired s a => Lens' s a
Lens' Schema [Text]
required (Text
propertyNameText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:)
instance (Internal spec) => Internal ('JsonArray spec) where
  internal :: Proxy ('JsonArray spec) -> Schema
internal Proxy ('JsonArray spec)
_ =
    let
      elementSchema :: Schema
      elementSchema :: Schema
elementSchema = Proxy spec -> Schema
forall (spec :: Specification).
Internal spec =>
Proxy spec -> Schema
internal (forall {k} (t :: k). Proxy t
forall (t :: Specification). Proxy t
Proxy @spec)
    in
      Schema
forall a. Monoid a => a
mempty
        Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& ASetter Schema Schema (Maybe OpenApiType) (Maybe OpenApiType)
-> Maybe OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Schema Schema (Maybe OpenApiType) (Maybe OpenApiType)
forall s a. HasType s a => Lens' s a
Lens' Schema (Maybe OpenApiType)
type_ (OpenApiType -> Maybe OpenApiType
forall a. a -> Maybe a
Just OpenApiType
OpenApiArray)
        Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& ASetter Schema Schema (Maybe OpenApiItems) (Maybe OpenApiItems)
-> Maybe OpenApiItems -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Schema Schema (Maybe OpenApiItems) (Maybe OpenApiItems)
forall s a. HasItems s a => Lens' s a
Lens' Schema (Maybe OpenApiItems)
items (OpenApiItems -> Maybe OpenApiItems
forall a. a -> Maybe a
Just (Referenced Schema -> OpenApiItems
OpenApiItemsObject (Schema -> Referenced Schema
forall a. a -> Referenced a
Inline Schema
elementSchema)))
instance Internal 'JsonBool where
  internal :: Proxy 'JsonBool -> Schema
internal Proxy 'JsonBool
_ =
    Schema
forall a. Monoid a => a
mempty Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& ASetter Schema Schema (Maybe OpenApiType) (Maybe OpenApiType)
-> Maybe OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Schema Schema (Maybe OpenApiType) (Maybe OpenApiType)
forall s a. HasType s a => Lens' s a
Lens' Schema (Maybe OpenApiType)
type_ (OpenApiType -> Maybe OpenApiType
forall a. a -> Maybe a
Just OpenApiType
OpenApiBoolean)

instance Internal 'JsonDateTime where
  internal :: Proxy 'JsonDateTime -> Schema
internal Proxy 'JsonDateTime
_ =
    Schema
forall a. Monoid a => a
mempty
      Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& ASetter Schema Schema (Maybe OpenApiType) (Maybe OpenApiType)
-> Maybe OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Schema Schema (Maybe OpenApiType) (Maybe OpenApiType)
forall s a. HasType s a => Lens' s a
Lens' Schema (Maybe OpenApiType)
type_ (OpenApiType -> Maybe OpenApiType
forall a. a -> Maybe a
Just OpenApiType
OpenApiString)
      Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& ASetter Schema Schema (Maybe Text) (Maybe Text)
-> Maybe Text -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Schema Schema (Maybe Text) (Maybe Text)
forall s a. HasFormat s a => Lens' s a
Lens' Schema (Maybe Text)
format (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"date-time")


{-|
  Helper for defining `ToSchema` instances based on `HasJsonEncodingSpec`
  using @deriving via@.

  Example:

  > data MyType = ...
  >   deriving ToSchema via (EncodingSchema MyType)
  > instance HasJsonEncodingSchema MyType where
  >   ...
-}
newtype EncodingSchema a =
  EncodingSchema {forall a. EncodingSchema a -> a
unEncodingSchema :: a}
instance (Typeable a, Internal (EncodingSpec a)) => ToSchema (EncodingSchema a) where
  declareNamedSchema :: Proxy (EncodingSchema a)
-> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy (EncodingSchema a)
_ =
    NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a. a -> DeclareT (Definitions Schema) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text -> Schema -> NamedSchema
NamedSchema Maybe Text
forall a. Maybe a
Nothing (Proxy (EncodingSpec a) -> Schema
forall (spec :: Specification).
Internal spec =>
Proxy spec -> Schema
toOpenApiSchema (forall {k} (t :: k). Proxy t
forall (t :: Specification). Proxy t
Proxy @(EncodingSpec a))))


{-|
  Helper for defining `ToSchema` instances based on `HasJsonDecodingSpec`
  using @deriving via@.

  Example:

  > data MyType = ...
  >   deriving ToSchema via (DecodingSchema MyType)
  > instance HasJsonDecodingSchema MyType where
  >   ...
-}
newtype DecodingSchema a =
  DecodingSchema {forall a. DecodingSchema a -> a
unDecodingSchema :: a}
instance (Typeable a, Internal (DecodingSpec a)) => ToSchema (DecodingSchema a) where
  declareNamedSchema :: Proxy (DecodingSchema a)
-> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy (DecodingSchema a)
_ =
    NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a. a -> DeclareT (Definitions Schema) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text -> Schema -> NamedSchema
NamedSchema Maybe Text
forall a. Maybe a
Nothing (Proxy (DecodingSpec a) -> Schema
forall (spec :: Specification).
Internal spec =>
Proxy spec -> Schema
toOpenApiSchema (forall {k} (t :: k). Proxy t
forall (t :: Specification). Proxy t
Proxy @(DecodingSpec a))))


{- | Shorthand for demoting type-level strings.  -}
sym
  :: forall a b.
     ( IsString b
     , KnownSymbol a
     )
  => b
sym :: forall (a :: Symbol) b. (IsString b, KnownSymbol a) => b
sym = String -> b
forall a. IsString a => String -> a
fromString (String -> b) -> String -> b
forall a b. (a -> b) -> a -> b
$ Proxy a -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @a)