{-# 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 :: Seq UserId -> MH () -> MH ()
handleNewUsers Seq UserId
newUserIds MH ()
after = do
    forall a.
AsyncPriority -> (Session -> IO a) -> (a -> Maybe (MH ())) -> MH ()
doAsyncMM AsyncPriority
Preempt Session -> IO [UserInfo]
getUserInfo [UserInfo] -> Maybe (MH ())
addNewUsers
    where getUserInfo :: Session -> IO [UserInfo]
getUserInfo Session
session =
              do Seq User
nUsers <- Seq UserId -> Session -> IO (Seq User)
MM.mmGetUsersByIds Seq UserId
newUserIds Session
session
                 let usrInfo :: User -> UserInfo
usrInfo User
u = User -> Bool -> UserInfo
userInfoFromUser User
u Bool
True
                     usrList :: [User]
usrList = forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq User
nUsers
                 forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ User -> UserInfo
usrInfo forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [User]
usrList

          addNewUsers :: [UserInfo] -> Maybe (MH ())
          addNewUsers :: [UserInfo] -> Maybe (MH ())
addNewUsers [UserInfo]
is = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ UserInfo -> MH ()
addNewUser [UserInfo]
is forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MH ()
after

-- | Handle the typing events from the websocket to show the currently
-- typing users on UI
handleTypingUser :: UserId -> ChannelId -> Maybe PostId -> MH ()
handleTypingUser :: UserId -> ChannelId -> Maybe PostId -> MH ()
handleTypingUser UserId
uId ChannelId
cId Maybe PostId
threadRootPostId = do
    Config
config <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use (Lens' ChatState ChatResources
csResourcesforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' ChatResources Config
crConfiguration)
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Config -> Bool
configShowTypingIndicator Config
config) forall a b. (a -> b) -> a -> b
$ do
        UserFetch -> (UserInfo -> MH ()) -> MH ()
withFetchedUser (UserId -> UserFetch
UserFetchById UserId
uId) forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ do
            UTCTime
ts <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime

            -- Indicate that the user is typing in the specified
            -- channel.
            ChannelId -> Traversal' ChatState ClientChannel
csChannel(ChannelId
cId)forall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' ClientChannel (MessageInterface Name ())
ccMessageInterfaceforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall n i. Lens' (MessageInterface n i) (EditState n)
miEditorforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall n. Lens' (EditState n) EphemeralEditState
esEphemeral forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= UserId -> UTCTime -> EphemeralEditState -> EphemeralEditState
addEphemeralStateTypingUser UserId
uId UTCTime
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.
            HashMap TeamId TeamState
teams <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Lens' ChatState (HashMap TeamId TeamState)
csTeams
            forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall k v. HashMap k v -> [k]
HM.keys HashMap TeamId TeamState
teams) forall a b. (a -> b) -> a -> b
$ \TeamId
tId -> do
                Maybe PostId
pId <- forall s (m :: * -> *) a.
MonadState s m =>
Getting (First a) s a -> m (Maybe a)
preuse (HasCallStack => TeamId -> Traversal' ChatState ThreadInterface
threadInterface(TeamId
tId)forall b c a. (b -> c) -> (a -> b) -> a -> c
.forall n i1 i2.
Lens (MessageInterface n i1) (MessageInterface n i2) i1 i2
miRootPostId)
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe PostId
pId forall a. Eq a => a -> a -> Bool
== Maybe PostId
threadRootPostId) forall a b. (a -> b) -> a -> b
$ do
                    HasCallStack => TeamId -> Traversal' ChatState ThreadInterface
threadInterface(TeamId
tId)forall b c a. (b -> c) -> (a -> b) -> a -> c
.forall n i. Lens' (MessageInterface n i) (EditState n)
miEditorforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall n. Lens' (EditState n) EphemeralEditState
esEphemeral forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= UserId -> UTCTime -> EphemeralEditState -> EphemeralEditState
addEphemeralStateTypingUser UserId
uId UTCTime
ts

-- | Handle the websocket event for when a user is updated, e.g. has changed
-- their nickname
handleUserUpdated :: User -> MH ()
handleUserUpdated :: User -> MH ()
handleUserUpdated User
user = do
    Lens' ChatState Users
