Users.hs

{-# LANGUAGE OverloadedStrings #-}
module Matterhorn.State.Users
  ( handleNewUsers
  , handleTypingUser
  , handleUserUpdated
  , withFetchedUser
  , withFetchedUserMaybe
  )
where

import           Prelude ()
import           Matterhorn.Prelude

import qualified Data.Text as T
import qualified Data.Foldable as F
import qualified Data.HashMap.Strict as HM
import qualified Data.Sequence as Seq
import           Data.Time ( getCurrentTime )
import           Lens.Micro.Platform

import qualified Network.Mattermost.Endpoints as MM
import           Network.Mattermost.Types

import           Matterhorn.Config
import           Matterhorn.Types
import           Matterhorn.State.Common


handleNewUsers :: Seq UserId -> MH () -> MH ()
handleNewUsers newUserIds after = do
    doAsyncMM Preempt getUserInfo addNewUsers
    where getUserInfo session =
              do nUsers <- MM.mmGetUsersByIds newUserIds session
                 let usrInfo u = userInfoFromUser u True
                     usrList = toList nUsers
                 return $ usrInfo <$> usrList

          addNewUsers :: [UserInfo] -> Maybe Work
          addNewUsers is = Just $ Work "handleNewUsers" $ mapM_ addNewUser is >> after

-- | Handle the typing events from the websocket to show the currently
-- typing users on UI
handleTypingUser :: UserId -> ChannelId -> Maybe PostId -> MH ()
handleTypingUser uId cId threadRootPostId = do
    config <- use (csResources.crConfiguration)
    when (configShowTypingIndicator config) $ do
        withFetchedUser (UserFetchById uId) $ const $ do
            ts <- liftIO getCurrentTime

            -- Indicate that the user is typing in the specified
            -- channel.
            csChannel(cId).ccMessageInterface.miEditor.esEphemeral %= addEphemeralStateTypingUser uId ts

            -- If the typing is occurring in a thread and that thread is
            -- open in some team, also indicate that the user is typing
            -- in that thread's window.
            teams <- use csTeams
            forM_ (HM.keys teams) $ \tId -> do
                pId <- preuse (threadInterface(tId).miRootPostId)
                when (pId == threadRootPostId) $ do
                    threadInterface(tId).miEditor.esEphemeral %= addEphemeralStateTypingUser uId ts

-- | Handle the websocket event for when a user is updated, e.g. has changed
-- their nickname
handleUserUpdated :: User -> MH ()
handleUserUpdated user = do
    csUsers %= modifyUserById (userId user)
        (\ui -> userInfoFromUser user (ui ^. uiInTeam))


-- | Given a user fetching strategy, locate the user in the state or
-- fetch it from the server, and pass the result to the specified
-- action. Assumes a single match is the only expected/valid result.
withFetchedUser :: UserFetch -> (UserInfo -> MH ()) -> MH ()
withFetchedUser fetch handle =
    withFetchedUserMaybe fetch $ \u -> do
        case u of
            Nothing -> postErrorMessage' "No such user"
            Just user -> handle user

withFetchedUserMaybe :: UserFetch -> (Maybe UserInfo -> MH ()) -> MH ()
withFetchedUserMaybe fetch handle = do
    st <- use id
    session <- getSession

    let localMatch = case fetch of
            UserFetchById uId -> userById uId st
            UserFetchByUsername uname -> userByUsername uname st
            UserFetchByNickname nick -> userByNickname nick st

    case localMatch of
        Just user -> handle $ Just user
        Nothing -> do
            mhLog LogGeneral $ T.pack $ "withFetchedUserMaybe: getting " <> show fetch
            doAsyncWith Normal $ do
                results <- case fetch of
                    UserFetchById uId ->
                        MM.mmGetUsersByIds (Seq.singleton uId) session
                    UserFetchByUsername uname ->
                        MM.mmGetUsersByUsernames (Seq.singleton $ trimUserSigil uname) session
                    UserFetchByNickname nick -> do
                        let req = UserSearch { userSearchTerm = trimUserSigil nick
                                             , userSearchAllowInactive = True
                                             , userSearchWithoutTeam = True
                                             , userSearchInChannelId = Nothing
                                             , userSearchNotInTeamId = Nothing
                                             , userSearchNotInChannelId = Nothing
                                             , userSearchTeamId = Nothing
                                             }
                        MM.mmSearchUsers req session

                return $ Just $ Work "withFetchedUserMaybe" $ do
                    infos <- forM (F.toList results) $ \u -> do
                        let info = userInfoFromUser u True
                        addNewUser info
                        return info

                    case infos of
                        [match] -> handle $ Just match
                        [] -> handle Nothing
                        _ -> postErrorMessage' "Error: ambiguous user information"