{-# LANGUAGE TemplateHaskell #-}

-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2022 Wire Swiss GmbH <opensource@wire.com>
--
-- This program is free software: you can redistribute it and/or modify it under
-- the terms of the GNU Affero General Public License as published by the Free
-- Software Foundation, either version 3 of the License, or (at your option) any
-- later version.
--
-- This program is distributed in the hope that it will be useful, but WITHOUT
-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
-- details.
--
-- You should have received a copy of the GNU Affero General Public License along
-- with this program. If not, see <https://www.gnu.org/licenses/>.

module Test.Data.Schema where

import Control.Applicative
import Control.Arrow ((&&&))
import Control.Lens (Prism', at, ix, makePrisms, nullOf, prism', (?~), (^.), _1)
import Data.Aeson (FromJSON (..), Result (..), ToJSON (..), Value (..), decode, encode, fromJSON)
import Data.Aeson.QQ
import Data.Aeson.Types qualified as A
import Data.HashMap.Strict.InsOrd qualified as InsOrdHashMap
import Data.List.NonEmpty (NonEmpty ((:|)))
import Data.OpenApi qualified as S
import Data.OpenApi.Declare qualified as S
import Data.Proxy
import Data.Schema hiding (getName)
import Data.Text qualified as Text
import Imports
import Test.Data.Schema.Names
import Test.Tasty
import Test.Tasty.HUnit

tests :: TestTree
tests =
  testGroup
    "Swagger.Typed"
    [ testFooToJSON,
      testFooFromJSON,
      testFooFromJSONFailure,
      testFooSchema,
      testBarAToJSON,
      testBarAFromJSON,
      testBarBToJSON,
      testBarBFromJSON,
      testAccessToJSON,
      testAccessFromJSON,
      testUser1ToJSON,
      testUser1FromJSON,
      testUser2ToJSON,
      testUser2FromJSON,
      testUserSchema,
      testTaggedObjectToJSON,
      testTaggedObjectFromJSON,
      testTaggedObject2ToJSON,
      testTaggedObject2FromJSON,
      testTaggedObject3FromJSON,
      testNonEmptyParseFailure,
      testNonEmptyParseSuccess,
      testNonEmptyToJSON,
      testNonEmptySchema,
      testRefField,
      testGenericObject,
      testRmClientWrong,
      testRmClient,
      testEnumType,
      testNullable,
      testSchemaNames
    ]

testFooToJSON :: TestTree
testFooToJSON =
  testCase "toJSON Foo" $
    assertEqual
      "toJSON should match handwritten JSON"
      exampleFooJSON
      (toJSON exampleFoo)

testFooFromJSON :: TestTree
testFooFromJSON =
  testCase "fromJSON Foo" $
    assertEqual
      "fromJSON should match example"
      (Success exampleFoo)
      (fromJSON exampleFooJSON)

testFooFromJSONFailure :: TestTree
testFooFromJSONFailure =
  testCase "fromJSON Foo failure" $
    case fromJSON @Foo exampleFooInvalidJSON of
      Success _ -> assertFailure "fromJSON should fail"
      Error err -> do
        assertBool
          "fromJSON error should mention missing key"
          ("\"str\"" `isInfixOf` err)

testFooSchema :: TestTree
testFooSchema =
  testCase "Foo schema" $ do
    let s = S.toSchema (Proxy @Foo)
    assertEqual
      "Description should match"
      (Just "A Foo object")
      (s ^. description)
    assertEqual
      "a, b and str should be required"
      ["a", "b", "str"]
      (s ^. S.required)
    assertEqual
      "Schema for \"a\" should be referenced"
      (Just (S.Ref (S.Reference "A_LTU1Nzc2NDkw")))
      (s ^. S.properties . at "a")
    case s ^. S.properties . at "str" of
      Nothing -> assertFailure "\"str\" field should be present"
      Just (S.Ref _) ->
        assertFailure "Schema for \"str\" field should be inlined"
      Just (S.Inline _) -> pure ()

testBarAToJSON :: TestTree
testBarAToJSON =
  testCase "toJSON BarA" $
    assertEqual
      "toJSON should match handwritten JSON"
      exampleBarAJSON
      (toJSON exampleBarA)

testBarAFromJSON :: TestTree
testBarAFromJSON =
  testCase "fromJSON BarA" $
    assertEqual
      "fromJSON should match example"
      (Success exampleBarA)
      (fromJSON exampleBarAJSON)

testBarBToJSON :: TestTree
testBarBToJSON =
  testCase "toJSON BarB" $
    assertEqual
      "toJSON should match handwritten JSON"
      exampleBarBJSON
      (toJSON exampleBarB)

testBarBFromJSON :: TestTree
testBarBFromJSON =
  testCase "fromJSON BarB" $
    assertEqual
      "fromJSON should match example"
      (Success exampleBarB)
      (fromJSON exampleBarBJSON)

testAccessToJSON :: TestTree
testAccessToJSON =
  testCase "toJSON Access" $
    assertEqual
      "toJSON should match handwritten JSON"
      "link"
      (toJSON Link)

testAccessFromJSON :: TestTree
testAccessFromJSON =
  testCase "fromJSON Access" $
    assertEqual
      "fromJSON should match example"
      (Success Link)
      (fromJSON "link")

testUser1ToJSON :: TestTree
testUser1ToJSON =
  testCase "toJSON User" $
    assertEqual
      "toJSON should match handwritten JSON"
      exampleUser1JSON
      (encode exampleUser1)

testUser1FromJSON :: TestTree
testUser1FromJSON =
  testCase "fromJSON User" $
    assertEqual
      "fromJSON should match example"
      (Just exampleUser1)
      (decode exampleUser1JSON)

testUser2ToJSON :: TestTree
testUser2ToJSON =
  testCase "toJSON User" $
    assertEqual
      "toJSON should match handwritten JSON"
      exampleUser2JSON
      (encode exampleUser2)

testUser2FromJSON :: TestTree
testUser2FromJSON =
  testCase "fromJSON User" $
    assertEqual
      "fromJSON should match example"
      (Just exampleUser2)
      (decode exampleUser2JSON)

testUserSchema :: TestTree
testUserSchema =
  testCase "User schema" $ do
    let s = S.toSchema (Proxy @User)
    assertEqual
      "only name should be required"
      ["name"]
      (s ^. S.required)

testTaggedObjectToJSON :: TestTree
testTaggedObjectToJSON =
  testCase "toJSON TaggedObject" $
    assertEqual
      "toJSON should match handwritten JSON"
      exampleTaggedObjectJSON
      (toJSON exampleTaggedObject)

testTaggedObjectFromJSON :: TestTree
testTaggedObjectFromJSON =
  testCase "fromJSON TaggedObject" $
    assertEqual
      "fromJSON should match example"
      (Success exampleTaggedObject)
      (fromJSON exampleTaggedObjectJSON)

testTaggedObject2ToJSON :: TestTree
testTaggedObject2ToJSON =
  testCase "toJSON TaggedObject 2" $
    assertEqual
      "toJSON should match handwritten JSON"
      exampleTaggedObject2JSON
      (toJSON exampleTaggedObject2)

testTaggedObject2FromJSON :: TestTree
testTaggedObject2FromJSON =
  testCase "fromJSON TaggedObject 2" $
    assertEqual
      "fromJSON should match example"
      (Success exampleTaggedObject2)
      (fromJSON exampleTaggedObject2JSON)

testTaggedObject3FromJSON :: TestTree
testTaggedObject3FromJSON =
  testCase "fromJSON TaggedObject failure" $
    case fromJSON @TaggedObject exampleTaggedObject3JSON of
      Success _ -> assertFailure "fromJSON should fail"
      Error err -> do
        assertBool
          "fromJSON error should mention missing key"
          ("\"tag1_data\"" `isInfixOf` err)

testNonEmptyParseFailure :: TestTree
testNonEmptyParseFailure =
  testCase "NonEmpty parse failure" $ do
    let invalidJSON = [aesonQQ|{"nl": []}|]
    case fromJSON @NonEmptyTest invalidJSON of
      Success _ -> assertFailure "fromJSON should fail"
      Error err -> do
        assertEqual
          "fromJSON error should mention that list is not empty"
          "Unexpected empty array found while parsing a NonEmpty"
          err

testNonEmptyParseSuccess :: TestTree
testNonEmptyParseSuccess =
  testCase "NonEmpty parse success" $ do
    let json = [aesonQQ|{"nl": ["something", "other thing"]}|]
        expected = NonEmptyTest ("something" :| ["other thing"])
    assertEqual
      "fromJSON should mention that list is not empty"
      (Success expected)
      (fromJSON json)

testNonEmptyToJSON :: TestTree
testNonEmptyToJSON =
  testCase "NonEmpty ToJSON" $ do
    let expected = [aesonQQ|{"nl": ["something", "other thing"]}|]
        testVal = NonEmptyTest ("something" :| ["other thing"])
    assertEqual
      "fromJSON should mention that list is not empty"
      expected
      (toJSON testVal)

testNonEmptySchema :: TestTree
testNonEmptySchema =
  testCase "NonEmpty Schema" $ do
    let sch = S.toSchema (Proxy @NonEmptyTest)
    case InsOrdHashMap.lookup "nl" $ sch ^. S.properties of
      Nothing -> assertFailure "expected schema to have a property called 'nl'"
      Just (S.Ref _) -> assertFailure "expected property 'nl' to have inline schema"
      Just (S.Inline nlSch) -> do
        assertEqual "type should be Array" (Just S.OpenApiArray) (nlSch ^. S.type_)
        assertEqual "minItems should be 1" (Just 1) (nlSch ^. S.minItems)

testRefField :: TestTree
testRefField =
  testCase "Reference in a field" $ do
    let (defs, _) = S.runDeclare (S.declareSchemaRef (Proxy @Named)) mempty
    assertBool "Referenced schema should be declared" $
      not . nullOf (ix "Name") $
        defs

testGenericObject :: TestTree
testGenericObject =
  testCase "Generic object" $ do
    let s = S.toSchema (Proxy @GenericObject)
    assertEqual
      "type should be Object"
      (Just S.OpenApiObject)
      (s ^. S.type_)

testRmClientWrong :: TestTree
testRmClientWrong =
  testCase "Parser succeeds when password is invalid" $ do
    let json = [aesonQQ|{"password": "a"}|]
        expected = RmClient Nothing
    assertEqual
      "fromJSON should succeed"
      (Success expected)
      (A.parse (schemaIn rmClientSchema) json)

testRmClient :: TestTree
testRmClient =
  testCase "Parser fails when password is invalid" $ do
    let json = [aesonQQ|{"password": "a"}|]
    case fromJSON @RmClient json of
      Success _ -> assertFailure "fromJSON should fail"
      Error err -> do
        assertEqual
          "fromJSON error should mention password too short"
          "password too short"
          err

testEnumType :: TestTree
testEnumType =
  testCase "Enum Swagger schema has the correct type" $ do
    let e1 :: ValueSchema NamedSwaggerDoc Text
        e1 = enum @Text (element "hello" "hello")
        (_, s1) = S.runDeclare (declareSwaggerSchema e1) mempty
    assertEqual
      "Text enum has Swagger type \"string\""
      (s1 ^. S.type_)
      (Just S.OpenApiString)

    let e2 :: ValueSchema NamedSwaggerDoc Integer
        e2 = enum @Integer (element (3 :: Integer) (3 :: Integer))
        (_, s2) = S.runDeclare (declareSwaggerSchema e2) mempty
    assertEqual
      "Integer enum has Swagger type \"integer\""
      (s2 ^. S.type_)
      (Just S.OpenApiInteger)

testNullable :: TestTree
testNullable =
  let sch = nullable (unnamed schema) :: ValueSchema SwaggerDoc (Maybe Int)
   in testGroup
        "Nullable schemas"
        [ testCase "Nullable schemas should parse both null and non-null values" $ do
            A.parse (schemaIn sch) (A.Number 5) @?= Success (Just 5)
            A.parse (schemaIn sch) A.Null @?= Success Nothing,
          testCase "Nullable schemas should produce either a value or null" $ do
            schemaOut sch (Just 5) @?= Just (A.Number 5)
            schemaOut sch Nothing @?= Just A.Null,
          testCase "Nullable schemas should return an error when parsing invalid non-null values" $ do
            case A.parse (schemaIn sch) (A.String "foo") of
              Success _ -> assertFailure "fromJSON should fail"
              Error _ -> pure ()
        ]

---

data A = A {thing :: Text, other :: Int}
  deriving (Eq, Show)

instance ToSchema A where
  schema =
    object $
      A
        <$> thing .= field "thing" schema
        <*> other .= field "other" schema

newtype B = B {bThing :: Int}
  deriving (Eq, Show)

instance ToSchema B where
  schema = object $ B <$> bThing .= field "b_thing" schema

data Foo = Foo {fooA :: A, fooB :: B, fooStr :: Text}
  deriving stock (Eq, Show)
  deriving (ToJSON, FromJSON, S.ToSchema) via Schema Foo

exampleFoo :: Foo
exampleFoo = Foo (A "a-thing" 42) (B 99) "raw string"

exampleFooJSON :: Value
exampleFooJSON =
  [aesonQQ|{ "a": {"thing": "a-thing", "other": 42},
          "a_thing": "a-thing",
          "b": {"b_thing": 99},
          "str": "raw string"
        }|]

exampleFooInvalidJSON :: Value
exampleFooInvalidJSON =
  [aesonQQ| { "a": {"thing": "a-thing", "other": 42},
              "b": {"b_thing": 99}} |]

instance ToSchema Foo where
  schema =
    (doc . description ?~ "A Foo object")
      . object
      $ Foo
        <$> fooA .= field "a" schema
        <* (thing . fooA) .= optional (field "a_thing" (unnamed schema))
        <*> fooB .= field "b" schema
        <*> fooStr .= field "str" (unnamed schema)

data Bar = BarA A | BarB B
  deriving (Eq, Show)
  deriving (ToJSON, FromJSON) via Schema Bar

_BarA :: Prism' Bar A
_BarA = prism' BarA $ \case
  BarA a -> Just a
  _ -> Nothing

_BarB :: Prism' Bar B
_BarB = prism' BarB $ \case
  BarB b -> Just b
  _ -> Nothing

instance ToSchema Bar where
  schema =
    named "Bar" $
      tag _BarA (unnamed schema)
        <> tag _BarB (unnamed schema)

exampleBarA :: Bar
exampleBarA = BarA (A "cthulhu" 711)

exampleBarAJSON :: Value
exampleBarAJSON = [aesonQQ| {"thing": "cthulhu", "other": 711} |]

exampleBarB :: Bar
exampleBarB = BarB (B 831)

exampleBarBJSON :: Value
exampleBarBJSON = [aesonQQ| {"b_thing": 831} |]

data Access = Public | Private | Link | Code
  deriving (Eq, Show)
  deriving (ToJSON, FromJSON) via Schema Access

instance ToSchema Access where
  schema =
    enum @Text $
      element "public" Public
        <> element "private" Private
        <> element "link" Link
        <> element "code" Code

-- optional fields

data User = User
  { userName :: Text,
    userHandle :: Maybe Text,
    userExpire :: Maybe Int
  }
  deriving (Eq, Show)
  deriving (ToJSON, FromJSON, S.ToSchema) via Schema User

instance ToSchema User where
  schema =
    object $
      User
        <$> userName .= field "name" schema
        <*> userHandle .= maybe_ (optField "handle" schema)
        <*> userExpire .= maybe_ (optField "expire" schema)

exampleUser1 :: User
exampleUser1 = User "Alice" (Just "alice") Nothing

exampleUser1JSON :: LByteString
exampleUser1JSON = "{\"handle\":\"alice\",\"name\":\"Alice\"}"

exampleUser2 :: User
exampleUser2 = User "Bob" Nothing (Just 100)

exampleUser2JSON :: LByteString
exampleUser2JSON = "{\"expire\":100,\"name\":\"Bob\"}"

-- bind schemas

data TaggedObject = TO
  { toTag :: Tag,
    toObj :: UntaggedObject
  }
  deriving (Eq, Show)
  deriving (FromJSON, ToJSON, S.ToSchema) via Schema TaggedObject

data UntaggedObject = Obj1 String | Obj2 Int
  deriving (Eq, Show)

data Tag = Tag1 | Tag2
  deriving (Eq, Show, Enum, Bounded)

_Obj1 :: Prism' UntaggedObject String
_Obj1 = prism' Obj1 $ \case
  Obj1 a -> Just a
  _ -> Nothing

_Obj2 :: Prism' UntaggedObject Int
_Obj2 = prism' Obj2 $ \case
  Obj2 b -> Just b
  _ -> Nothing

instance ToSchema Tag where
  schema = enum @Text (element "tag1" Tag1 <> element "tag2" Tag2)

instance ToSchema TaggedObject where
  schema =
    object $
      uncurry TO
        <$> (toTag &&& toObj)
          .= bind
            (fst .= field "tag" schema)
            (snd .= fieldOver _1 "obj" (objectOver _1 untaggedSchema))
    where
      untaggedSchema = dispatch $ \case
        Tag1 -> tag _Obj1 (field "tag1_data" schema)
        Tag2 -> tag _Obj2 (field "tag2_data" schema)

exampleTaggedObject :: TaggedObject
exampleTaggedObject = TO Tag1 (Obj1 "foo")

exampleTaggedObjectJSON :: Value
exampleTaggedObjectJSON = [aesonQQ| {"tag": "tag1", "obj": { "tag1_data": "foo" } } |]

exampleTaggedObject2 :: TaggedObject
exampleTaggedObject2 = TO Tag2 (Obj2 44)

exampleTaggedObject2JSON :: Value
exampleTaggedObject2JSON = [aesonQQ| {"tag": "tag2", "obj": { "tag2_data": 44 } } |]

exampleTaggedObject3JSON :: Value
exampleTaggedObject3JSON = [aesonQQ| {"tag": "tag1", "obj": { "tag2_data": 44 } } |]

-- non empty

newtype NonEmptyTest = NonEmptyTest {nl :: NonEmpty Text}
  deriving stock (Eq, Show)
  deriving (ToJSON, FromJSON, S.ToSchema) via Schema NonEmptyTest

instance ToSchema NonEmptyTest where
  schema = object $ NonEmptyTest <$> nl .= field "nl" (nonEmptyArray schema)

-- references

newtype Named = Named {getName :: Text}

instance ToSchema Named where
  schema = Named <$> getName .= object (field "name" (text "Name"))

instance S.ToSchema Named where
  declareNamedSchema = schemaToSwagger

--- optional fields

data RmClient = RmClient {rmPassword :: Maybe Text}
  deriving (Eq, Show)
  deriving (FromJSON) via Schema RmClient

passwordSchema :: ValueSchema NamedSwaggerDoc Text
passwordSchema = schema `withParser` validate
  where
    validate :: Text -> A.Parser Text
    validate x =
      if Text.length x < 6
        then fail "password too short"
        else pure x

-- this is "wrong", because it succeeds even if password validation fails
rmClientSchema :: ValueSchema NamedSwaggerDoc RmClient
rmClientSchema =
  object $
    RmClient
      <$> rmPassword .= optional (field "password" (maybeWithDefault Null passwordSchema))

instance ToSchema RmClient where
  schema =
    object $
      RmClient
        <$> rmPassword .= maybe_ (optField "password" passwordSchema)

-- Generic Object
newtype GenericObject = GenericObject {fromGenericObject :: A.Object}
  deriving (ToJSON, FromJSON, S.ToSchema) via Schema GenericObject

instance ToSchema GenericObject where
  schema =
    named "GenericObject" $
      GenericObject <$> fromGenericObject .= jsonObject

-- examples from documentation (only type-checked)

data Detail
  = Name Text
  | Age Int

makePrisms ''Detail

data DetailTag = NameTag | AgeTag
  deriving (Eq, Enum, Bounded)

tagSchema :: ValueSchema NamedSwaggerDoc DetailTag
tagSchema =
  enum @Text $
    mconcat [element "name" NameTag, element "age" AgeTag]

detailSchema :: ValueSchema NamedSwaggerDoc Detail
detailSchema =
  object $
    fromTagged
      <$> toTagged
        .= bind
          (fst .= field "tag" tagSchema)
          (snd .= fieldOver _1 "value" untaggedSchema)
  where
    toTagged :: Detail -> (DetailTag, Detail)
    toTagged d@(Name _) = (NameTag, d)
    toTagged d@(Age _) = (AgeTag, d)

    fromTagged :: (DetailTag, Detail) -> Detail
    fromTagged = snd

    untaggedSchema = dispatch $ \case
      NameTag -> tag _Name (unnamed schema)
      AgeTag -> tag _Age (unnamed schema)

userSchemaWithDefaultName' :: ValueSchema NamedSwaggerDoc User
userSchemaWithDefaultName' =
  object $
    User
      <$> (getOptText . userName) .= maybe_ (fromMaybe "" <$> optField "name" schema)
      <*> userHandle .= maybe_ (optField "handle" schema)
      <*> userExpire .= maybe_ (optField "expire" schema)
  where
    getOptText :: Text -> Maybe Text
    getOptText "" = Nothing
    getOptText t = Just t

userSchemaWithDefaultName :: ValueSchema NamedSwaggerDoc User
userSchemaWithDefaultName =
  object $
    User
      <$> userName .= (field "name" schema <|> pure "")
      <*> userHandle .= maybe_ (optField "handle" schema)
      <*> userExpire .= maybe_ (optField "expire" schema)
