{-# LANGUAGE TemplateHaskell #-}

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.Provider.Service
import Wire.API.User
import Wire.Arbitrary

data StoredUser = StoredUser
  { StoredUser -> UserId
id :: UserId,
    StoredUser -> Name
name :: Name,
    StoredUser -> Maybe TextStatus
textStatus :: Maybe TextStatus,
    StoredUser -> Maybe Pict
pict :: Maybe Pict,
    StoredUser -> Maybe EmailAddress
email :: Maybe EmailAddress,
    StoredUser -> Maybe EmailAddress
emailUnvalidated :: Maybe EmailAddress,
    StoredUser -> Maybe UserSSOId
ssoId :: Maybe UserSSOId,
    StoredUser -> ColourId
accentId :: ColourId,
    StoredUser -> Maybe [Asset]
assets :: Maybe [Asset],
    StoredUser -> Bool
activated :: Bool,
    StoredUser -> Maybe AccountStatus
status :: Maybe AccountStatus,
    StoredUser -> Maybe UTCTimeMillis
expires :: Maybe UTCTimeMillis,
    StoredUser -> Maybe Language
language :: Maybe Language,
    StoredUser -> Maybe Country
country :: Maybe Country,
    StoredUser -> Maybe ProviderId
providerId :: Maybe ProviderId,
    StoredUser -> Maybe ServiceId
serviceId :: Maybe ServiceId,
    StoredUser -> Maybe Handle
handle :: Maybe Handle,
    StoredUser -> Maybe TeamId
teamId :: Maybe TeamId,
    StoredUser -> Maybe ManagedBy
managedBy :: Maybe ManagedBy,
    StoredUser -> Maybe (Set BaseProtocolTag)
supportedProtocols :: Maybe (Set BaseProtocolTag)
  }
  deriving (Int -> StoredUser -> ShowS
[StoredUser] -> ShowS
StoredUser -> String
(Int -> StoredUser -> ShowS)
-> (StoredUser -> String)
-> ([StoredUser] -> ShowS)
-> Show StoredUser
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StoredUser -> ShowS
showsPrec :: Int -> StoredUser -> ShowS
$cshow :: StoredUser -> String
show :: StoredUser -> String
$cshowList :: [StoredUser] -> ShowS
showList :: [StoredUser] -> ShowS
Show, StoredUser -> StoredUser -> Bool
(StoredUser -> StoredUser -> Bool)
-> (StoredUser -> StoredUser -> Bool) -> Eq StoredUser
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: StoredUser -> StoredUser -> Bool
== :: StoredUser -> StoredUser -> Bool
$c/= :: StoredUser -> StoredUser -> Bool
/= :: StoredUser -> StoredUser -> Bool
Eq, Eq StoredUser
Eq StoredUser =>
(StoredUser -> StoredUser -> Ordering)
-> (StoredUser -> StoredUser -> Bool)
-> (StoredUser -> StoredUser -> Bool)
-> (StoredUser -> StoredUser -> Bool)
-> (StoredUser -> StoredUser -> Bool)
-> (StoredUser -> StoredUser -> StoredUser)
-> (StoredUser -> StoredUser -> StoredUser)
-> Ord StoredUser
StoredUser -> StoredUser -> Bool
StoredUser -> StoredUser -> Ordering
StoredUser -> StoredUser -> StoredUser
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: StoredUser -> StoredUser -> Ordering
compare :: StoredUser -> StoredUser -> Ordering
$c< :: StoredUser -> StoredUser -> Bool
< :: StoredUser -> StoredUser -> Bool
$c<= :: StoredUser -> StoredUser -> Bool
<= :: StoredUser -> StoredUser -> Bool
$c> :: StoredUser -> StoredUser -> Bool
> :: StoredUser -> StoredUser -> Bool
$c>= :: StoredUser -> StoredUser -> Bool
>= :: StoredUser -> StoredUser -> Bool
$cmax :: StoredUser -> StoredUser -> StoredUser
max :: StoredUser -> StoredUser -> StoredUser
$cmin :: StoredUser -> StoredUser -> StoredUser
min :: StoredUser -> StoredUser -> StoredUser
Ord, (forall x. StoredUser -> Rep StoredUser x)
-> (forall x. Rep StoredUser x -> StoredUser) -> Generic StoredUser
forall x. Rep StoredUser x -> StoredUser
forall x. StoredUser -> Rep StoredUser x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. StoredUser -> Rep StoredUser x
from :: forall x. StoredUser -> Rep StoredUser x
$cto :: forall x. Rep StoredUser x -> StoredUser
to :: forall x. Rep StoredUser x -> StoredUser
Generic)
  deriving (Gen StoredUser
Gen StoredUser
-> (StoredUser -> [StoredUser]) -> Arbitrary StoredUser
StoredUser -> [StoredUser]
forall a. Gen a -> (a -> [a]) -> Arbitrary a
$carbitrary :: Gen StoredUser
arbitrary :: Gen StoredUser
$cshrink :: StoredUser -> [StoredUser]
shrink :: StoredUser -> [StoredUser]
Arbitrary) via (GenericUniform StoredUser)

recordInstance ''StoredUser

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

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

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

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

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

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

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

hasPendingInvitation :: StoredUser -> Bool
hasPendingInvitation :: StoredUser -> Bool
hasPendingInvitation StoredUser
u = StoredUser
u.status Maybe AccountStatus -> Maybe AccountStatus -> Bool
forall a. Eq a => a -> a -> Bool
== AccountStatus -> Maybe AccountStatus
forall a. a -> Maybe a
Just AccountStatus
PendingInvitation

mkUserFromStored :: Domain -> Locale -> StoredUser -> User
mkUserFromStored :: Domain -> Locale -> StoredUser -> User
mkUserFromStored Domain
domain Locale
defaultLocale StoredUser
storedUser =
  let expiration :: Maybe UTCTimeMillis
expiration = if StoredUser
storedUser.status Maybe AccountStatus -> Maybe AccountStatus -> Bool
forall a. Eq a => a -> a -> Bool
== AccountStatus -> Maybe AccountStatus
forall a. a -> Maybe a
Just AccountStatus
Ephemeral then StoredUser
storedUser.expires else Maybe UTCTimeMillis
forall a. Maybe a
Nothing
      loc :: Locale
loc = Locale -> (Maybe Language, Maybe Country) -> Locale
toLocale Locale
defaultLocale (StoredUser
storedUser.language, StoredUser
storedUser.country)
      svc :: Maybe ServiceRef
svc = ServiceId -> ProviderId -> ServiceRef
newServiceRef (ServiceId -> ProviderId -> ServiceRef)
-> Maybe ServiceId -> Maybe (ProviderId -> ServiceRef)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StoredUser
storedUser.serviceId Maybe (ProviderId -> ServiceRef)
-> Maybe ProviderId -> Maybe ServiceRef
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StoredUser
storedUser.providerId
   in User
        { $sel:userQualifiedId:User :: Qualified UserId
userQualifiedId = (UserId -> Domain -> Qualified UserId
forall a. a -> Domain -> Qualified a
Qualified StoredUser
storedUser.id Domain
domain),
          $sel:userIdentity:User :: Maybe UserIdentity
userIdentity = StoredUser
storedUser.identity,
          $sel:userEmailUnvalidated:User :: Maybe EmailAddress
userEmailUnvalidated = StoredUser
storedUser.emailUnvalidated,
          $sel:userDisplayName:User :: Name
userDisplayName = StoredUser
storedUser.name,
          $sel:userTextStatus:User :: Maybe TextStatus
userTextStatus = StoredUser
storedUser.textStatus,
          $sel:userPict:User :: Pict
userPict = (Pict -> Maybe Pict -> Pict
forall a. a -> Maybe a -> a
fromMaybe Pict
noPict StoredUser
storedUser.pict),
          $sel:userAssets:User :: [Asset]
userAssets = ([Asset] -> Maybe [Asset] -> [Asset]
forall a. a -> Maybe a -> a
fromMaybe [] StoredUser
storedUser.assets),
          $sel:userAccentId:User :: ColourId
userAccentId = StoredUser
storedUser.accentId,
          $sel:userStatus:User :: AccountStatus
userStatus = AccountStatus -> Maybe AccountStatus -> AccountStatus
forall a. a -> Maybe a -> a
fromMaybe AccountStatus
Active StoredUser
storedUser.status,
          $sel:userLocale:User :: Locale
userLocale = Locale
loc,
          $sel:userService:User :: Maybe ServiceRef
userService = Maybe ServiceRef
svc,
          $sel:userHandle:User :: Maybe Handle
userHandle = StoredUser
storedUser.handle,
          $sel:userExpire:User :: Maybe UTCTimeMillis
userExpire = Maybe UTCTimeMillis
expiration,
          $sel:userTeam:User :: Maybe TeamId
userTeam = StoredUser
storedUser.teamId,
          $sel:userManagedBy:User :: ManagedBy
userManagedBy = ManagedBy -> Maybe ManagedBy -> ManagedBy
forall a. a -> Maybe a -> a
fromMaybe ManagedBy
ManagedByWire StoredUser
storedUser.managedBy,
          $sel:userSupportedProtocols:User :: Set BaseProtocolTag
userSupportedProtocols = case StoredUser
storedUser.supportedProtocols of
            Maybe (Set BaseProtocolTag)
Nothing -> Set BaseProtocolTag
defSupportedProtocols
            Just Set BaseProtocolTag
ps -> if Set BaseProtocolTag -> Bool
forall a. Set a -> Bool
S.null Set BaseProtocolTag
ps then Set BaseProtocolTag
defSupportedProtocols else Set BaseProtocolTag
ps
        }

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

-- | If the user is not activated, 'toIdentity' will return 'Nothing' as a
-- precaution, because elsewhere we rely on the fact that a non-empty
-- 'UserIdentity' means that the user is activated.
--
-- The reason it's just a "precaution" is that we /also/ have an invariant that
-- having an email or phone in the database means the user has to be activated.
toIdentity ::
  -- | Whether the user is activated
  Bool ->
  Maybe EmailAddress ->
  Maybe UserSSOId ->
  Maybe UserIdentity
toIdentity :: Bool -> Maybe EmailAddress -> Maybe UserSSOId -> Maybe UserIdentity
toIdentity Bool
True (Just EmailAddress
e) Maybe UserSSOId
Nothing = UserIdentity -> Maybe UserIdentity
forall a. a -> Maybe a
Just (UserIdentity -> Maybe UserIdentity)
-> UserIdentity -> Maybe UserIdentity
forall a b. (a -> b) -> a -> b
$! EmailAddress -> UserIdentity
EmailIdentity EmailAddress
e
toIdentity Bool
True Maybe EmailAddress
email (Just UserSSOId
ssoid) = UserIdentity -> Maybe UserIdentity
forall a. a -> Maybe a
Just (UserIdentity -> Maybe UserIdentity)
-> UserIdentity -> Maybe UserIdentity
forall a b. (a -> b) -> a -> b
$! UserSSOId -> Maybe EmailAddress -> UserIdentity
SSOIdentity UserSSOId
ssoid Maybe EmailAddress
email
toIdentity Bool
True Maybe EmailAddress
Nothing Maybe UserSSOId
Nothing = Maybe UserIdentity
forall a. Maybe a
Nothing
toIdentity Bool
False Maybe EmailAddress
_ Maybe UserSSOId
_ = Maybe UserIdentity
forall a. Maybe a
Nothing

instance HasField "identity" StoredUser (Maybe UserIdentity) where
  getField :: StoredUser -> Maybe UserIdentity
getField StoredUser
user = Bool -> Maybe EmailAddress -> Maybe UserSSOId -> Maybe UserIdentity
toIdentity StoredUser
user.activated StoredUser
user.email StoredUser
user.ssoId

instance HasField "locale" StoredUser (Maybe Locale) where
  getField :: StoredUser -> Maybe Locale
getField StoredUser
user = Language -> Maybe Country -> Locale
Locale (Language -> Maybe Country -> Locale)
-> Maybe Language -> Maybe (Maybe Country -> Locale)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StoredUser
user.language Maybe (Maybe Country -> Locale)
-> Maybe (Maybe Country) -> Maybe Locale
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Country -> Maybe (Maybe Country)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure StoredUser
user.country