module Wire.TeamInvitationSubsystem.Interpreter where

import Control.Arrow ((&&&))
import Control.Error (MaybeT (..))
import Data.ByteString.Conversion (toByteString')
import Data.Id
import Data.Qualified
import Data.Set qualified as Set
import Data.Text.Ascii qualified as AsciiText
import Data.Text.Encoding qualified as Text
import Imports
import Polysemy
import Polysemy.Error
import Polysemy.Input (Input, input, runInputConst)
import Polysemy.TinyLog
import System.Logger.Message as Log
import URI.ByteString
import Util.Logging
import Util.Timeout (Timeout (..))
import Wire.API.Team.Invitation
import Wire.API.Team.Member
import Wire.API.Team.Member qualified as Teams
import Wire.API.Team.Permission
import Wire.API.Team.Role
import Wire.API.User
import Wire.Arbitrary
import Wire.EmailSubsystem
import Wire.GalleyAPIAccess hiding (AddTeamMember)
import Wire.GalleyAPIAccess qualified as GalleyAPIAccess
import Wire.InvitationStore (InvitationStore, StoredInvitation)
import Wire.InvitationStore qualified as Store
import Wire.Sem.Logger qualified as Log
import Wire.Sem.Now (Now)
import Wire.Sem.Now qualified as Now
import Wire.Sem.Random (Random)
import Wire.Sem.Random qualified as Random
import Wire.TeamInvitationSubsystem
import Wire.TeamInvitationSubsystem.Error
import Wire.UserKeyStore
import Wire.UserSubsystem (UserSubsystem, getLocalUserAccountByUserKey, getSelfProfile, isBlocked)

data TeamInvitationSubsystemConfig = TeamInvitationSubsystemConfig
  { TeamInvitationSubsystemConfig -> Word32
maxTeamSize :: Word32,
    TeamInvitationSubsystemConfig -> Timeout
teamInvitationTimeout :: Timeout
  }
  deriving (Int -> TeamInvitationSubsystemConfig -> ShowS
[TeamInvitationSubsystemConfig] -> ShowS
TeamInvitationSubsystemConfig -> String
(Int -> TeamInvitationSubsystemConfig -> ShowS)
-> (TeamInvitationSubsystemConfig -> String)
-> ([TeamInvitationSubsystemConfig] -> ShowS)
-> Show TeamInvitationSubsystemConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TeamInvitationSubsystemConfig -> ShowS
showsPrec :: Int -> TeamInvitationSubsystemConfig -> ShowS
$cshow :: TeamInvitationSubsystemConfig -> String
show :: TeamInvitationSubsystemConfig -> String
$cshowList :: [TeamInvitationSubsystemConfig] -> ShowS
showList :: [TeamInvitationSubsystemConfig] -> ShowS
Show, (forall x.
 TeamInvitationSubsystemConfig
 -> Rep TeamInvitationSubsystemConfig x)
-> (forall x.
    Rep TeamInvitationSubsystemConfig x
    -> TeamInvitationSubsystemConfig)
-> Generic TeamInvitationSubsystemConfig
forall x.
Rep TeamInvitationSubsystemConfig x
-> TeamInvitationSubsystemConfig
forall x.
TeamInvitationSubsystemConfig
-> Rep TeamInvitationSubsystemConfig x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x.
TeamInvitationSubsystemConfig
-> Rep TeamInvitationSubsystemConfig x
from :: forall x.
TeamInvitationSubsystemConfig
-> Rep TeamInvitationSubsystemConfig x
$cto :: forall x.
Rep TeamInvitationSubsystemConfig x
-> TeamInvitationSubsystemConfig
to :: forall x.
Rep TeamInvitationSubsystemConfig x
-> TeamInvitationSubsystemConfig
Generic)
  deriving (Gen TeamInvitationSubsystemConfig
Gen TeamInvitationSubsystemConfig
-> (TeamInvitationSubsystemConfig
    -> [TeamInvitationSubsystemConfig])
-> Arbitrary TeamInvitationSubsystemConfig
TeamInvitationSubsystemConfig -> [TeamInvitationSubsystemConfig]
forall a. Gen a -> (a -> [a]) -> Arbitrary a
$carbitrary :: Gen TeamInvitationSubsystemConfig
arbitrary :: Gen TeamInvitationSubsystemConfig
$cshrink :: TeamInvitationSubsystemConfig -> [TeamInvitationSubsystemConfig]
shrink :: TeamInvitationSubsystemConfig -> [TeamInvitationSubsystemConfig]
Arbitrary) via GenericUniform TeamInvitationSubsystemConfig

runTeamInvitationSubsystem ::
  ( Member (Error TeamInvitationSubsystemError) r,
    Member TinyLog r,
    Member GalleyAPIAccess r,
    Member UserSubsystem r,
    Member Random r,
    Member InvitationStore r,
    Member Now r,
    Member EmailSubsystem r
  ) =>
  TeamInvitationSubsystemConfig ->
  InterpreterFor TeamInvitationSubsystem r
runTeamInvitationSubsystem :: forall (r :: EffectRow).
(Member (Error TeamInvitationSubsystemError) r, Member TinyLog r,
 Member GalleyAPIAccess r, Member UserSubsystem r, Member Random r,
 Member InvitationStore r, Member Now r, Member EmailSubsystem r) =>
TeamInvitationSubsystemConfig
-> InterpreterFor TeamInvitationSubsystem r
runTeamInvitationSubsystem TeamInvitationSubsystemConfig
cfg = (forall (rInitial :: EffectRow) x.
 TeamInvitationSubsystem (Sem rInitial) x -> Sem r x)
-> Sem (TeamInvitationSubsystem : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
FirstOrder e "interpret" =>
(forall (rInitial :: EffectRow) x. e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret ((forall (rInitial :: EffectRow) x.
  TeamInvitationSubsystem (Sem rInitial) x -> Sem r x)
 -> Sem (TeamInvitationSubsystem : r) a -> Sem r a)
-> (forall (rInitial :: EffectRow) x.
    TeamInvitationSubsystem (Sem rInitial) x -> Sem r x)
-> Sem (TeamInvitationSubsystem : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ \case
  InviteUser Local UserId
luid TeamId
tid InvitationRequest
request -> TeamInvitationSubsystemConfig
-> Sem (Input TeamInvitationSubsystemConfig : r) x -> Sem r x
forall i (r :: EffectRow) a. i -> Sem (Input i : r) a -> Sem r a
runInputConst TeamInvitationSubsystemConfig
cfg (Sem (Input TeamInvitationSubsystemConfig : r) x -> Sem r x)
-> Sem (Input TeamInvitationSubsystemConfig : r) x -> Sem r x
forall a b. (a -> b) -> a -> b
$ Local UserId
-> TeamId
-> InvitationRequest
-> Sem
     (Input TeamInvitationSubsystemConfig : r)
     (Invitation, InvitationLocation)
forall (r :: EffectRow).
(Member (Error TeamInvitationSubsystemError) r,
 Member GalleyAPIAccess r, Member UserSubsystem r, Member TinyLog r,
 Member Random r, Member InvitationStore r,
 Member (Input TeamInvitationSubsystemConfig) r, Member Now r,
 Member EmailSubsystem r) =>
Local UserId
-> TeamId
-> InvitationRequest
-> Sem r (Invitation, InvitationLocation)
inviteUserImpl Local UserId
luid TeamId
tid InvitationRequest
request
  InternalCreateInvitation TeamId
tid Maybe InvitationId
mExpectedInvId Role
role Local (Maybe UserId)
mbInviterUid EmailAddress
inviterEmail InvitationRequest
invRequest ->
    TeamInvitationSubsystemConfig
-> Sem (Input TeamInvitationSubsystemConfig : r) x -> Sem r x
forall i (r :: EffectRow) a. i -> Sem (Input i : r) a -> Sem r a
runInputConst TeamInvitationSubsystemConfig
cfg (Sem (Input TeamInvitationSubsystemConfig : r) x -> Sem r x)
-> Sem (Input TeamInvitationSubsystemConfig : r) x -> Sem r x
forall a b. (a -> b) -> a -> b
$ TeamId
-> Maybe InvitationId
-> Role
-> Local (Maybe UserId)
-> EmailAddress
-> InvitationRequest
-> Sem
     (Input TeamInvitationSubsystemConfig : r)
     (Invitation, InvitationCode)
forall (r :: EffectRow).
(Member GalleyAPIAccess r, Member UserSubsystem r,
 Member InvitationStore r, Member TinyLog r,
 Member (Error TeamInvitationSubsystemError) r, Member Random r,
 Member (Input TeamInvitationSubsystemConfig) r, Member Now r,
 Member EmailSubsystem r) =>
TeamId
-> Maybe InvitationId
-> Role
-> Local (Maybe UserId)
-> EmailAddress
-> InvitationRequest
-> Sem r (Invitation, InvitationCode)
createInvitation' TeamId
tid Maybe InvitationId
mExpectedInvId Role
role Local (Maybe UserId)
mbInviterUid EmailAddress
inviterEmail InvitationRequest
invRequest

inviteUserImpl ::
  ( Member (Error TeamInvitationSubsystemError) r,
    Member GalleyAPIAccess r,
    Member UserSubsystem r,
    Member TinyLog r,
    Member Random r,
    Member InvitationStore r,
    Member (Input TeamInvitationSubsystemConfig) r,
    Member Now r,
    Member EmailSubsystem r
  ) =>
  Local UserId ->
  TeamId ->
  InvitationRequest ->
  Sem r (Invitation, InvitationLocation)
inviteUserImpl :: forall (r :: EffectRow).
(Member (Error TeamInvitationSubsystemError) r,
 Member GalleyAPIAccess r, Member UserSubsystem r, Member TinyLog r,
 Member Random r, Member InvitationStore r,
 Member (Input TeamInvitationSubsystemConfig) r, Member Now r,
 Member EmailSubsystem r) =>
Local UserId
-> TeamId
-> InvitationRequest
-> Sem r (Invitation, InvitationLocation)
inviteUserImpl Local UserId
luid TeamId
tid InvitationRequest
request = do
  let inviteeRole :: Role
inviteeRole = Role -> Maybe Role -> Role
forall a. a -> Maybe a -> a
fromMaybe Role
defaultRole InvitationRequest
request.role

  let inviteePerms :: Permissions
inviteePerms = Role -> Permissions
Teams.rolePermissions Role
inviteeRole
  UserId -> TeamId -> Permissions -> Sem r ()
forall (r :: EffectRow).
(Member GalleyAPIAccess r,
 Member (Error TeamInvitationSubsystemError) r) =>
UserId -> TeamId -> Permissions -> Sem r ()
ensurePermissionToAddUser (Local UserId -> UserId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local UserId
luid) TeamId
tid Permissions
inviteePerms

  EmailAddress
inviterEmail <-
    TeamInvitationSubsystemError
-> Maybe EmailAddress -> Sem r EmailAddress
forall e (r :: EffectRow) a.
Member (Error e) r =>
e -> Maybe a -> Sem r a
note TeamInvitationSubsystemError
TeamInvitationNoEmail (Maybe EmailAddress -> Sem r EmailAddress)
-> Sem r (Maybe EmailAddress) -> Sem r EmailAddress
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MaybeT (Sem r) EmailAddress -> Sem r (Maybe EmailAddress)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT do
      SelfProfile
self <- Sem r (Maybe SelfProfile) -> MaybeT (Sem r) SelfProfile
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (Sem r (Maybe SelfProfile) -> MaybeT (Sem r) SelfProfile)
-> Sem r (Maybe SelfProfile) -> MaybeT (Sem r) SelfProfile
forall a b. (a -> b) -> a -> b
$ Local UserId -> Sem r (Maybe SelfProfile)
forall (r :: EffectRow).
Member UserSubsystem r =>
Local UserId -> Sem r (Maybe SelfProfile)
getSelfProfile Local UserId
luid
      Sem r (Maybe EmailAddress) -> MaybeT (Sem r) EmailAddress
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (Sem r (Maybe EmailAddress) -> MaybeT (Sem r) EmailAddress)
-> (User -> Sem r (Maybe EmailAddress))
-> User
-> MaybeT (Sem r) EmailAddress
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe EmailAddress -> Sem r (Maybe EmailAddress)
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe EmailAddress -> Sem r (Maybe EmailAddress))
-> (User -> Maybe EmailAddress)
-> User
-> Sem r (Maybe EmailAddress)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. User -> Maybe EmailAddress
userEmail (User -> MaybeT (Sem r) EmailAddress)
-> User -> MaybeT (Sem r) EmailAddress
forall a b. (a -> b) -> a -> b
$ SelfProfile -> User
selfUser SelfProfile
self

  let context :: Msg -> Msg
context =
        Text -> Msg -> Msg
logFunction Text
"Brig.Team.API.createInvitation"
          (Msg -> Msg) -> (Msg -> Msg) -> Msg -> Msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TeamId -> Msg -> Msg
logTeam TeamId
tid
          (Msg -> Msg) -> (Msg -> Msg) -> Msg -> Msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EmailAddress -> Msg -> Msg
logEmail InvitationRequest
request.inviteeEmail

  (Invitation -> Invitation
forall a. a -> a
id (Invitation -> Invitation)
-> (Invitation -> InvitationLocation)
-> Invitation
-> (Invitation, InvitationLocation)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Invitation -> InvitationLocation
loc) (Invitation -> (Invitation, InvitationLocation))
-> ((Invitation, InvitationCode) -> Invitation)
-> (Invitation, InvitationCode)
-> (Invitation, InvitationLocation)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Invitation, InvitationCode) -> Invitation
forall a b. (a, b) -> a
fst
    ((Invitation, InvitationCode) -> (Invitation, InvitationLocation))
-> Sem r (Invitation, InvitationCode)
-> Sem r (Invitation, InvitationLocation)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Msg -> Msg)
-> Sem
     (Error TeamInvitationSubsystemError : r)
     (Invitation, InvitationCode)
-> Sem r (Invitation, InvitationCode)
forall (r :: EffectRow).
(Member TinyLog r,
 Member (Error TeamInvitationSubsystemError) r) =>
(Msg -> Msg)
-> Sem
     (Error TeamInvitationSubsystemError : r)
     (Invitation, InvitationCode)
-> Sem r (Invitation, InvitationCode)
logInvitationRequest
      Msg -> Msg
context
      (TeamId
-> Maybe InvitationId
-> Role
-> Local (Maybe UserId)
-> EmailAddress
-> InvitationRequest
-> Sem
     (Error TeamInvitationSubsystemError : r)
     (Invitation, InvitationCode)
forall (r :: EffectRow).
(Member GalleyAPIAccess r, Member UserSubsystem r,
 Member InvitationStore r, Member TinyLog r,
 Member (Error TeamInvitationSubsystemError) r, Member Random r,
 Member (Input TeamInvitationSubsystemConfig) r, Member Now r,
 Member EmailSubsystem r) =>
TeamId
-> Maybe InvitationId
-> Role
-> Local (Maybe UserId)
-> EmailAddress
-> InvitationRequest
-> Sem r (Invitation, InvitationCode)
createInvitation' TeamId
tid Maybe InvitationId
forall a. Maybe a
Nothing Role
inviteeRole (UserId -> Maybe UserId
forall a. a -> Maybe a
Just (UserId -> Maybe UserId) -> Local UserId -> Local (Maybe UserId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Local UserId
luid) EmailAddress
inviterEmail InvitationRequest
request)
  where
    loc :: Invitation -> InvitationLocation
    loc :: Invitation -> InvitationLocation
loc Invitation
inv =
      ByteString -> InvitationLocation
InvitationLocation (ByteString -> InvitationLocation)
-> ByteString -> InvitationLocation
forall a b. (a -> b) -> a -> b
$ ByteString
"/teams/" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> TeamId -> ByteString
forall a. ToByteString a => a -> ByteString
toByteString' TeamId
tid ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"/invitations/" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> InvitationId -> ByteString
forall a. ToByteString a => a -> ByteString
toByteString' Invitation
inv.invitationId

createInvitation' ::
  ( Member GalleyAPIAccess r,
    Member UserSubsystem r,
    Member InvitationStore r,
    Member TinyLog r,
    Member (Error TeamInvitationSubsystemError) r,
    Member Random r,
    Member (Input TeamInvitationSubsystemConfig) r,
    Member Now r,
    Member EmailSubsystem r
  ) =>
  TeamId ->
  Maybe InvitationId ->
  Role ->
  Local (Maybe UserId) ->
  EmailAddress ->
  InvitationRequest ->
  Sem r (Invitation, InvitationCode)
createInvitation' :: forall (r :: EffectRow).
(Member GalleyAPIAccess r, Member UserSubsystem r,
 Member InvitationStore r, Member TinyLog r,
 Member (Error TeamInvitationSubsystemError) r, Member Random r,
 Member (Input TeamInvitationSubsystemConfig) r, Member Now r,
 Member EmailSubsystem r) =>
TeamId
-> Maybe InvitationId
-> Role
-> Local (Maybe UserId)
-> EmailAddress
-> InvitationRequest
-> Sem r (Invitation, InvitationCode)
createInvitation' TeamId
tid Maybe InvitationId
mExpectedInvId Role
inviteeRole Local (Maybe UserId)
mbInviterUid EmailAddress
inviterEmail InvitationRequest
invRequest = do
  let email :: EmailAddress
email = InvitationRequest
invRequest.inviteeEmail
  let uke :: QualifiedWithTag 'QLocal EmailKey
uke = Local (Maybe UserId)
-> EmailKey -> QualifiedWithTag 'QLocal EmailKey
forall (t :: QTag) x a.
QualifiedWithTag t x -> a -> QualifiedWithTag t a
qualifyAs Local (Maybe UserId)
mbInviterUid (EmailKey -> QualifiedWithTag 'QLocal EmailKey)
-> EmailKey -> QualifiedWithTag 'QLocal EmailKey
forall a b. (a -> b) -> a -> b
$ EmailAddress -> EmailKey
mkEmailKey EmailAddress
email
  Bool
blacklistedEm <- EmailAddress -> Sem r Bool
forall (r :: EffectRow).
Member UserSubsystem r =>
EmailAddress -> Sem r Bool
isBlocked EmailAddress
email
  Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
blacklistedEm (Sem r () -> Sem r ()) -> Sem r () -> Sem r ()
forall a b. (a -> b) -> a -> b
$
    TeamInvitationSubsystemError -> Sem r ()
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw TeamInvitationSubsystemError
TeamInvitationBlacklistedEmail

  Maybe User
mEmailOwner <- QualifiedWithTag 'QLocal EmailKey -> Sem r (Maybe User)
forall (r :: EffectRow).
Member UserSubsystem r =>
QualifiedWithTag 'QLocal EmailKey -> Sem r (Maybe User)
getLocalUserAccountByUserKey QualifiedWithTag 'QLocal EmailKey
uke
  Bool
isPersonalUserMigration <- case Maybe User
mEmailOwner of
    Maybe User
Nothing -> Bool -> Sem r Bool
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    Just User
user ->
      if (User
user.userStatus AccountStatus -> AccountStatus -> Bool
forall a. Eq a => a -> a -> Bool
== AccountStatus
Active Bool -> Bool -> Bool
&& Maybe TeamId -> Bool
forall a. Maybe a -> Bool
isNothing User
user.userTeam)
        then Bool -> Sem r Bool
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
        else TeamInvitationSubsystemError -> Sem r Bool
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw TeamInvitationSubsystemError
TeamInvitationEmailTaken

  Word32
maxSize <- TeamInvitationSubsystemConfig -> Word32
maxTeamSize (TeamInvitationSubsystemConfig -> Word32)
-> Sem r TeamInvitationSubsystemConfig -> Sem r Word32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sem r TeamInvitationSubsystemConfig
forall i (r :: EffectRow). Member (Input i) r => Sem r i
input
  Int64
pending <- TeamId -> Sem r Int64
forall (r :: EffectRow).
Member InvitationStore r =>
TeamId -> Sem r Int64
Store.countInvitations TeamId
tid
  Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
pending Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word32
maxSize) (Sem r () -> Sem r ()) -> Sem r () -> Sem r ()
forall a b. (a -> b) -> a -> b
$
    TeamInvitationSubsystemError -> Sem r ()
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw TeamInvitationSubsystemError
TooManyTeamInvitations

  ShowOrHideInvitationUrl
showInvitationUrl <- TeamId -> Sem r ShowOrHideInvitationUrl
forall (r :: EffectRow).
Member GalleyAPIAccess r =>
TeamId -> Sem r ShowOrHideInvitationUrl
GalleyAPIAccess.getExposeInvitationURLsToTeamAdmin TeamId
tid

  do
    InvitationId
iid <- Sem r InvitationId
-> (InvitationId -> Sem r InvitationId)
-> Maybe InvitationId
-> Sem r InvitationId
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (UUID -> InvitationId
forall {k} (a :: k). UUID -> Id a
Id (UUID -> InvitationId) -> Sem r UUID -> Sem r InvitationId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sem r UUID
forall (r :: EffectRow). Member Random r => Sem r UUID
Random.uuid) InvitationId -> Sem r InvitationId
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe InvitationId
mExpectedInvId
    UTCTime
now <- Sem r UTCTime
forall (r :: EffectRow). Member Now r => Sem r UTCTime
Now.get
    Timeout
timeout <- TeamInvitationSubsystemConfig -> Timeout
teamInvitationTimeout (TeamInvitationSubsystemConfig -> Timeout)
-> Sem r TeamInvitationSubsystemConfig -> Sem r Timeout
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sem r TeamInvitationSubsystemConfig
forall i (r :: EffectRow). Member (Input i) r => Sem r i
input
    InvitationCode
code <- Sem r InvitationCode
forall (r :: EffectRow). Member Random r => Sem r InvitationCode
mkInvitationCode
    StoredInvitation
newInv <-
      let insertInv :: InsertInvitation
insertInv =
            Store.MkInsertInvitation
              { $sel:invitationId:MkInsertInvitation :: InvitationId
invitationId = InvitationId
iid,
                $sel:teamId:MkInsertInvitation :: TeamId
teamId = TeamId
tid,
                $sel:role:MkInsertInvitation :: Role
role = Role
inviteeRole,
                $sel:createdAt:MkInsertInvitation :: UTCTime
createdAt = UTCTime
now,
                $sel:createdBy:MkInsertInvitation :: Maybe UserId
createdBy = Local (Maybe UserId) -> Maybe UserId
forall (t :: QTag) a. QualifiedWithTag t a -> a
tUnqualified Local (Maybe UserId)
mbInviterUid,
                $sel:inviteeEmail:MkInsertInvitation :: EmailAddress
inviteeEmail = EmailAddress
email,
                $sel:inviteeName:MkInsertInvitation :: Maybe Name
inviteeName = InvitationRequest
invRequest.inviteeName,
                $sel:code:MkInsertInvitation :: InvitationCode
code = InvitationCode
code
                -- mUrl = mUrl
              }
       in InsertInvitation -> Timeout -> Sem r StoredInvitation
forall (r :: EffectRow).
Member InvitationStore r =>
InsertInvitation -> Timeout -> Sem r StoredInvitation
Store.insertInvitation InsertInvitation
insertInv Timeout
timeout

    let sendOp :: EmailAddress
-> TeamId
-> EmailAddress
-> InvitationCode
-> Maybe Locale
-> Sem r Text
sendOp =
          if Bool
isPersonalUserMigration
            then EmailAddress
-> TeamId
-> EmailAddress
-> InvitationCode
-> Maybe Locale
-> Sem r Text
forall (r :: EffectRow).
Member EmailSubsystem r =>
EmailAddress
-> TeamId
-> EmailAddress
-> InvitationCode
-> Maybe Locale
-> Sem r Text
sendTeamInvitationMailPersonalUser
            else EmailAddress
-> TeamId
-> EmailAddress
-> InvitationCode
-> Maybe Locale
-> Sem r Text
forall (r :: EffectRow).
Member EmailSubsystem r =>
EmailAddress
-> TeamId
-> EmailAddress
-> InvitationCode
-> Maybe Locale
-> Sem r Text
sendTeamInvitationMail

    Text
invitationUrl <- EmailAddress
-> TeamId
-> EmailAddress
-> InvitationCode
-> Maybe Locale
-> Sem r Text
sendOp EmailAddress
email TeamId
tid EmailAddress
inviterEmail InvitationCode
code InvitationRequest
invRequest.locale
    Invitation
inv <- Text
-> ShowOrHideInvitationUrl -> StoredInvitation -> Sem r Invitation
forall (r :: EffectRow).
Member TinyLog r =>
Text
-> ShowOrHideInvitationUrl -> StoredInvitation -> Sem r Invitation
toInvitation Text
invitationUrl ShowOrHideInvitationUrl
showInvitationUrl StoredInvitation
newInv
    (Invitation, InvitationCode) -> Sem r (Invitation, InvitationCode)
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Invitation
inv, InvitationCode
code)

mkInvitationCode :: (Member Random r) => Sem r InvitationCode
mkInvitationCode :: forall (r :: EffectRow). Member Random r => Sem r InvitationCode
mkInvitationCode = AsciiBase64Url -> InvitationCode
InvitationCode (AsciiBase64Url -> InvitationCode)
-> (ByteString -> AsciiBase64Url) -> ByteString -> InvitationCode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> AsciiBase64Url
AsciiText.encodeBase64Url (ByteString -> InvitationCode)
-> Sem r ByteString -> Sem r InvitationCode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Sem r ByteString
forall (r :: EffectRow). Member Random r => Int -> Sem r ByteString
Random.bytes Int
24

isPersonalUser :: (Member UserSubsystem r) => Local EmailKey -> Sem r Bool
isPersonalUser :: forall (r :: EffectRow).
Member UserSubsystem r =>
QualifiedWithTag 'QLocal EmailKey -> Sem r Bool
isPersonalUser QualifiedWithTag 'QLocal EmailKey
uke = do
  Maybe User
mAccount <- QualifiedWithTag 'QLocal EmailKey -> Sem r (Maybe User)
forall (r :: EffectRow).
Member UserSubsystem r =>
QualifiedWithTag 'QLocal EmailKey -> Sem r (Maybe User)
getLocalUserAccountByUserKey QualifiedWithTag 'QLocal EmailKey
uke
  Bool -> Sem r Bool
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Sem r Bool) -> Bool -> Sem r Bool
forall a b. (a -> b) -> a -> b
$ case Maybe User
mAccount of
    -- this can e.g. happen if the key is claimed but the account is not yet created
    Maybe User
