content: module Wire.UserGroupSubsystem.Interpreter where
  
  import Control.Error (MaybeT (..))
  import Control.Lens ((^.))
  import Data.Default
  import Data.Id
  import Data.Json.Util
  import Data.Qualified (Local, Qualified (qUnqualified), qualifyAs)
  import Data.Set qualified as Set
  import Data.Vector (Vector)
  import Imports
  import Polysemy
  import Polysemy.Error
  import Polysemy.Input (Input, input)
  import Wire.API.Conversation qualified as Conversation
  import Wire.API.Error
  import Wire.API.Error.Brig qualified as E
  import Wire.API.Pagination
  import Wire.API.Push.V2 (RecipientClients (RecipientClientsAll))
  import Wire.API.Team.Member
  import Wire.API.Team.Member qualified as TM
  import Wire.API.User
  import Wire.API.UserEvent
  import Wire.API.UserGroup
  import Wire.API.UserGroup.Pagination
  import Wire.Error
  import Wire.GalleyAPIAccess (GalleyAPIAccess, internalGetConversation)
  import Wire.NotificationSubsystem
  import Wire.PaginationState
  import Wire.TeamSubsystem
  import Wire.UserGroupStore (UserGroupPageRequest (..))
  import Wire.UserGroupStore qualified as Store
  import Wire.UserGroupSubsystem (GroupSearch (..), UserGroupSubsystem (..))
  import Wire.UserSubsystem (UserSubsystem, getLocalUserProfiles, getUserTeam)
  
  interpretUserGroupSubsystem ::
    ( Member UserSubsystem r,
      Member (Error UserGroupSubsystemError) r,
      Member Store.UserGroupStore r,
      Member (Input (Local ())) r,
      Member NotificationSubsystem r,
      Member TeamSubsystem r,
      Member GalleyAPIAccess r
    ) =>
    InterpreterFor UserGroupSubsystem r
  interpretUserGroupSubsystem = interpret $ \case
    CreateGroup creator newGroup -> createUserGroup creator newGroup
    GetGroup getter gid includeChannels -> getUserGroup getter gid includeChannels
    GetGroups getter search -> getUserGroups getter search
    UpdateGroup updater groupId groupUpdate -> updateGroup updater groupId groupUpdate
    DeleteGroup deleter groupId -> deleteGroup deleter groupId
    AddUser adder groupId addeeId -> addUser adder groupId addeeId
    AddUsers adder groupId addeeIds -> addUsers adder groupId addeeIds
    UpdateUsers updater groupId uids -> updateUsers updater groupId uids
    RemoveUser remover groupId removeeId -> removeUser remover groupId removeeId
    RemoveUserFromAllGroups uid tid -> removeUserFromAllGroups uid tid
    UpdateChannels performer groupId channelIds -> updateChannels performer groupId channelIds
  
  data UserGroupSubsystemError
    = UserGroupNotATeamAdmin
    | UserGroupMemberIsNotInTheSameTeam
    | UserGroupNotFound
    | UserGroupChannelNotFound
    deriving (Show, Eq)
  
  userGroupSubsystemErrorToHttpError :: UserGroupSubsystemError -> HttpError
  userGroupSubsystemErrorToHttpError =
    StdError . \case
      UserGroupNotATeamAdmin -> errorToWai @E.UserGroupNotATeamAdmin
      UserGroupMemberIsNotInTheSameTeam -> errorToWai @E.UserGroupMemberIsNotInTheSameTeam
      UserGroupNotFound -> errorToWai @E.UserGroupNotFound
      UserGroupChannelNotFound -> errorToWai @E.UserGroupChannelNotFound
  
  createUserGroup ::
    ( Member UserSubsystem r,
      Member (Error UserGroupSubsystemError) r,
      Member Store.UserGroupStore r,
      Member (Input (Local ())) r,
      Member NotificationSubsystem r,
      Member TeamSubsystem r
    ) =>
    UserId ->
    NewUserGroup ->
    Sem r UserGroup
  createUserGroup creator newGroup = do
    let managedBy = ManagedByWire
    team <- getTeamAsAdmin creator >>= note UserGroupNotATeamAdmin
    luids <- qualifyLocal $ toList newGroup.members
    profiles <- getLocalUserProfiles luids
    let existingIds = Set.fromList $ fmap (qUnqualified . profileQualifiedId) profiles
    let actualIds = Set.fromList $ toList newGroup.members
    let allInSameTeam = all (\p -> p.profileTeam == Just team) profiles
    when (existingIds /= actualIds || not allInSameTeam) $
      throw $
        UserGroupMemberIsNotInTheSameTeam
    ug <- Store.createUserGroup team newGroup managedBy
    admins <- fmap (^. TM.userId) . (^. teamMembers) <$> internalGetTeamAdmins team
    pushNotifications
      [ mkEvent creator (UserGroupCreated ug.id_) admins
      ]
    pure ug
  
  getTeamAsAdmin ::
    ( Member UserSubsystem r,
      Member TeamSubsystem r
    ) =>
    UserId ->
    Sem r (Maybe TeamId)
  getTeamAsAdmin user = runMaybeT do
    (team, member) <- MaybeT $ getTeamAsMember user
    guard (isAdminOrOwner (member ^. permissions))
    pure team
  
  getTeamAsMember ::
    ( Member UserSubsystem r,
      Member TeamSubsystem r
    ) =>
    UserId ->
    Sem r (Maybe (TeamId, TeamMember))
  getTeamAsMember memberId = runMaybeT do
    team <- MaybeT $ getUserTeam memberId
    mbr <- MaybeT $ internalGetTeamMember memberId team
    pure (team, mbr)
  
  mkEvent :: UserId -> UserGroupEvent -> [UserId] -> Push
  mkEvent author evt recipients =
    def
      { origin = Just author,
        json = toJSONObject $ UserGroupEvent evt,
        recipients = (\uid -> Recipient {recipientUserId = uid, recipientClients = RecipientClientsAll}) <$> recipients,
        transient = True
      }
  
  qualifyLocal :: (Member (Input (Local ())) r) => a -> Sem r (Local a)
  qualifyLocal a = do
    l <- input
    pure $ qualifyAs l a
  
  getUserGroup ::
    ( Member UserSubsystem r,
      Member Store.UserGroupStore r,
      Member TeamSubsystem r
    ) =>
    UserId ->
    UserGroupId ->
    Bool ->
    Sem r (Maybe UserGroup)
  getUserGroup getter gid includeChannels = runMaybeT $ do
    team <- MaybeT $ getUserTeam getter
    getterCanSeeAll <- mkGetterCanSeeAll getter team
    userGroup <- MaybeT $ Store.getUserGroup team gid includeChannels
    if getterCanSeeAll || getter `elem` (toList (runIdentity userGroup.members))
      then pure userGroup
      else MaybeT $ pure Nothing
  
  mkGetterCanSeeAll ::
    forall r.
    (Member TeamSubsystem r) =>
    UserId ->
    TeamId ->
    MaybeT (Sem r) Bool
  mkGetterCanSeeAll getter team = do
    creatorTeamMember <- MaybeT $ internalGetTeamMember getter team
    pure . isAdminOrOwner $ creatorTeamMember ^. permissions
  
  getUserGroups ::
    forall r.
    ( Member UserSubsystem r,
      Member TeamSubsystem r,
      Member Store.UserGroupStore r,
      Member (Error UserGroupSubsystemError) r
    ) =>
    UserId ->
    GroupSearch ->
    Sem r UserGroupPage
  getUserGroups getter search = do
    team :: TeamId <- getUserTeam getter >>= ifNothing UserGroupNotATeamAdmin
    getterCanSeeAll :: Bool <- fromMaybe False <$> runMaybeT (mkGetterCanSeeAll getter team)
    unless getterCanSeeAll (throw UserGroupNotATeamAdmin)
    let pageReq =
          UserGroupPageRequest
            { pageSize = fromMaybe def search.pageSize,
              sortOrder = fromMaybe Desc search.sortOrder,
              paginationState = case (fromMaybe def search.sortBy) of
                SortByName ->
                  PaginationSortByName $
                    (,) <$> search.lastName <*> search.lastId
                SortByCreatedAt ->
                  PaginationSortByCreatedAt $
                    (,) <$> search.lastCreatedAt <*> search.lastId,
              team = team,
              searchString = search.query,
              includeMemberCount = search.includeMemberCount,
              includeChannels = search.includeChannels
            }
    Store.getUserGroups pageReq
    where
      ifNothing :: UserGroupSubsystemError -> Maybe a -> Sem r a
      ifNothing e = maybe (throw e) pure
  
  updateGroup ::
    ( Member UserSubsystem r,
      Member Store.UserGroupStore r,
      Member (Error UserGroupSubsystemError) r,
      Member NotificationSubsystem r,
      Member TeamSubsystem r
    ) =>
    UserId ->
    UserGroupId ->
    UserGroupUpdate ->
    Sem r ()
  updateGroup updater groupId groupUpdate = do
    team <- getTeamAsAdmin updater >>= note UserGroupNotATeamAdmin
    found <- isJust <$> Store.updateUserGroup team groupId groupUpdate
    if found
      then do
        admins <- fmap (^. TM.userId) . (^. teamMembers) <$> internalGetTeamAdmins team
        pushNotifications [mkEvent updater (UserGroupUpdated groupId) admins]
      else throw UserGroupNotFound
  
  deleteGroup ::
    ( Member UserSubsystem r,
      Member Store.UserGroupStore r,
      Member (Error UserGroupSubsystemError) r,
      Member NotificationSubsystem r,
      Member TeamSubsystem r
    ) =>
    UserId ->
    UserGroupId ->
    Sem r ()
  deleteGroup deleter groupId =
    getTeamAsMember deleter >>= \case
      Nothing -> throw UserGroupNotFound
      Just (team, member) -> do
        if isAdminOrOwner (member ^. permissions)
          then do
            found <- isJust <$> Store.deleteUserGroup team groupId
            if found
              then do
                admins <- fmap (^. TM.userId) . (^. teamMembers) <$> internalGetTeamAdmins team
                pushNotifications [mkEvent deleter (UserGroupDeleted groupId) admins]
              else
                throw UserGroupNotFound
          else do
            throw UserGroupNotATeamAdmin
  
  addUser ::
    ( Member UserSubsystem r,
      Member Store.UserGroupStore r,
      Member (Error UserGroupSubsystemError) r,
      Member NotificationSubsystem r,
      Member TeamSubsystem r
    ) =>
    UserId ->
    UserGroupId ->
    UserId ->
    Sem r ()
  addUser adder groupId addeeId = do
    ug <- getUserGroup adder groupId False >>= note UserGroupNotFound
    team <- getTeamAsAdmin adder >>= note UserGroupNotATeamAdmin
    void $ internalGetTeamMember addeeId team >>= note UserGroupMemberIsNotInTheSameTeam
    unless (addeeId `elem` runIdentity ug.members) $ do
      Store.addUser groupId addeeId
      admins <- fmap (^. TM.userId) . (^. teamMembers) <$> internalGetTeamAdmins team
      pushNotifications
        [ mkEvent adder (UserGroupUpdated groupId) admins
        ]
  
  addUsers ::
    ( Member UserSubsystem r,
      Member Store.UserGroupStore r,
      Member (Error UserGroupSubsystemError) r,
      Member NotificationSubsystem r,
      Member TeamSubsystem r
    ) =>
    UserId ->
    UserGroupId ->
    Vector UserId ->
    Sem r ()
  addUsers adder groupId addeeIds = do
    ug <- getUserGroup adder groupId False >>= note UserGroupNotFound
    team <- getTeamAsAdmin adder >>= note UserGroupNotATeamAdmin
    forM_ addeeIds $ \addeeId ->
      internalGetTeamMember addeeId team >>= note UserGroupMemberIsNotInTheSameTeam
  
    let missingAddeeIds = toList addeeIds \\ toList (runIdentity ug.members)
    unless (null missingAddeeIds) $ do
      mapM_ (Store.addUser groupId) missingAddeeIds
      admins <- fmap (^. TM.userId) . (^. teamMembers) <$> internalGetTeamAdmins team
      pushNotifications
        [ mkEvent adder (UserGroupUpdated groupId) admins
        ]
  
  updateUsers ::
    ( Member UserSubsystem r,
      Member Store.UserGroupStore r,
      Member (Error UserGroupSubsystemError) r,
      Member NotificationSubsystem r,
      Member TeamSubsystem r
    ) =>
    UserId ->
    UserGroupId ->
    Vector UserId ->
    Sem r ()
  updateUsers updater groupId uids = do
    void $ getUserGroup updater groupId False >>= note UserGroupNotFound
    team <- getTeamAsAdmin updater >>= note UserGroupNotATeamAdmin
    forM_ uids $ \uid ->
      internalGetTeamMember uid team >>= note UserGroupMemberIsNotInTheSameTeam
    Store.updateUsers groupId uids
    admins <- fmap (^. TM.userId) . (^. teamMembers) <$> internalGetTeamAdmins team
    pushNotifications
      [ mkEvent updater (UserGroupUpdated groupId) admins
      ]
  
  removeUser ::
    ( Member UserSubsystem r,
      Member Store.UserGroupStore r,
      Member (Error UserGroupSubsystemError) r,
      Member NotificationSubsystem r,
      Member TeamSubsystem r
    ) =>
    UserId ->
    UserGroupId ->
    UserId ->
    Sem r ()
  removeUser remover groupId removeeId = do
    ug <- getUserGroup remover groupId False >>= note UserGroupNotFound
    team <- getTeamAsAdmin remover >>= note UserGroupNotATeamAdmin
    void $ internalGetTeamMember removeeId team >>= note UserGroupMemberIsNotInTheSameTeam
    when (removeeId `elem` runIdentity ug.members) $ do
      Store.removeUser groupId removeeId
      admins <- fmap (^. TM.userId) . (^. teamMembers) <$> internalGetTeamAdmins team
      pushNotifications
        [ mkEvent remover (UserGroupUpdated groupId) admins
        ]
  
  removeUserFromAllGroups ::
    ( Member Store.UserGroupStore r,
      Member TeamSubsystem r
    ) =>
    UserId ->
    TeamId ->
    Sem r ()
  removeUserFromAllGroups uid tid = do
    internalGetTeamMember uid tid >>= \case
      Just _ -> nextPage Nothing >>= go
      Nothing -> pure ()
    where
      go (ug : ugs) = do
        Store.removeUser ug.id_ uid
        -- when we get to the last item, get a new page
        ugs' <- case ugs of
          [] -> nextPage (Just ug)
          _ -> pure ugs
        go ugs'
      -- no more items, terminate
      go [] = pure ()
  
      nextPage mug =
        fmap (.page) . Store.getUserGroups $
          UserGroupPageRequest
            { pageSize = def,
              sortOrder = Desc,
              paginationState =
                PaginationSortByCreatedAt $
                  fmap Store.userGroupCreatedAtPaginationState mug,
              team = tid,
              searchString = Nothing,
              includeMemberCount = False,
              includeChannels = False
            }
  
  updateChannels ::
    ( Member UserSubsystem r,
      Member Store.UserGroupStore r,
      Member (Error UserGroupSubsystemError) r,
      Member TeamSubsystem r,
      Member NotificationSubsystem r,
      Member GalleyAPIAccess r
    ) =>
    UserId ->
    UserGroupId ->
    Vector ConvId ->
    Sem r ()
  updateChannels performer groupId channelIds = do
    void $ getUserGroup performer groupId False >>= note UserGroupNotFound
    teamId <- getTeamAsAdmin performer >>= note UserGroupNotATeamAdmin
    for_ channelIds $ \channelId -> do
      conv <- internalGetConversation channelId >>= note UserGroupChannelNotFound
      let meta = conv.metadata
      unless (meta.cnvmTeam == Just teamId && meta.cnvmGroupConvType == Just Conversation.Channel) $
        throw UserGroupChannelNotFound
    Store.updateUserGroupChannels groupId channelIds
  
    admins <- fmap (^. TM.userId) . (^. teamMembers) <$> internalGetTeamAdmins teamId
    pushNotifications
      [ mkEvent performer (UserGroupUpdated groupId) admins
      ]
  