{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

-- 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.Schema.UserSpec
  ( spec,
  )
where

import Data.Aeson
import qualified Data.Aeson.KeyMap as KeyMap
import Data.Either (isLeft, isRight)
import Data.Foldable (for_)
import Data.Text (Text)
import HaskellWorks.Hspec.Hedgehog (require)
import Hedgehog
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import Lens.Micro
import Network.URI.Static (uri)
import Test.Hspec
import Test.Schema.Util (genUri, mk_prop_caseInsensitive)
import Text.Email.Validate (emailAddress, validate)
import qualified Web.Scim.Class.User as UserClass
import Web.Scim.Filter (AttrPath (..))
import Web.Scim.Schema.Common (ScimBool (ScimBool), URI (..), WithId (..), lowerKey)
import qualified Web.Scim.Schema.ListResponse as ListResponse
import Web.Scim.Schema.Meta (ETag (Strong, Weak), Meta (..), WithMeta (..))
import Web.Scim.Schema.PatchOp (Op (..), Operation (..), PatchOp (..), Patchable (..), Path (..))
import qualified Web.Scim.Schema.PatchOp as PatchOp
import Web.Scim.Schema.Schema (Schema (..))
import Web.Scim.Schema.User (NoUserExtra (..), User (..))
import qualified Web.Scim.Schema.User as User
import Web.Scim.Schema.User.Address as Address
import Web.Scim.Schema.User.Certificate as Certificate
import Web.Scim.Schema.User.Email as Email
import Web.Scim.Schema.User.IM as IM
import Web.Scim.Schema.User.Name as Name
import Web.Scim.Schema.User.Phone as Phone
import Web.Scim.Schema.User.Photo as Photo
import Web.Scim.Test.Util

prop_roundtrip :: Property
prop_roundtrip = property $ do
  user <- forAll genUser
  tripping user toJSON fromJSON

type PatchTag = TestTag Text () () UserExtraPatch

type UserExtraPatch = KeyMap.KeyMap Text

spec :: Spec
spec = do
  describe "scimEmailsToEmailAddress" $ do
    let Right adr1 = validate "one@example.com"
        Right adr2 = validate "two@example.com"
        Right adr3 = validate "three@example.com"

        false1 = Nothing
        false2 = Just (ScimBool False)
        true = Just (ScimBool True)

    it "returns Nothing if empty" $ do
      scimEmailsToEmailAddress [] `shouldBe` Nothing

    it "returns first primary if it exists" $ do
      scimEmailsToEmailAddress
        [ Email Nothing (EmailAddress adr1) false1,
          Email Nothing (EmailAddress adr2) false2,
          Email (Just "this is ignored") (EmailAddress adr3) true
        ]
        `shouldBe` Just adr3

    it "returns first entry if no primary exists" $ do
      scimEmailsToEmailAddress
        [ Email Nothing (EmailAddress adr1) false1,
          Email Nothing (EmailAddress adr2) false2
        ]
        `shouldBe` Just adr1
      scimEmailsToEmailAddress
        [ Email Nothing (EmailAddress adr1) false2,
          Email Nothing (EmailAddress adr2) false1
        ]
        `shouldBe` Just adr1

  describe "applyPatch" $ do
    it "only applies patch for supported fields" $ do
      let schemas' = []
      let extras = KeyMap.empty
      let user :: User PatchTag = User.empty schemas' "hello" extras
      for_
        [ ("username", String "lol"),
          ("displayname", String "lol"),
          ("externalid", String "lol"),
          ("active", Bool True)
        ]
        $ \(key, upd) -> do
          let operation = Operation Replace (Just (NormalPath (AttrPath Nothing key Nothing))) (Just upd)
          let patchOp = PatchOp [operation]
          User.applyPatch user patchOp `shouldSatisfy` isRight
    it "does not support multi-value attributes" $ do
      let schemas' = []
      let extras = KeyMap.empty
      let user :: User PatchTag = User.empty schemas' "hello" extras
      for_
        [ ("schemas", toJSON @[Schema] mempty),
          ("name", toJSON @Name emptyName),
          ("nickName", toJSON @Text mempty),
          ("profileUrl", toJSON @URI (URI [uri|https://example.com|])),
          ("title", toJSON @Text mempty),
          ("userType", toJSON @Text mempty),
          ("preferredLanguage", toJSON @Text mempty),
          ("locale", toJSON @Text mempty),
          ("password", toJSON @Text mempty),
          ("emails", toJSON @[Email] mempty),
          ("phoneNumbers", toJSON @[Phone] mempty),
          ("ims", toJSON @[IM] mempty),
          ("photos", toJSON @[Photo] mempty),
          ("addresses", toJSON @[Address] mempty),
          ("entitlements", toJSON @[Text] mempty),
          ("x509Certificates", toJSON @[Certificate] mempty)
        ]
        $ \(key, upd) -> do
          let operation = Operation Replace (Just (NormalPath (AttrPath Nothing key Nothing))) (Just upd)
          let patchOp = PatchOp [operation]
          User.applyPatch user patchOp `shouldSatisfy` isLeft
    it "applies patch to `extra`" $ do
      let schemas' = []
      let extras = KeyMap.empty
      let user :: User PatchTag = User.empty schemas' "hello" extras
      let Right programmingLanguagePath = PatchOp.parsePath (User.supportedSchemas @PatchTag) "urn:hscim:test:programmingLanguage"
      let operation = Operation Replace (Just programmingLanguagePath) (Just (toJSON @Text "haskell"))
      let patchOp = PatchOp [operation]
      User.extra <$> User.applyPatch user patchOp `shouldBe` Right (KeyMap.singleton "programmingLanguage" "haskell")
  describe "JSON serialization" $ do
    it "handles all fields" $ do
      require prop_roundtrip
      toJSON completeUser `shouldBe` completeUserJson
      eitherDecode (encode completeUserJson) `shouldBe` Right completeUser
    it "has defaults for all optional and multi-valued fields" $ do
      toJSON minimalUser `shouldBe` minimalUserJson
      eitherDecode (encode minimalUserJson) `shouldBe` Right minimalUser
    it "treats 'null' and '[]' as absence of fields" $
      eitherDecode (encode minimalUserJsonRedundant)
        `shouldBe` Right minimalUser
    it "allows casing variations in field names" $ do
      require $ mk_prop_caseInsensitive genUser
      require $ mk_prop_caseInsensitive (ListResponse.fromList . (: []) <$> genStoredUser)
      eitherDecode (encode minimalUserJsonNonCanonical) `shouldBe` Right minimalUser
    it "doesn't require the 'schemas' field" $
      eitherDecode (encode minimalUserJsonNoSchemas)
        `shouldBe` Right minimalUser
    it "doesn't add 'extra' if it's an empty object" $ do
      toJSON (extendedUser UserExtraEmpty) `shouldBe` extendedUserEmptyJson
      eitherDecode (encode extendedUserEmptyJson)
        `shouldBe` Right (extendedUser UserExtraEmpty)
    it "encodes and decodes 'extra' correctly" $ do
      toJSON (extendedUser (UserExtraObject "foo")) `shouldBe` extendedUserObjectJson
      eitherDecode (encode extendedUserObjectJson)
        `shouldBe` Right (extendedUser (UserExtraObject "foo"))

genName :: Gen Name
genName =
  Name
    <$> Gen.maybe (Gen.text (Range.constant 0 20) Gen.unicode)
    <*> Gen.maybe (Gen.text (Range.constant 0 20) Gen.unicode)
    <*> Gen.maybe (Gen.text (Range.constant 0 20) Gen.unicode)
    <*> Gen.maybe (Gen.text (Range.constant 0 20) Gen.unicode)
    <*> Gen.maybe (Gen.text (Range.constant 0 20) Gen.unicode)
    <*> Gen.maybe (Gen.text (Range.constant 0 20) Gen.unicode)

genStoredUser :: Gen (UserClass.StoredUser (TestTag Text () () NoUserExtra))
genStoredUser = do
  m <- genMeta
  i <- Gen.element ["wef", "asdf", "@", "#", "1"]
  WithMeta m . WithId i <$> genUser

genMeta :: Gen Meta
genMeta =
  Meta
    <$> Gen.enumBounded
    <*> Gen.element [read "2021-08-23 13:13:31.450140036 UTC", read "2019-01-01 09:55:59 UTC"]
    <*> Gen.element [read "2021-08-23 13:13:31.450140036 UTC", read "2022-01-01 09:55:59 UTC"]
    <*> (Gen.element [Weak, Strong] <*> Gen.text (Range.constant 0 20) Gen.unicode)
    <*> genUri

-- TODO(arianvp) Generate the lists too, but first need better support for SCIM
-- lists in the first place
genUser :: Gen (User (TestTag Text () () NoUserExtra))
genUser = do
  let schemas' = [User20] -- TODO random schemas or?
  userName' <- Gen.text (Range.constant 0 20) Gen.unicode
  externalId' <- Gen.maybe $ Gen.text (Range.constant 0 20) Gen.unicode
  name' <- Gen.maybe genName
  displayName' <- Gen.maybe $ Gen.text (Range.constant 0 20) Gen.unicode
  nickName' <- Gen.maybe $ Gen.text (Range.constant 0 20) Gen.unicode
  profileUrl' <- Gen.maybe $ genUri
  title' <- Gen.maybe $ Gen.text (Range.constant 0 20) Gen.unicode
  userType' <- Gen.maybe $ Gen.text (Range.constant 0 20) Gen.unicode
  preferredLanguage' <- Gen.maybe $ Gen.text (Range.constant 0 20) Gen.unicode
  locale' <- Gen.maybe $ Gen.text (Range.constant 0 20) Gen.unicode
  active' <- Gen.maybe $ (ScimBool <$> Gen.bool)
  password' <- Gen.maybe $ Gen.text (Range.constant 0 20) Gen.unicode
  let emails' = [] -- Gen.list (Range.constant 0 20) genEmail
  let phoneNumbers' = [] -- Gen.list (Range.constant 0 20) genPhone
  let ims' = [] -- Gen.list (Range.constant 0 20) genIM
  let photos' = [] -- Gen.list (Range.constant 0 20) genPhoto
  let addresses' = [] -- Gen.list (Range.constant 0 20) genAddress
  let entitlements' = [] -- Gen.list (Range.constant 0 20) (Gen.text (Range.constant 0 20) Gen.unicode)
  let roles' = [] -- Gen.list (Range.constant 0 20) (Gen.text (Range.constant 0 10) Gen.unicode)
  let x509Certificates' = [] -- Gen.list (Range.constant 0 20) genCertificate
  pure $
    User
      { schemas = schemas',
        userName = userName',
        externalId = externalId',
        name = name',
        displayName = displayName',
        nickName = nickName',
        profileUrl = profileUrl',
        title = title',
        userType = userType',
        preferredLanguage = preferredLanguage',
        locale = locale',
        active = active',
        password = password',
        emails = emails',
        phoneNumbers = phoneNumbers',
        ims = ims',
        photos = photos',
        addresses = addresses',
        entitlements = entitlements',
        roles = roles',
        x509Certificates = x509Certificates',
        extra = NoUserExtra
      }

-- | A 'User' with all attributes present.
completeUser :: User (TestTag Text () () NoUserExtra)
completeUser =
  User
    { schemas = [User20],
      userName = "sample userName",
      externalId = Just "sample externalId",
      name =
        Just $
          Name
            { Name.formatted = Just "sample formatted name",
              Name.familyName = Nothing,
              Name.givenName = Nothing,
              Name.middleName = Nothing,
              Name.honorificPrefix = Nothing,
              Name.honorificSuffix = Nothing
            },
      displayName = Just "sample displayName",
      nickName = Just "sample nickName",
      profileUrl = Just (URI [uri|https://example.com|]),
      title = Just "sample title",
      userType = Just "sample userType",
      preferredLanguage = Just "da, en-gb;q=0.8, en;q=0.7",
      locale = Just "en-US",
      active = Just (ScimBool True),
      password = Just "sample password",
      emails =
        [ Email
            { Email.typ = Just "work",
              Email.value =
                maybe
                  (error "couldn't parse email")
                  EmailAddress
                  (emailAddress "user@example.com"),
              Email.primary = Nothing
            }
        ],
      phoneNumbers =
        [ Phone
            { Phone.typ = Just "work",
              Phone.value = Just "+15417543010"
            }
        ],
      ims =
        [ IM
            { IM.typ = Just "Wire",
              IM.value = Just "@user"
            }
        ],
      photos =
        [ Photo
            { Photo.typ = Just "userpic",
              Photo.value = Just (URI [uri|https://example.com/userpic.png|])
            }
        ],
      addresses =
        [ Address
            { Address.formatted = Just "sample Address",
              Address.streetAddress = Nothing,
              Address.locality = Nothing,
              Address.region = Nothing,
              Address.postalCode = Nothing,
              Address.country = Nothing,
              Address.typ = Just "home",
              Address.primary = Just (ScimBool True)
            }
        ],
      entitlements = ["sample entitlement"],
      roles = ["sample role"],
      x509Certificates =
        [ Certificate
            { Certificate.typ = Just "sample certificate type",
              Certificate.value = Just "sample certificate"
            }
        ],
      extra = NoUserExtra
    }

-- | Reference encoding of 'completeUser'.
completeUserJson :: Value
completeUserJson =
  [scim|
{
  "roles": [
    "sample role"
  ],
  "x509Certificates": [
    {
      "value": "sample certificate",
      "type": "sample certificate type"
    }
  ],
  "schemas": [
    "urn:ietf:params:scim:schemas:core:2.0:User"
  ],
  "locale": "en-US",
  "addresses": [
    {
      "formatted": "sample Address",
      "primary": true,
      "type": "home"
    }
  ],
  "userName": "sample userName",
  "phoneNumbers": [
    {
      "value": "+15417543010",
      "type": "work"
    }
  ],
  "active": true,
  "photos": [
    {
      "value": "https://example.com/userpic.png",
      "type": "userpic"
    }
  ],
  "name": {
    "formatted": "sample formatted name"
  },
  "password": "sample password",
  "emails": [
    {
      "value": "user@example.com",
      "type": "work"
    }
  ],
  "ims": [
    {
      "value": "@user",
      "type": "Wire"
    }
  ],
  "preferredLanguage": "da, en-gb;q=0.8, en;q=0.7",
  "entitlements": [
    "sample entitlement"
  ],
  "displayName": "sample displayName",
  "nickName": "sample nickName",
  "profileUrl": "https://example.com",
  "title": "sample title",
  "externalId": "sample externalId",
  "userType": "sample userType"
}
|]

-- | A 'User' with all attributes empty (if possible).
minimalUser :: User (TestTag Text () () NoUserExtra)
minimalUser = User.empty [User20] "sample userName" NoUserExtra

-- | Reference encoding of 'minimalUser'.
minimalUserJson :: Value
minimalUserJson =
  [scim|
{
  "schemas": [
    "urn:ietf:params:scim:schemas:core:2.0:User"
  ],
  "userName": "sample userName"
}
|]

-- | An encoding of 'minimalUser' with redundant @null@s and @[]@s for missing
-- fields.
minimalUserJsonRedundant :: Value
minimalUserJsonRedundant =
  [scim|
{
  "schemas": [
    "urn:ietf:params:scim:schemas:core:2.0:User"
  ],
  "roles": [],
  "x509Certificates": [],
  "locale": null,
  "addresses": [],
  "userName": "sample userName",
  "phoneNumbers": [],
  "active": null,
  "photos": [],
  "name": null,
  "password": null,
  "emails": [],
  "ims": [],
  "preferredLanguage": null,
  "entitlements": [],
  "displayName": null,
  "nickName": null,
  "profileUrl": null,
  "title": null,
  "externalId": null,
  "userType": null
}
|]

-- | An encoding of 'minimalUser' with non-canonical field name casing.
minimalUserJsonNonCanonical :: Value
minimalUserJsonNonCanonical =
  [scim|
{
  "schemas": [
    "urn:ietf:params:scim:schemas:core:2.0:User"
  ],
  "USERname": "sample userName"
}
|]

-- | An encoding of 'minimalUser' without the @schemas@ field.
minimalUserJsonNoSchemas :: Value
minimalUserJsonNoSchemas =
  [scim|
{
  "userName": "sample userName"
}
|]

data UserExtraTest = UserExtraEmpty | UserExtraObject {test :: Text}
  deriving (Show, Eq)

instance FromJSON UserExtraTest where
  parseJSON = withObject "UserExtraObject" $ \(lowercase -> o) -> do
    o .:? "urn:hscim:test" >>= \case
      Nothing -> pure UserExtraEmpty
      Just (lowercase -> o2) -> UserExtraObject <$> o2 .: "test"
    where
      lowercase = KeyMap.fromList . map (over _1 lowerKey) . KeyMap.toList

instance ToJSON UserExtraTest where
  toJSON UserExtraEmpty = object []
  toJSON (UserExtraObject t) =
    object ["urn:hscim:test" .= object ["test" .= t]]

instance Patchable UserExtraTest where
  applyOperation _ _ = undefined

-- | A 'User' with extra fields present.
extendedUser :: UserExtraTest -> User (TestTag Text () () UserExtraTest)
extendedUser e =
  User.empty [User20, CustomSchema "urn:hscim:test"] "sample userName" e

-- | Encoding of @extendedUser UserExtraEmpty@.
extendedUserEmptyJson :: Value
extendedUserEmptyJson =
  [scim|
{
  "schemas": [
    "urn:ietf:params:scim:schemas:core:2.0:User",
    "urn:hscim:test"
  ],
  "userName": "sample userName"
}
|]

-- | Encoding of @extendedUser (UserExtraObject "foo")@.
extendedUserObjectJson :: Value
extendedUserObjectJson =
  [scim|
{
  "schemas": [
    "urn:ietf:params:scim:schemas:core:2.0:User",
    "urn:hscim:test"
  ],
  "userName": "sample userName",
  "urn:hscim:test": {
    "test": "foo"
  }
}
|]