Nothing -> Bool
False
    Just User
user -> User
user.userStatus AccountStatus -> AccountStatus -> Bool
forall a. Eq a => a -> a -> Bool
== AccountStatus
Active Bool -> Bool -> Bool
&& Maybe TeamId -> Bool
forall a. Maybe a -> Bool
isNothing User
user.userTeam

-- | brig used to not store the role, so for migration we allow this to be empty and fill in the
-- default here.
toInvitation ::
  forall r.
  (Member TinyLog r) =>
  Text ->
  ShowOrHideInvitationUrl ->
  StoredInvitation ->
  Sem r Invitation
toInvitation :: forall (r :: EffectRow).
Member TinyLog r =>
Text
-> ShowOrHideInvitationUrl -> StoredInvitation -> Sem r Invitation
toInvitation Text
urlText ShowOrHideInvitationUrl
showUrl StoredInvitation
storedInv = do
  Maybe (URIRef Absolute)
url <-
    case ShowOrHideInvitationUrl
showUrl of
      ShowOrHideInvitationUrl
HideInvitationUrl -> Maybe (URIRef Absolute) -> Sem r (Maybe (URIRef Absolute))
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (URIRef Absolute)
forall a. Maybe a
Nothing
      ShowOrHideInvitationUrl
ShowInvitationUrl -> Text -> Sem r (Maybe (URIRef Absolute))
parseHttpsUrl Text
urlText
  Invitation -> Sem r Invitation
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Invitation -> Sem r Invitation) -> Invitation -> Sem r Invitation
forall a b. (a -> b) -> a -> b
$
    Invitation
      { $sel:team:Invitation :: TeamId
team = StoredInvitation
storedInv.teamId,
        $sel:role:Invitation :: Role
role = Role -> Maybe Role -> Role
forall a. a -> Maybe a -> a
fromMaybe Role
defaultRole StoredInvitation
storedInv.role,
        $sel:invitationId:Invitation :: InvitationId
invitationId = StoredInvitation
storedInv.invitationId,
        $sel:createdAt:Invitation :: UTCTimeMillis
createdAt = StoredInvitation
storedInv.createdAt,
        $sel:createdBy:Invitation :: Maybe UserId
createdBy = StoredInvitation
storedInv.createdBy,
        $sel:inviteeEmail:Invitation :: EmailAddress
inviteeEmail = StoredInvitation
storedInv.email,
        $sel:inviteeName:Invitation :: Maybe Name
inviteeName = StoredInvitation
storedInv.name,
        $sel:inviteeUrl:Invitation :: Maybe (URIRef Absolute)
inviteeUrl = Maybe (URIRef Absolute)
url
      }
  where
    parseHttpsUrl :: Text -> Sem r (Maybe (URIRef Absolute))
    parseHttpsUrl :: Text -> Sem r (Maybe (URIRef Absolute))
