{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeAbstractions #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}
module Main (main) where
import Control.Lens (At(at), (&), set)
import Data.Aeson (ToJSON(toJSON), FromJSON)
import Data.JsonSpec
( Field(Field), FieldSpec(Optional, Required)
, HasJsonDecodingSpec(DecodingSpec, fromJSONStructure)
, HasJsonEncodingSpec(EncodingSpec, toJSONStructure), SpecJSON(SpecJSON)
, Specification
( JsonArray, JsonBool, JsonDateTime, JsonEither, JsonInt, JsonLet
, JsonNullable, JsonNum, JsonObject, JsonRaw, JsonRef, JsonString, JsonTag
)
, (:::), (::?), unField
)
import Data.JsonSpec.OpenApi (EncodingSchema, Rename, toOpenApiSchema)
import Data.OpenApi (Definitions, ToSchema)
import Data.Proxy (Proxy(Proxy))
import Data.Text (Text)
import Data.Time (UTCTime)
import Prelude
( Applicative(pure), Bool(False), Functor(fmap), Maybe(Just), Monoid(mempty)
, ($), (.), Eq, IO, Show
)
import Test.Hspec (describe, hspec, it, shouldBe)
import qualified Data.Aeson as Aeson
import qualified Data.HashMap.Strict.InsOrd as HMI
import qualified Data.OpenApi as OA
main :: IO ()
main =
hspec $ do
describe "toOpenApiSchema" $ do
it "string" $
let
actual :: (Definitions OA.Schema, OA.Schema)
actual = toOpenApiSchema (Proxy @JsonString)
expected :: (Definitions OA.Schema, OA.Schema)
expected = (mempty, stringSchema)
in
actual `shouldBe` expected
it "sum" $
let
actual :: (Definitions OA.Schema, OA.Schema)
actual =
toOpenApiSchema (Proxy @(
JsonEither
(
JsonObject
'[ Required "tag" (JsonTag "a")
, Required "content" JsonString
]
)
(
JsonObject
'[ Required "tag" (JsonTag "b")
, Required "content" JsonString
]
)
))
expected :: (Definitions OA.Schema, OA.Schema)
expected =
( mempty
, mempty
& set OA.oneOf (Just
[ OA.Inline $
mempty
& set OA.type_ (Just OA.OpenApiObject)
& set OA.properties (
mempty
& set (at "tag") (Just (OA.Inline (
mempty
& set OA.enum_ (Just [toJSON ("a" :: Text)])
)))
& set (at "content") (Just (
OA.Inline stringSchema
))
)
& set OA.required ["tag", "content"]
& set
OA.additionalProperties
(Just (OA.AdditionalPropertiesAllowed False))
, OA.Inline $
mempty
& set OA.type_ (Just OA.OpenApiObject)
& set OA.properties (
mempty
& set (at "tag") (Just (OA.Inline (
mempty
& set OA.enum_ (Just [toJSON ("b" :: Text)])
)))
& set (at "content") (Just (
OA.Inline stringSchema
))
)
& set OA.required ["tag", "content"]
& set
OA.additionalProperties
(Just (OA.AdditionalPropertiesAllowed False))
]
)
)
in
actual `shouldBe` expected
it "object" $
let
actual :: (Definitions OA.Schema, OA.Schema)
actual =
toOpenApiSchema (Proxy @(
JsonObject '[
Required "Foo" JsonString,
Required "Bar" JsonString
]
))
expected :: (Definitions OA.Schema, OA.Schema)
expected =
( mempty
, mempty
& set OA.type_ (Just OA.OpenApiObject)
& set OA.properties (
mempty
& set (at "Foo") (Just (OA.Inline stringSchema))
& set (at "Bar") (Just (OA.Inline stringSchema))
)
& set OA.required ["Foo", "Bar"]
& set
OA.additionalProperties
(Just (OA.AdditionalPropertiesAllowed False))
)
in
actual `shouldBe` expected
it "raw" $
let
actual :: (Definitions OA.Schema, OA.Schema)
actual = toOpenApiSchema (Proxy @JsonRaw)
expected :: (Definitions OA.Schema, OA.Schema)
expected =
( mempty
, mempty & set OA.type_ (Just OA.OpenApiObject)
)
in
actual `shouldBe` expected
it "num" $
let
actual :: (Definitions OA.Schema, OA.Schema)
actual = toOpenApiSchema (Proxy @JsonNum)
expected :: (Definitions OA.Schema, OA.Schema)
expected = (mempty, numSchema)
in
actual `shouldBe` expected
it "complex array" $
let
actual :: (Definitions OA.Schema, OA.Schema)
actual =
toOpenApiSchema (Proxy @(
JsonArray (
JsonObject '[
Required "Foo" JsonString,
Required "Bar" JsonString
]
)
))
expected :: (Definitions OA.Schema, OA.Schema)
expected =
( mempty
, let
elementSchema :: OA.Schema
elementSchema =
mempty
& set OA.type_ (Just OA.OpenApiObject)
& set OA.properties (
mempty
& set (at "Foo") (Just (OA.Inline stringSchema))
& set (at "Bar") (Just (OA.Inline stringSchema))
)
& set OA.required ["Foo", "Bar"]
& set
OA.additionalProperties
(Just (OA.AdditionalPropertiesAllowed False))
in
mempty
& set OA.type_ (Just OA.OpenApiArray)
& set OA.items (Just (
OA.OpenApiItemsObject (OA.Inline elementSchema)
))
)
in
actual `shouldBe` expected
it "bool" $
let
actual :: (Definitions OA.Schema, OA.Schema)
actual =
toOpenApiSchema (Proxy @JsonBool)
expected :: (Definitions OA.Schema, OA.Schema)
expected = (mempty, boolSchema)
in
actual `shouldBe` expected
it "nullable" $
let
actual :: (Definitions OA.Schema, OA.Schema)
actual =
toOpenApiSchema (Proxy @(JsonNullable JsonInt))
expected :: (Definitions OA.Schema, OA.Schema)
expected =
( mempty
, mempty
& set OA.oneOf (Just
[ OA.Inline $
mempty & set OA.type_ (Just OA.OpenApiNull)
, OA.Inline $
mempty & set OA.type_ (Just OA.OpenApiInteger)
]
)
)
in
Aeson.encode actual `shouldBe` Aeson.encode expected
it "optional" $
let
actual :: (Definitions OA.Schema, OA.Schema)
actual =
toOpenApiSchema (Proxy @(
JsonObject '[
Required "foo" JsonString,
Optional "bar" JsonString
]
))
expected :: (Definitions OA.Schema, OA.Schema)
expected =
( mempty
, mempty
& set OA.type_ (Just OA.OpenApiObject)
& set OA.properties (
mempty
& set (at "foo") (Just (OA.Inline stringSchema))
& set (at "bar") (Just (OA.Inline stringSchema))
)
& set OA.required ["foo"]
& set
OA.additionalProperties
(Just (OA.AdditionalPropertiesAllowed False))
)
in
Aeson.encode actual `shouldBe` Aeson.encode expected
it "date-time" $
let
actual :: (Definitions OA.Schema, OA.Schema)
actual =
toOpenApiSchema (Proxy @JsonDateTime)
expected :: (Definitions OA.Schema, OA.Schema)
expected =
( mempty
, stringSchema & set OA.format (Just "date-time")
)
in
actual `shouldBe` expected
it "let expression" $
let
actual :: (Definitions OA.Schema, OA.Schema)
actual =
toOpenApiSchema (Proxy @(
JsonLet '[
'("thing", JsonString)
]
(
JsonObject '[
Required "foo" (JsonRef "thing")
]
)
))
expected :: (Definitions OA.Schema, OA.Schema)
expected =
( HMI.singleton "thing" stringSchema
, mempty
& set OA.type_ (Just OA.OpenApiObject)
& set OA.properties (
mempty
& set (at "foo") (Just (OA.Ref (OA.Reference "thing")))
)
& set OA.required ["foo"]
& set
OA.additionalProperties
(Just (OA.AdditionalPropertiesAllowed False))
)
in
actual `shouldBe` expected
it "top level reference" $
let
actual :: (Definitions OA.Schema, OA.Schema)
actual =
toOpenApiSchema (Proxy @(
JsonLet '[
'("foo", JsonNum),
'("bar", JsonString)
]
(JsonRef "bar")
))
expected :: (Definitions OA.Schema, OA.Schema)
expected =
( HMI.fromList [("foo", numSchema), ("bar", stringSchema)]
, stringSchema
)
in
actual `shouldBe` expected
it "lower level reference" $
let
actual :: (Definitions OA.Schema, OA.Schema)
actual =
toOpenApiSchema (Proxy @(
JsonObject '[
Required "foo" (
JsonLet
'[ '("thing", JsonString)]
(JsonRef "thing")
)
]
))
expected :: (Definitions OA.Schema, OA.Schema)
expected =
( HMI.singleton "thing" stringSchema
, mempty
& set OA.type_ (Just OA.OpenApiObject)
& set OA.properties (
mempty
& set (at "foo") (Just (OA.Ref (OA.Reference "thing")))
)
& set OA.required ["foo"]
& set
OA.additionalProperties
(Just (OA.AdditionalPropertiesAllowed False))
)
in
Aeson.encode actual `shouldBe` Aeson.encode expected
it "Mutual recursion" $
let
barSchema :: OA.Schema
barSchema =
mempty
& set OA.type_ (Just OA.OpenApiObject)
& set
OA.additionalProperties
(Just (OA.AdditionalPropertiesAllowed False))
& set
OA.properties
(
HMI.fromList
[ ( "recbar"
, OA.Inline (
mempty
& set OA.type_ (Just OA.OpenApiArray)
& set
OA.items
(
Just
. OA.OpenApiItemsObject
. OA.Ref
. OA.Reference
$ "foo"
)
)
)
, ( "valbar"
, OA.Inline stringSchema
)
]
)
& set OA.required ["recbar", "valbar"]
expected :: (Definitions OA.Schema, OA.Schema)
expected =
( HMI.fromList
[ ( "foo"
, mempty
& set OA.type_ (Just OA.OpenApiObject)
& set
OA.additionalProperties
(Just (OA.AdditionalPropertiesAllowed False))
& set
OA.properties
(
HMI.fromList
[ ( "recfoo"
, OA.Inline (
mempty
& set OA.type_ (Just OA.OpenApiArray)
& set
OA.items
(
Just
. OA.OpenApiItemsObject
. OA.Ref
. OA.Reference
$ "bar"
)
)
)
, ( "valfoo"
, OA.Inline (
mempty
& set OA.type_ (Just OA.OpenApiInteger)
)
)
]
)
& set OA.required ["recfoo", "valfoo"]
)
, ( "bar"
, barSchema
)
]
, barSchema
)
actual :: (Definitions OA.Schema, OA.Schema)
actual =
toOpenApiSchema (Proxy @(
JsonLet
'[ '( "foo"
, JsonObject
'[ "recfoo" ::: JsonArray (JsonRef "bar")
, "valfoo" ::: JsonInt
]
)
, '( "bar"
, JsonObject
'[ "recbar" ::: JsonArray (JsonRef "foo")
, "valbar" ::: JsonString
]
)
]
(JsonRef "bar")
))
in
Aeson.encode actual `shouldBe` Aeson.encode expected
it "Nested name conflict" $
let
expected :: (Definitions OA.Schema, OA.Schema)
expected =
( mempty
& set (at "foo.1") (Just (stringSchema))
& set (at "foo") (Just (stringSchema))
, stringSchema
)
actual :: (Definitions OA.Schema, OA.Schema)
actual =
toOpenApiSchema (Proxy @(Rename (
JsonLet
'[ '("foo"
, JsonLet
'[ '( "foo"
, JsonString
)
]
(JsonRef "foo")
)
]
(JsonRef "foo")
)))
in
Aeson.encode actual `shouldBe` Aeson.encode expected
it "Nested name conflict 2" $
let
expectedFooSchema :: OA.Schema
expectedFooSchema =
mempty
& set OA.type_ (Just OA.OpenApiObject)
& set
OA.additionalProperties
(Just (OA.AdditionalPropertiesAllowed False))
& set OA.properties (
mempty
& set (at "field1") (Just (
OA.Ref (OA.Reference "foo.1")
))
& set (at "field2") (Just (
OA.Ref (OA.Reference "bar")
))
)
expected :: (Definitions OA.Schema, OA.Schema)
expected =
( mempty
& set (at "bar") (Just stringSchema)
& set (at "foo.1") (Just stringSchema)
& set (at "foo") (Just expectedFooSchema)
, expectedFooSchema
)
actual :: (Definitions OA.Schema, OA.Schema)
actual =
toOpenApiSchema (Proxy @(Rename (
JsonLet
'[ '("foo"
, JsonLet
'[ '( "foo"
, JsonString
)
]
(
JsonObject
'[ ("field1" ::? JsonRef "foo")
, ("field2" ::? JsonRef "bar")
]
)
)
, '( "bar"
, JsonString
)
]
(JsonRef "foo")
)))
in
Aeson.encode actual `shouldBe` Aeson.encode expected
it "Nested name conflict 3" $
let
expected :: (Definitions OA.Schema, OA.Schema)
expected =
( mempty
& set (at "foo.1") (Just stringSchema)
& set (at "foo.2") (Just (
mempty & set OA.type_ (Just OA.OpenApiInteger)
))
& set (at "foo.3") (Just (
mempty & set OA.type_ (Just OA.OpenApiBoolean)
))
& set (at "foo") (Just (
mempty
& set OA.type_ (Just OA.OpenApiObject)
& set OA.properties (HMI.fromList
[ ("field1", OA.Ref (OA.Reference "foo.1"))
, ("field2", OA.Ref (OA.Reference "foo.2"))
, ("field3", OA.Ref (OA.Reference "foo.3"))
]
)
& set OA.additionalProperties (Just (
OA.AdditionalPropertiesAllowed False
))
& set OA.required ["field1", "field2", "field3"]
))
& set (at "foo.4") (Just (
mempty
& set OA.oneOf (
Just
[ OA.Inline $
mempty & set OA.type_ (Just OA.OpenApiNull)
, OA.Inline $ stringSchema
]
)
))
, mempty
& set OA.type_ (Just OA.OpenApiObject)
& set OA.properties (HMI.fromList
[ ("field1", OA.Ref (OA.Reference "foo"))
, ("field2", OA.Ref (OA.Reference "foo.4"))
]
)
& set OA.required ["field1", "field2"]
& set OA.additionalProperties (Just (
OA.AdditionalPropertiesAllowed False
))
)
actual :: (Definitions OA.Schema, OA.Schema)
actual =
toOpenApiSchema (Proxy @(Rename (
JsonLet
'[ '( "foo"
, JsonLet
'[ '("foo", JsonString) ]
(
JsonObject
'[ "field1" ::: JsonRef "foo"
, "field2" ::: JsonLet
'[ '("foo", JsonInt) ]
(JsonRef "foo")
, "field3" ::: JsonLet
'[ '("foo", JsonBool) ]
(JsonRef "foo")
]
)
)
]
(
JsonObject
'[ "field1" ::: JsonRef "foo"
, "field2" ::: JsonLet
'[ '("foo", JsonNullable JsonString) ]
(JsonRef "foo")
]
)
)))
in
Aeson.encode actual `shouldBe` Aeson.encode expected
describe "EncodingSchema" $
it "works" $
let
actual :: OA.Schema
actual = OA.toSchema (Proxy @User)
expected :: OA.Schema
expected =
mempty
& set OA.type_ (Just OA.OpenApiObject)
& set OA.properties (
mempty
& set (at "name") (Just (OA.Inline stringSchema))
& set (at "last-login") (Just (OA.Inline dateSchema))
)
& set OA.required ["name"]
& set
OA.additionalProperties
(Just (OA.AdditionalPropertiesAllowed False))
in
Aeson.encode actual `shouldBe` Aeson.encode expected
{-
This is the example used in the docs. If you update it, then update
the docs as well.
-}
data User = User
{ name :: Text
, lastLogin :: Maybe UTCTime
}
deriving stock (Show, Eq)
deriving ToSchema via (EncodingSchema User) -- <-- ToSchema instance defined here
deriving (ToJSON, FromJSON) via (SpecJSON User)
instance HasJsonEncodingSpec User where
type EncodingSpec User =
JsonObject
'[ Required "name" JsonString
, Optional "last-login" JsonDateTime
]
toJSONStructure user =
(Field @"name" (name user),
(fmap (Field @"last-login") (lastLogin user),
()))
instance HasJsonDecodingSpec User where
type DecodingSpec User = EncodingSpec User
fromJSONStructure
(Field @"name" name,
(fmap (unField @"last-login") -> lastLogin,
()))
=
pure User { name , lastLogin }
stringSchema :: OA.Schema
stringSchema = mempty & set OA.type_ (Just OA.OpenApiString)
numSchema :: OA.Schema
numSchema = mempty & set OA.type_ (Just OA.OpenApiNumber)
boolSchema :: OA.Schema
boolSchema = mempty & set OA.type_ (Just OA.OpenApiBoolean)
dateSchema :: OA.Schema
dateSchema =
mempty
& set OA.type_ (Just OA.OpenApiString)
& set OA.format (Just "date-time")