csUsers forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= UserId -> (UserInfo -> UserInfo) -> Users -> Users
modifyUserById (User -> UserId
userId User
user)
        (\UserInfo
ui -> User -> Bool -> UserInfo
userInfoFromUser User
user (UserInfo
ui forall s a. s -> Getting a s a -> a
^. Lens' UserInfo Bool
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 :: UserFetch -> (UserInfo -> MH ()) -> MH ()
withFetchedUser UserFetch
fetch UserInfo -> MH ()
handle =
    UserFetch -> (Maybe UserInfo -> MH ()) -> MH ()
withFetchedUserMaybe UserFetch
fetch forall a b. (a -> b) -> a -> b
$ \Maybe UserInfo
u -> do
        case Maybe UserInfo
u of
            Maybe UserInfo
Nothing -> Text -> MH ()
postErrorMessage' Text
"No such user"
            Just UserInfo
user -> UserInfo -> MH ()
handle UserInfo
user

withFetchedUserMaybe :: UserFetch -> (Maybe UserInfo -> MH ()) -> MH ()
withFetchedUserMaybe :: UserFetch -> (Maybe UserInfo -> MH ()) -> MH ()
withFetchedUserMaybe UserFetch
fetch Maybe UserInfo -> MH ()
handle = do
    ChatState
st <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use forall a. a -> a
id
    Session
session <- MH Session
getSession

    let localMatch :: Maybe UserInfo
localMatch = case UserFetch
fetch of
            UserFetchById UserId
uId -> UserId -> ChatState -> Maybe UserInfo
userById UserId
uId ChatState
st
            UserFetchByUsername Text
uname -> Text -> ChatState -> Maybe UserInfo
userByUsername Text
uname ChatState
st
            UserFetchByNickname Text
nick -> Text -> ChatState -> Maybe UserInfo
userByNickname Text
nick ChatState
st

    case Maybe UserInfo
localMatch of
        Just UserInfo
user -> Maybe UserInfo -> MH ()
handle forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just UserInfo
user
        Maybe UserInfo
Nothing -> do
            LogCategory -> Text -> MH ()
mhLog LogCategory
LogGeneral forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ String
"withFetchedUserMaybe: getting " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show UserFetch
fetch
            AsyncPriority -> IO (Maybe (MH ())) -> MH ()
doAsyncWith AsyncPriority
Normal forall a b. (a -> b) -> a -> b
$ do
                Seq User
results <- case UserFetch
fetch of
                    UserFetchById UserId
uId ->
                        Seq UserId -> Session -> IO (Seq User)
MM.mmGetUsersByIds (forall a. a -> Seq a
Seq.singleton UserId
uId) Session
session
                    UserFetchByUsername Text
uname ->
                        Seq Text -> Session -> IO (Seq User)
MM.mmGetUsersByUsernames (forall a. a -> Seq a
Seq.singleton forall a b. (a -> b) -> a -> b
$ Text -> Text
trimUserSigil Text
uname) Session
session
                    UserFetchByNickname Text
nick -> do
                        let req :: UserSearch
req = UserSearch { userSearchTerm :: Text
userSearchTerm = Text -> Text
trimUserSigil Text
nick
                                             , userSearchAllowInactive :: Bool
userSearchAllowInactive = Bool
True
                                             , userSearchWithoutTeam :: Bool
userSearchWithoutTeam = Bool
True
                                             , userSearchInChannelId :: Maybe ChannelId
userSearchInChannelId = forall a. Maybe a
Nothing
                                             , userSearchNotInTeamId :: Maybe TeamId
userSearchNotInTeamId = forall a. Maybe a
Nothing
                                             , userSearchNotInChannelId :: Maybe ChannelId
userSearchNotInChannelId = forall a. Maybe a
Nothing
                                             , userSearchTeamId :: Maybe TeamId
userSearchTeamId = forall a. Maybe a
Nothing
                                             }
                        UserSearch -> Session -> IO (Seq User)
MM.mmSearchUsers UserSearch
req Session
session

                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ do
                    [UserInfo]
infos <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList Seq User
results) forall a b. (a -> b) -> a -> b
$ \User
u -> do
                        let info :: UserInfo
info = User -> Bool -> UserInfo
userInfoFromUser User
u Bool
True
                        UserInfo -> MH ()
addNewUser UserInfo
info
                        forall (m :: * -> *) a. Monad m => a -> m a
return UserInfo
info

                    case [UserInfo]
infos of
                        [UserInfo
match] -> Maybe UserInfo -> MH ()
handle forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just UserInfo
match
                        [] -> Maybe UserInfo -> MH ()
handle forall a. Maybe a
Nothing
                        [UserInfo]
_ -> Text -> MH ()
postErrorMessage' Text
"Error: ambiguous user information"