parseHttpsUrl Text
url =
      (URIParseError -> Sem r (Maybe (URIRef Absolute)))
-> (URIRef Absolute -> Sem r (Maybe (URIRef Absolute)))
-> Either URIParseError (URIRef Absolute)
-> Sem r (Maybe (URIRef Absolute))
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\URIParseError
e -> Maybe (URIRef Absolute)
forall a. Maybe a
Nothing Maybe (URIRef Absolute)
-> Sem r () -> Sem r (Maybe (URIRef Absolute))
forall a b. a -> Sem r b -> Sem r a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> URIParseError -> Sem r ()
forall {r :: EffectRow} {a} {a}.
(Member TinyLog r, ToBytes a, Show a) =>
a -> a -> Sem r ()
logError Text
url URIParseError
e) (Maybe (URIRef Absolute) -> Sem r (Maybe (URIRef Absolute))
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (URIRef Absolute) -> Sem r (Maybe (URIRef Absolute)))
-> (URIRef Absolute -> Maybe (URIRef Absolute))
-> URIRef Absolute
-> Sem r (Maybe (URIRef Absolute))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. URIRef Absolute -> Maybe (URIRef Absolute)
forall a. a -> Maybe a
Just) (Either URIParseError (URIRef Absolute)
 -> Sem r (Maybe (URIRef Absolute)))
