content: {-# LANGUAGE GADTs #-}
  {-# LANGUAGE RecordWildCards #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  {-# LANGUAGE StandaloneDeriving #-}
  {-# LANGUAGE UndecidableInstances #-}
  
  -- 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/>.
  
  -- | SCIM user representation.
  --
  -- = Our interpretation of the spec
  --
  -- The spec can be read at <https://tools.ietf.org/html/rfc7643#section-4.1>.
  -- While implementing the spec we had to resolve some ambiguities and place some
  -- additional constraints on the possible SCIM server behavior we can support.
  --
  -- == Resource ID / user ID
  --
  -- The 'User' object doesn't contain a user ID (as in "opaque server-assigned
  -- immutable ID") by design. IDs and metadata are added to types in a uniform
  -- fashion by using @WithId@ and @WithMeta@.
  --
  -- == Optional fields
  --
  -- The spec only mandates the @userName@ and @id@ attribute. All other
  -- attributes seem optional.
  --
  -- == Multi-valued fields
  --
  -- When a multi-valued field (e.g. @emails@) doesn't contain any values, it's
  -- unclear whether we should serialize it as @[]@ or omit it entirely. We have
  -- opted for the latter to conform to an example in the spec:
  -- <https://tools.ietf.org/html/rfc7644#section-3.5.1>.
  --
  -- TODO(arianvp):
  --  Multi-valued attributes actually have some more quirky semantics that we
  --  currently don't support yet. E.g. if the multi-values have a
  --  'primary' field then only one of the entires must have 'primary: true'
  --  and all the others are either implied 'primary: false' or must be checked
  --  that they're false
  --
  --
  -- == Attribute names
  --
  -- When parsing JSON objects, we ignore capitalization differences in field
  -- names -- e.g. both @USERNAME@ and @userName@ are accepted.
  --  This is described by the spec  https://tools.ietf.org/html/rfc7643#section-2.1
  module Web.Scim.Schema.User
    ( User (..),
      empty,
      NoUserExtra (..),
      applyPatch,
      resultToScimError,
      isUserSchema,
      module Web.Scim.Schema.UserTypes,
    )
  where
  
  import Control.Monad
  import Control.Monad.Except
  import Data.Aeson
  import qualified Data.Aeson.Key as Key
  import qualified Data.Aeson.KeyMap as KeyMap
  import Data.List ((\\))
  import Data.Text (Text, pack)
  import qualified Data.Text as Text
  import GHC.Generics (Generic)
  import Lens.Micro
  import Web.Scim.AttrName
  import Web.Scim.Filter (AttrPath (..))
  import Web.Scim.Schema.Common
  import Web.Scim.Schema.Error
  import Web.Scim.Schema.PatchOp
  import Web.Scim.Schema.Schema (Schema (..), getSchemaUri)
  import Web.Scim.Schema.User.Address (Address)
  import Web.Scim.Schema.User.Certificate (Certificate)
  import Web.Scim.Schema.User.Email (Email)
  import Web.Scim.Schema.User.IM (IM)
  import Web.Scim.Schema.User.Name (Name)
  import Web.Scim.Schema.User.Phone (Phone)
  import Web.Scim.Schema.User.Photo (Photo)
  import Web.Scim.Schema.UserTypes
  
  -- | SCIM user record, parametrized with type-level @tag@ (see 'UserTypes').
  data User tag = User
    { schemas :: [Schema],
      -- Mandatory fields
      userName :: Text,
      -- Optional fields
      externalId :: Maybe Text,
      name :: Maybe Name,
      displayName :: Maybe Text,
      nickName :: Maybe Text,
      profileUrl :: Maybe URI,
      title :: Maybe Text,
      userType :: Maybe Text,
      preferredLanguage :: Maybe Text,
      locale :: Maybe Text,
      active :: Maybe ScimBool,
      password :: Maybe Text,
      -- Multi-valued fields
      emails :: [Email],
      phoneNumbers :: [Phone],
      ims :: [IM],
      photos :: [Photo],
      addresses :: [Address],
      entitlements :: [Text],
      roles :: [Text],
      x509Certificates :: [Certificate],
      -- Extra data.
      --
      -- During rendering, we'll convert it to JSON; if it's an object we'll merge it with the
      -- main user object, if it's @null@ we'll do nothing, otherwise we'll add it under the
      -- @"extra"@ field (though you should definitely not rely on this).
      --
      -- During parsing, we'll attempt to parse the /whole/ user object as @extra@, so your
      -- 'FromJSON' instance should be prepared to ignore unrelated fields. Also keep in mind that
      -- the SCIM spec requires field names to be case-insensitive, i.e. if you're looking for a
      -- field "foo" you should also handle a field called "FOO". Look at the @FromJSON User@
      -- instance to see how it can be done.
      --
      -- FUTUREWORK: make it easy for hscim users to implement a proper parser (with correct
      -- rendering of optional and multivalued fields, lowercase objects, etc).
      extra :: UserExtra tag
    }
    deriving (Generic)
  
  deriving instance (Show (UserExtra tag)) => Show (User tag)
  
  deriving instance (Eq (UserExtra tag)) => Eq (User tag)
  
  empty ::
    -- | Schemas
    [Schema] ->
    -- | userName
    Text ->
    -- | Extra data
    UserExtra tag ->
    User tag
  empty schemas userName extra =
    User
      { schemas = schemas,
        userName = userName,
        externalId = Nothing,
        name = Nothing,
        displayName = Nothing,
        nickName = Nothing,
        profileUrl = Nothing,
        title = Nothing,
        userType = Nothing,
        preferredLanguage = Nothing,
        locale = Nothing,
        active = Nothing,
        password = Nothing,
        emails = [],
        phoneNumbers = [],
        ims = [],
        photos = [],
        addresses = [],
        entitlements = [],
        roles = [],
        x509Certificates = [],
        extra = extra
      }
  
  instance (FromJSON (UserExtra tag)) => FromJSON (User tag) where
    parseJSON = withObject "User" $ \obj -> do
      -- Lowercase all fields
      let o = KeyMap.fromList . map (over _1 lowerKey) . KeyMap.toList $ obj
      schemas <-
        o .:? "schemas" <&> \case
          Nothing -> [User20]
          Just xs -> if User20 `elem` xs then xs else User20 : xs
      userName <- o .: "username"
      externalId <- o .:? "externalid"
      name <- o .:? "name"
      displayName <- o .:? "displayname"
      nickName <- o .:? "nickname"
      profileUrl <- o .:? "profileurl"
      title <- o .:? "title"
      userType <- o .:? "usertype"
      preferredLanguage <- o .:? "preferredlanguage"
      locale <- o .:? "locale"
      active <- o .:? "active"
      password <- o .:? "password"
      emails <- o .:? "emails" .!= []
      phoneNumbers <- o .:? "phonenumbers" .!= []
      ims <- o .:? "ims" .!= []
      photos <- o .:? "photos" .!= []
      addresses <- o .:? "addresses" .!= []
      entitlements <- o .:? "entitlements" .!= []
      roles <- o .:? "roles" .!= []
      x509Certificates <- o .:? "x509certificates" .!= []
      extra <- parseJSON (Object obj)
      pure User {..}
  
  instance (ToJSON (UserExtra tag)) => ToJSON (User tag) where
    toJSON User {..} =
      let mainObject =
            KeyMap.fromList $
              concat
                [ ["schemas" .= schemas],
                  ["userName" .= userName],
                  optionalField "externalId" externalId,
                  optionalField "name" name,
                  optionalField "displayName" displayName,
                  optionalField "nickName" nickName,
                  optionalField "profileUrl" profileUrl,
                  optionalField "title" title,
                  optionalField "userType" userType,
                  optionalField "preferredLanguage" preferredLanguage,
                  optionalField "locale" locale,
                  optionalField "active" active,
                  optionalField "password" password,
                  multiValuedField "emails" emails,
                  multiValuedField "phoneNumbers" phoneNumbers,
                  multiValuedField "ims" ims,
                  multiValuedField "photos" photos,
                  multiValuedField "addresses" addresses,
                  multiValuedField "entitlements" entitlements,
                  multiValuedField "roles" roles,
                  multiValuedField "x509Certificates" x509Certificates
                ]
          extraObject = case toJSON extra of
            Null -> mempty
            Object x -> x
            other -> KeyMap.fromList ["extra" .= other]
       in Object (KeyMap.union mainObject extraObject)
      where
        -- Omit a field if it's Nothing
        optionalField fname = \case
          Nothing -> []
          Just x -> [fname .= x]
        -- Omit a field if it's []
        multiValuedField fname = \case
          [] -> []
          xs -> [fname .= xs]
  
  -- | A type used to indicate that the SCIM record doesn't have any extra data. Encoded as an
  -- empty map.
  data NoUserExtra = NoUserExtra
    deriving (Eq, Show)
  
  instance FromJSON NoUserExtra where
    parseJSON = withObject "NoUserExtra" $ \_ -> pure NoUserExtra
  
  instance ToJSON NoUserExtra where
    toJSON _ = object []
  
  instance Patchable NoUserExtra where
    applyOperation _ _ = throwError $ badRequest InvalidValue (Just "there are no user extra attributes to patch")
  
  ----------------------------------------------------------------------------
  -- Applying
  
  -- | Applies a JSON Patch to a SCIM Core User
  -- Only supports the core attributes.
  -- Evenmore, only some hand-picked ones currently.
  -- We'll have to think how patch is going to work in the presence of extensions.
  -- Also, we can probably make  PatchOp type-safe to some extent (Read arianvp's thesis :))
  applyPatch ::
    ( Patchable (UserExtra tag),
      FromJSON (UserExtra tag),
      MonadError ScimError m,
      UserTypes tag
    ) =>
    User tag ->
    PatchOp tag ->
    m (User tag)
  applyPatch = (. getOperations) . foldM applyOperation
  
  resultToScimError :: (MonadError ScimError m) => Result a -> m a
  resultToScimError (Error reason) = throwError $ badRequest InvalidValue (Just (pack reason))
  resultToScimError (Success a) = pure a
  
  -- TODO(arianvp): support multi-valued and complex attributes.
  -- TODO(arianvp): Actually do this in some kind of type-safe way. e.g.
  -- have a UserPatch type.
  --
  -- What I understand from the spec:  The difference between add an replace is only
  -- in the fact that replace will not concat multi-values, and behaves differently for complex values too.
  -- For simple attributes, add and replace are identical.
  applyUserOperation ::
    forall m tag.
    ( UserTypes tag,
      FromJSON (User tag),
      Patchable (UserExtra tag),
      MonadError ScimError m
    ) =>
    User tag ->
    Operation ->
    m (User tag)
  applyUserOperation user (Operation Add path value) = applyUserOperation user (Operation Replace path value)
  applyUserOperation user (Operation Replace (Just (NormalPath (AttrPath _schema attr _subAttr))) (Just value)) =
    case attr of
      "username" ->
        (\x -> user {userName = x}) <$> resultToScimError (fromJSON value)
      "displayname" ->
        (\x -> user {displayName = x}) <$> resultToScimError (fromJSON value)
      "externalid" ->
        (\x -> user {externalId = x}) <$> resultToScimError (fromJSON value)
      "active" ->
        (\x -> user {active = x}) <$> resultToScimError (fromJSON value)
      "roles" ->
        (\x -> user {roles = x}) <$> resultToScimError (fromJSON value)
      _ -> throwError (badRequest InvalidPath (Just "we only support attributes username, displayname, externalid, active, roles"))
  applyUserOperation _ (Operation Replace (Just (IntoValuePath _ _)) _) = do
    throwError (badRequest InvalidPath (Just "can not lens into multi-valued attributes yet"))
  applyUserOperation user (Operation Replace Nothing (Just value)) = do
    case value of
      Object hm | null ((AttrName . Key.toText <$> KeyMap.keys hm) \\ ["username", "displayname", "externalid", "active", "roles"]) -> do
        (u :: User tag) <- resultToScimError $ fromJSON value
        pure $
          user
            { userName = userName u,
              displayName = displayName u,
              externalId = externalId u,
              active = active u
            }
      _ -> throwError (badRequest InvalidPath (Just "we only support attributes username, displayname, externalid, active, roles"))
  applyUserOperation _ (Operation Replace _ Nothing) =
    throwError (badRequest InvalidValue (Just "No value was provided"))
  applyUserOperation _ (Operation Remove Nothing _) = throwError (badRequest NoTarget Nothing)
  applyUserOperation user (Operation Remove (Just (NormalPath (AttrPath _schema attr _subAttr))) _value) =
    case attr of
      "username" -> throwError (badRequest Mutability Nothing)
      "displayname" -> pure $ user {displayName = Nothing}
      "externalid" -> pure $ user {externalId = Nothing}
      "active" -> pure $ user {active = Nothing}
      "roles" -> pure $ user {roles = []}
      _ -> pure user
  applyUserOperation _ (Operation Remove (Just (IntoValuePath _ _)) _) = do
    throwError (badRequest InvalidPath (Just "can not lens into multi-valued attributes yet"))
  
  instance (UserTypes tag, FromJSON (User tag), Patchable (UserExtra tag)) => Patchable (User tag) where
    applyOperation user op@(Operation _ (Just (NormalPath (AttrPath schema _ _))) _)
      | isUserSchema schema = applyUserOperation user op
      | isSupportedCustomSchema schema = (\x -> user {extra = x}) <$> applyOperation (extra user) op
      | otherwise =
          throwError $ badRequest InvalidPath $ Just $ "we only support these schemas: " <> Text.intercalate ", " (map getSchemaUri (supportedSchemas @tag))
      where
        isSupportedCustomSchema = maybe False (`elem` supportedSchemas @tag)
    applyOperation user op = applyUserOperation user op
  
  -- Omission of a schema for users is implicitly the core schema
  -- TODO(arianvp): Link to part of the spec that claims this.
  isUserSchema :: Maybe Schema -> Bool
  isUserSchema = maybe True (== User20)
  