{-# LANGUAGE TemplateHaskell #-}

{-# OPTIONS -Wno-ambiguous-fields #-}
{-# OPTIONS -Wno-orphans #-}

-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2025 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 Wire.StoredUser where

import Data.Domain
import Data.Handle
import Data.Id
import Data.Json.Util
import Data.Qualified
import Data.Set qualified as S
import Database.CQL.Protocol (Record (..), TupleType, recordInstance)
import GHC.Records
import Imports
import Wire.API.Locale
import Wire.API.Password
import Wire.API.Provider.Service
import Wire.API.User
import Wire.Arbitrary

data StoredUser = StoredUser
  { id :: UserId,
    -- | Remove 'Maybe' from this when Cassandra support is removed
    userType :: Maybe UserType,
    name :: Name,
    textStatus :: Maybe TextStatus,
    pict :: Maybe Pict,
    email :: Maybe EmailAddress,
    emailUnvalidated :: Maybe EmailAddress,
    ssoId :: Maybe UserSSOId,
    accentId :: ColourId,
    assets :: Maybe [Asset],
    activated :: Bool,
    status :: Maybe AccountStatus,
    expires :: Maybe UTCTimeMillis,
    language :: Maybe Language,
    country :: Maybe Country,
    providerId :: Maybe ProviderId,
    serviceId :: Maybe ServiceId,
    handle :: Maybe Handle,
    teamId :: Maybe TeamId,
    managedBy :: Maybe ManagedBy,
    supportedProtocols :: Maybe (Set BaseProtocolTag),
    searchable :: Maybe Bool
  }
  deriving (Show, Eq, Ord, Generic)

instance Arbitrary StoredUser where
  arbitrary = do
    GenericUniform u <- arbitrary @(GenericUniform StoredUser)
    -- Ensure users are never bots and don't have service IDs
    let userType' = case u.userType of
          Just UserTypeBot -> Nothing -- Will be inferred as Regular
          other -> other
    pure $
      u
        { userType = userType',
          serviceId = Nothing,
          providerId = Nothing
        }

recordInstance ''StoredUser

setStoredUserName :: Name -> StoredUser -> StoredUser
setStoredUserName newName user = user {name = newName}

setStoredUserSupportedProtocols :: Set BaseProtocolTag -> StoredUser -> StoredUser
setStoredUserSupportedProtocols newProtocols user = user {supportedProtocols = Just newProtocols}

setStoredUserPict :: Pict -> StoredUser -> StoredUser
setStoredUserPict newPict user = user {pict = Just newPict}

setStoredUserAssets :: [Asset] -> StoredUser -> StoredUser
setStoredUserAssets newAssets user = user {assets = Just newAssets}

setStoredUserAccentId :: ColourId -> StoredUser -> StoredUser
setStoredUserAccentId newAccentId user = user {accentId = newAccentId}

setStoredUserLocale :: Locale -> StoredUser -> StoredUser
setStoredUserLocale newLocale user =
  user
    { language = Just newLocale.lLanguage,
      country = newLocale.lCountry
    }

setStoredUserHandle :: Handle -> StoredUser -> StoredUser
setStoredUserHandle newHandle user = user {handle = Just newHandle}

hasPendingInvitation :: StoredUser -> Bool
hasPendingInvitation u = u.status == Just PendingInvitation

mkUserFromStored :: Domain -> Locale -> StoredUser -> User
mkUserFromStored domain defaultLocale storedUser =
  let expiration = if storedUser.status == Just Ephemeral then storedUser.expires else Nothing
      loc = toLocale defaultLocale (storedUser.language, storedUser.country)
      svc = newServiceRef <$> storedUser.serviceId <*> storedUser.providerId
   in User
        { userQualifiedId = (Qualified storedUser.id domain),
          userType = inferUserType svc storedUser.userType,
          userIdentity = storedUser.identity,
          userEmailUnvalidated = storedUser.emailUnvalidated,
          userDisplayName = storedUser.name,
          userTextStatus = storedUser.textStatus,
          userPict = (fromMaybe noPict storedUser.pict),
          userAssets = (fromMaybe [] storedUser.assets),
          userAccentId = storedUser.accentId,
          userStatus = fromMaybe Active storedUser.status,
          userLocale = loc,
          userService = svc,
          userHandle = storedUser.handle,
          userExpire = expiration,
          userTeam = storedUser.teamId,
          userManagedBy = fromMaybe ManagedByWire storedUser.managedBy,
          userSupportedProtocols = case storedUser.supportedProtocols of
            Nothing -> defSupportedProtocols
            Just ps -> if S.null ps then defSupportedProtocols else ps,
          userSearchable = (fromMaybe True storedUser.searchable)
        }

-- | This function helps us avoid data migrations in cassandra: we
-- allow `User`s to have no type value for backwards compatibility.
-- The type is inferred as "bot" if there is a serviceId, and
-- "regular" otherwise.  For newly created apps, the second argument
-- will always be `Just`.
--
-- NB: The polymorphism is necessary because different caller have
-- different types of service ids in the `Maybe`.
inferUserType :: forall serviceId. Maybe serviceId -> Maybe UserType -> UserType
inferUserType _ (Just t) = t
inferUserType (Just _) Nothing = UserTypeBot
inferUserType Nothing Nothing = UserTypeRegular

toLocale :: Locale -> (Maybe Language, Maybe Country) -> Locale
toLocale _ (Just l, c) = Locale l c
toLocale l _ = l

toIdentity ::
  Maybe EmailAddress ->
  Maybe UserSSOId ->
  Maybe UserIdentity
toIdentity (Just e) Nothing = Just $! EmailIdentity e
toIdentity email (Just ssoid) = Just $! SSOIdentity ssoid email
toIdentity Nothing Nothing = Nothing

-- | If the user is not activated, 'toIdentity' will return 'Nothing', because
-- elsewhere we rely on the fact that a non-empty 'UserIdentity' means that the
-- user is activated.
--
-- FUTUREWORK(fisx): our account status representation is a mess.  we
-- have `activated` for personal users that have an invitation
-- pending; `status` for team members; sometimes no user identity
-- means not activated; and maybe more exceptions that i haven't found
-- today?  this needs to be cleaned up!
toIdentityIfActivated ::
  -- | Whether the user is activated
  Bool ->
  Maybe EmailAddress ->
  Maybe UserSSOId ->
  Maybe UserIdentity
toIdentityIfActivated True e s = toIdentity e s
toIdentityIfActivated False _ _ = Nothing

instance HasField "identity" StoredUser (Maybe UserIdentity) where
  getField user = toIdentityIfActivated user.activated user.email user.ssoId

instance HasField "locale" StoredUser (Maybe Locale) where
  getField user = Locale <$> user.language <*> pure user.country

--------------------------------------------------------------------------------

data NewStoredUser = NewStoredUser
  { id :: UserId,
    userType :: UserType,
    name :: Name,
    textStatus :: Maybe TextStatus,
    pict :: Pict,
    assets :: [Asset],
    email :: Maybe EmailAddress,
    ssoId :: Maybe UserSSOId,
    accentId :: ColourId,
    password :: Maybe Password,
    activated :: Bool,
    status :: AccountStatus,
    expires :: Maybe UTCTimeMillis,
    language :: Language,
    country :: Maybe Country,
    providerId :: Maybe ProviderId,
    serviceId :: Maybe ServiceId,
    handle :: Maybe Handle,
    teamId :: Maybe TeamId,
    managedBy :: ManagedBy,
    supportedProtocols :: Set BaseProtocolTag,
    searchable :: Bool
  }
  deriving (Show)

recordInstance ''NewStoredUser

-- addPrepQuery requires a Show instance for the input tuple type, but Show
-- instances are only defined up to 15 elements. Note that we can't use the
-- TupleType type family because type families in instance declarations are not
-- allowed.
deriving instance
  Show
    ( UserId,
      UserType,
      Name,
      Maybe TextStatus,
      Pict,
      [Asset],
      Maybe EmailAddress,
      Maybe UserSSOId,
      ColourId,
      Maybe Password,
      Bool,
      AccountStatus,
      Maybe UTCTimeMillis,
      Language,
      Maybe Country,
      Maybe ProviderId,
      Maybe ServiceId,
      Maybe Handle,
      Maybe TeamId,
      ManagedBy,
      Set BaseProtocolTag,
      Bool
    )

instance HasField "service" NewStoredUser (Maybe ServiceRef) where
  getField user = ServiceRef <$> user.serviceId <*> user.providerId

newStoredUserToStoredUser :: NewStoredUser -> StoredUser
newStoredUserToStoredUser new =
  StoredUser
    { id = new.id,
      userType = Just new.userType,
      name = new.name,
      textStatus = new.textStatus,
      pict = Just new.pict,
      email = new.email,
      emailUnvalidated = new.email,
      ssoId = new.ssoId,
      accentId = new.accentId,
      assets = Just new.assets,
      activated = new.activated,
      status = Just new.status,
      expires = new.expires,
      language = Just new.language,
      country = new.country,
      providerId = new.providerId,
      serviceId = new.serviceId,
      handle = new.handle,
      teamId = new.teamId,
      managedBy = Just new.managedBy,
      supportedProtocols = Just new.supportedProtocols,
      searchable = Just new.searchable
    }

-- This saves the identity from `NewStoredUser` even if the user is
-- not activated.
newStoredUserToUser :: Qualified NewStoredUser -> User
newStoredUserToUser (Qualified new domain) =
  User
    { userQualifiedId = Qualified new.id domain,
      userType = new.userType,
      userIdentity = toIdentity new.email new.ssoId,
      userEmailUnvalidated = Nothing,
      userDisplayName = new.name,
      userTextStatus = new.textStatus,
      userPict = new.pict,
      userAssets = new.assets,
      userAccentId = new.accentId,
      userStatus = new.status,
      userLocale = Locale new.language new.country,
      userService = newServiceRef <$> new.serviceId <*> new.providerId,
      userHandle = new.handle,
      userExpire = new.expires,
      userTeam = new.teamId,
      userManagedBy = new.managedBy,
      userSupportedProtocols = new.supportedProtocols,
      userSearchable = new.searchable
    }