-> Either URIParseError (URIRef Absolute)
-> Sem r (Maybe (URIRef Absolute))
forall a b. (a -> b) -> a -> b
$
        URIParserOptions
-> ByteString -> Either URIParseError (URIRef Absolute)
parseURI URIParserOptions
laxURIParserOptions (Text -> ByteString
Text.encodeUtf8 Text
url)

    logError :: a -> a -> Sem r ()
logError a
url a
e =
      (Msg -> Msg) -> Sem r ()
forall msg (r :: EffectRow).
Member (Logger msg) r =>
msg -> Sem r ()
Log.err ((Msg -> Msg) -> Sem r ()) -> (Msg -> Msg) -> Sem r ()
forall a b. (a -> b) -> a -> b
$
        forall a. ToBytes a => a -> Msg -> Msg
Log.msg @Text Text
"Unable to create invitation url. Please check configuration."
          (Msg -> Msg) -> (Msg -> Msg) -> Msg -> Msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> a -> Msg -> Msg
forall a. ToBytes a => ByteString -> a -> Msg -> Msg
Log.field ByteString
"url" a
url
          (Msg -> Msg) -> (Msg -> Msg) -> Msg -> Msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String -> Msg -> Msg
forall a. ToBytes a => ByteString -> a -> Msg -> Msg
Log.field ByteString
"error" (a -> String
forall a. Show a => a -> String
show a
e)

logInvitationRequest ::
  (Member TinyLog r, Member (Error TeamInvitationSubsystemError) r) =>
  (Msg -> Msg) ->
  Sem (Error TeamInvitationSubsystemError : r) (Invitation, InvitationCode) ->
  Sem r (Invitation, InvitationCode)
logInvitationRequest :: forall (r :: EffectRow).
(Member TinyLog r,
 Member (Error TeamInvitationSubsystemError) r) =>
(Msg -> Msg)
-> Sem
     (Error TeamInvitationSubsystemError : r)
     (Invitation, InvitationCode)
-> Sem r (Invitation, InvitationCode)
logInvitationRequest Msg -> Msg
context Sem
  (Error TeamInvitationSubsystemError : r)
  (Invitation, InvitationCode)
action =
  Sem
  (Error TeamInvitationSubsystemError : r)
  (Invitation, InvitationCode)
-> Sem
     r
     (Either TeamInvitationSubsystemError (Invitation, InvitationCode))
forall e (r :: EffectRow) a.
Sem (Error e : r) a -> Sem r (Either e a)
runError Sem
  (Error TeamInvitationSubsystemError : r)
  (Invitation, InvitationCode)
action Sem
  r
  (Either TeamInvitationSubsystemError (Invitation, InvitationCode))
-> (Either
      TeamInvitationSubsystemError (Invitation, InvitationCode)
    -> Sem r (Invitation, InvitationCode))
-> Sem r (Invitation, InvitationCode)
forall a b. Sem r a -> (a -> Sem r b) -> Sem r b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left TeamInvitationSubsystemError
e -> do
      (Msg -> Msg) -> Sem r ()
forall msg (r :: EffectRow).
Member (Logger msg) r =>
msg -> Sem r ()
Log.warn ((Msg -> Msg) -> Sem r ()) -> (Msg -> Msg) -> Sem r ()
forall a b. (a -> b) -> a -> b
$
        forall a. ToBytes a => a -> Msg -> Msg
msg @String (String
"Failed to create invitation: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TeamInvitationSubsystemError -> String
forall a. Show a => a -> String
show TeamInvitationSubsystemError
e)
          (Msg -> Msg) -> (Msg -> Msg) -> Msg -> Msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Msg -> Msg
context
      TeamInvitationSubsystemError -> Sem r (Invitation, InvitationCode)
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw TeamInvitationSubsystemError
e
    Right res :: (Invitation, InvitationCode)
res@(Invitation
_, InvitationCode
code) -> do
      (Msg -> Msg) -> Sem r ()
forall msg (r :: EffectRow).
Member (Logger msg) r =>
msg -> Sem r ()
Log.info ((Msg -> Msg) -> Sem r ()) -> (Msg -> Msg) -> Sem r ()
forall a b. (a -> b) -> a -> b
$
        forall a. ToBytes a => a -> Msg -> Msg
msg @ByteString ByteString
"Successfully created invitation"
          (Msg -> Msg) -> (Msg -> Msg) -> Msg -> Msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Msg -> Msg
context
          (Msg -> Msg) -> (Msg -> Msg) -> Msg -> Msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InvitationCode -> Msg -> Msg
logInvitationCode InvitationCode
code
      (Invitation, InvitationCode) -> Sem r (Invitation, InvitationCode)
forall a. a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Invitation, InvitationCode)
res

-- | Privilege escalation detection (make sure no `RoleMember` user creates a `RoleOwner`).
--
-- There is some code duplication with 'Galley.API.Teams.ensureNotElevated'.
ensurePermissionToAddUser ::
  ( Member GalleyAPIAccess r,
    Member (Error TeamInvitationSubsystemError) r
  ) =>
  UserId ->
  TeamId ->
  Permissions ->
  Sem r ()
ensurePermissionToAddUser :: forall (r :: EffectRow).
(Member GalleyAPIAccess r,
 Member (Error TeamInvitationSubsystemError) r) =>
UserId -> TeamId -> Permissions -> Sem r ()
ensurePermissionToAddUser UserId
u TeamId
t Permissions
inviteePerms = do
  Maybe TeamMember
minviter <- UserId -> TeamId -> Sem r (Maybe TeamMember)
forall (r :: EffectRow).
Member GalleyAPIAccess r =>
UserId -> TeamId -> Sem r (Maybe TeamMember)
GalleyAPIAccess.getTeamMember UserId
u TeamId
t
  Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Maybe TeamMember -> Bool
check Maybe TeamMember
minviter) (Sem r () -> Sem r ()) -> Sem r () -> Sem r ()
forall a b. (a -> b) -> a -> b
$
    TeamInvitationSubsystemError -> Sem r ()
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw TeamInvitationSubsystemError
TeamInvitationInsufficientTeamPermissions
  where
    check :: Maybe TeamMember -> Bool
    check :: Maybe TeamMember -> Bool
check (Just TeamMember
inviter) =
      TeamMember -> Perm -> Bool
forall perm. IsPerm perm => TeamMember -> perm -> Bool
hasPermission TeamMember
inviter Perm
AddTeamMember
        Bool -> Bool -> Bool
&& (Perm -> Bool) -> [Perm] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (TeamMember -> Perm -> Bool
forall perm. IsPerm perm => TeamMember -> perm -> Bool
mayGrantPermission TeamMember
inviter) (Set Perm -> [Perm]
forall a. Set a -> [a]
Set.toList (Permissions
inviteePerms.self))
    check Maybe TeamMember
Nothing = Bool
False

logInvitationCode :: InvitationCode -> (Msg -> Msg)
logInvitationCode :: InvitationCode -> Msg -> Msg
logInvitationCode InvitationCode
code = ByteString -> Text -> Msg -> Msg
forall a. ToBytes a => ByteString -> a -> Msg -> Msg
field ByteString
"invitation_code" (AsciiBase64Url -> Text
forall {k} (c :: k). AsciiText c -> Text
AsciiText.toText (AsciiBase64Url -> Text) -> AsciiBase64Url -> Text
forall a b. (a -> b) -> a -> b
$ InvitationCode -> AsciiBase64Url
fromInvitationCode InvitationCode
code)