{-# 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
    AsyncPriority
-> (Session -> IO [UserInfo])
-> ([UserInfo] -> Maybe (MH ()))
-> MH ()
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 = Seq User -> [User]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq User
nUsers
                 [UserInfo] -> IO [UserInfo]
forall (m :: * -> *) a. Monad m => a -> m a
return ([UserInfo] -> IO [UserInfo]) -> [UserInfo] -> IO [UserInfo]
forall a b. (a -> b) -> a -> b
$ User -> UserInfo
usrInfo (User -> UserInfo) -> [User] -> [UserInfo]
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 = MH () -> Maybe (MH ())
forall a. a -> Maybe a
Just (MH () -> Maybe (MH ())) -> MH () -> Maybe (MH ())
forall a b. (a -> b) -> a -> b
$ (UserInfo -> MH ()) -> [UserInfo] -> MH ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ UserInfo -> MH ()
addNewUser [UserInfo]
is MH () -> MH () -> MH ()
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 <- Getting Config ChatState Config -> MH Config
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use ((ChatResources -> Const Config ChatResources)
-> ChatState -> Const Config ChatState
Lens' ChatState ChatResources
csResources((ChatResources -> Const Config ChatResources)
 -> ChatState -> Const Config ChatState)
-> ((Config -> Const Config Config)
    -> ChatResources -> Const Config ChatResources)
-> Getting Config ChatState Config
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Config -> Const Config Config)
-> ChatResources -> Const Config ChatResources
Lens' ChatResources Config
crConfiguration)
    Bool -> MH () -> MH ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Config -> Bool
configShowTypingIndicator Config
config) (MH () -> MH ()) -> MH () -> MH ()
forall a b. (a -> b) -> a -> b
$ do
        UserFetch -> (UserInfo -> MH ()) -> MH ()
withFetchedUser (UserId -> UserFetch
UserFetchById UserId
uId) ((UserInfo -> MH ()) -> MH ()) -> (UserInfo -> MH ()) -> MH ()
forall a b. (a -> b) -> a -> b
$ MH () -> UserInfo -> MH ()
forall a b. a -> b -> a
const (MH () -> UserInfo -> MH ()) -> MH () -> UserInfo -> MH ()
forall a b. (a -> b) -> a -> b
$ do
            UTCTime
ts <- IO UTCTime -> MH UTCTime
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)((ClientChannel -> Identity ClientChannel)
 -> ChatState -> Identity ChatState)
-> ((EphemeralEditState -> Identity EphemeralEditState)
    -> ClientChannel -> Identity ClientChannel)
-> (EphemeralEditState -> Identity EphemeralEditState)
-> ChatState
-> Identity ChatState
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(MessageInterface Name () -> Identity (MessageInterface Name ()))
-> ClientChannel -> Identity ClientChannel
Lens' ClientChannel (MessageInterface Name ())
ccMessageInterface((MessageInterface Name () -> Identity (MessageInterface Name ()))
 -> ClientChannel -> Identity ClientChannel)
-> ((EphemeralEditState -> Identity EphemeralEditState)
    -> MessageInterface Name () -> Identity (MessageInterface Name ()))
-> (EphemeralEditState -> Identity EphemeralEditState)
-> ClientChannel
-> Identity ClientChannel
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(EditState Name -> Identity (EditState Name))
-> MessageInterface Name () -> Identity (MessageInterface Name ())
forall n i. Lens' (MessageInterface n i) (EditState n)
miEditor((EditState Name -> Identity (EditState Name))
 -> MessageInterface Name () -> Identity (MessageInterface Name ()))
-> ((EphemeralEditState -> Identity EphemeralEditState)
    -> EditState Name -> Identity (EditState Name))
-> (EphemeralEditState -> Identity EphemeralEditState)
-> MessageInterface Name ()
-> Identity (MessageInterface Name ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(EphemeralEditState -> Identity EphemeralEditState)
-> EditState Name -> Identity (EditState Name)
forall n. Lens' (EditState n) EphemeralEditState
esEphemeral ((EphemeralEditState -> Identity EphemeralEditState)
 -> ChatState -> Identity ChatState)
-> (EphemeralEditState -> EphemeralEditState) -> MH ()
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 <- Getting
  (HashMap TeamId TeamState) ChatState (HashMap TeamId TeamState)
-> MH (HashMap TeamId TeamState)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting
  (HashMap TeamId TeamState) ChatState (HashMap TeamId TeamState)
Lens' ChatState (HashMap TeamId TeamState)
csTeams
            [TeamId] -> (TeamId -> MH ()) -> MH ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (HashMap TeamId TeamState -> [TeamId]
forall k v. HashMap k v -> [k]
HM.keys HashMap TeamId TeamState
teams) ((TeamId -> MH ()) -> MH ()) -> (TeamId -> MH ()) -> MH ()
forall a b. (a -> b) -> a -> b
$ \TeamId
tId -> do
                Maybe PostId
pId <- Getting (First PostId) ChatState PostId -> MH (Maybe PostId)
forall s (m :: * -> *) a.
MonadState s m =>
Getting (First a) s a -> m (Maybe a)
preuse (HasCallStack => TeamId -> Traversal' ChatState ThreadInterface
TeamId -> Traversal' ChatState ThreadInterface
threadInterface(TeamId
tId)((ThreadInterface -> Const (First PostId) ThreadInterface)
 -> ChatState -> Const (First PostId) ChatState)
-> ((PostId -> Const (First PostId) PostId)
    -> ThreadInterface -> Const (First PostId) ThreadInterface)
-> Getting (First PostId) ChatState PostId
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(PostId -> Const (First PostId) PostId)
-> ThreadInterface -> Const (First PostId) ThreadInterface
forall n i i2.
Lens (MessageInterface n i) (MessageInterface n i2) i i2
miRootPostId)
                Bool -> MH () -> MH ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe PostId
pId Maybe PostId -> Maybe PostId -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe PostId
threadRootPostId) (MH () -> MH ()) -> MH () -> MH ()
forall a b. (a -> b) -> a -> b
$ do
                    HasCallStack => TeamId -> Traversal' ChatState ThreadInterface
TeamId -> Traversal' ChatState ThreadInterface
threadInterface(TeamId
tId)((ThreadInterface -> Identity ThreadInterface)
 -> ChatState -> Identity ChatState)
-> ((EphemeralEditState -> Identity EphemeralEditState)
    -> ThreadInterface -> Identity ThreadInterface)
-> (EphemeralEditState -> Identity EphemeralEditState)
-> ChatState
-> Identity ChatState
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(EditState Name -> Identity (EditState Name))
-> ThreadInterface -> Identity ThreadInterface
forall n i. Lens' (MessageInterface n i) (EditState n)
miEditor((EditState Name -> Identity (EditState Name))
 -> ThreadInterface -> Identity ThreadInterface)
-> ((EphemeralEditState -> Identity EphemeralEditState)
    -> EditState Name -> Identity (EditState Name))
-> (EphemeralEditState -> Identity EphemeralEditState)
-> ThreadInterface
-> Identity ThreadInterface
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(EphemeralEditState -> Identity EphemeralEditState)
-> EditState Name -> Identity (EditState Name)
forall n. Lens' (EditState n) EphemeralEditState
esEphemeral ((EphemeralEditState -> Identity EphemeralEditState)
 -> ChatState -> Identity ChatState)
-> (EphemeralEditState -> EphemeralEditState) -> MH ()
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
    (Users -> Identity Users) -> ChatState -> Identity ChatState
Lens' ChatState Users
csUsers ((Users -> Identity Users) -> ChatState -> Identity ChatState)
-> (Users -> Users) -> MH ()
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 UserInfo -> Getting Bool UserInfo Bool -> Bool
forall s a. s -> Getting a s a -> a
^. Getting Bool UserInfo Bool
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 ((Maybe UserInfo -> MH ()) -> MH ())
-> (Maybe UserInfo -> MH ()) -> MH ()
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 <- Getting ChatState ChatState ChatState -> MH ChatState
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting ChatState ChatState ChatState
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 (Maybe UserInfo -> MH ()) -> Maybe UserInfo -> MH ()
forall a b. (a -> b) -> a -> b
$ UserInfo -> Maybe UserInfo
forall a. a -> Maybe a
Just UserInfo
user
        Maybe UserInfo
Nothing -> do
            LogCategory -> Text -> MH ()
mhLog LogCategory
LogGeneral (Text -> MH ()) -> Text -> MH ()
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"withFetchedUserMaybe: getting " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> UserFetch -> String
forall a. Show a => a -> String
show UserFetch
fetch
            AsyncPriority -> IO (Maybe (MH ())) -> MH ()
doAsyncWith AsyncPriority
Normal (IO (Maybe (MH ())) -> MH ()) -> IO (Maybe (MH ())) -> MH ()
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 (UserId -> Seq UserId
forall a. a -> Seq a
Seq.singleton UserId
uId) Session
session
                    UserFetchByUsername Text
uname ->
                        Seq Text -> Session -> IO (Seq User)
MM.mmGetUsersByUsernames (Text -> Seq Text
forall a. a -> Seq a
Seq.singleton (Text -> Seq Text) -> Text -> Seq Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
trimUserSigil Text
uname) Session
session
                    UserFetchByNickname Text
nick -> do
                        let req :: UserSearch
req = UserSearch :: Text
-> Bool
-> Bool
-> Maybe ChannelId
-> Maybe TeamId
-> Maybe ChannelId
-> Maybe TeamId
-> UserSearch
UserSearch { userSearchTerm :: Text
userSearchTerm = Text -> Text
trimUserSigil Text
nick
                                             , userSearchAllowInactive :: Bool
userSearchAllowInactive = Bool
True
                                             , userSearchWithoutTeam :: Bool
userSearchWithoutTeam = Bool
True
                                             , userSearchInChannelId :: Maybe ChannelId
userSearchInChannelId = Maybe ChannelId
forall a. Maybe a
Nothing
                                             , userSearchNotInTeamId :: Maybe TeamId
userSearchNotInTeamId = Maybe TeamId
forall a. Maybe a
Nothing
                                             , userSearchNotInChannelId :: Maybe ChannelId
userSearchNotInChannelId = Maybe ChannelId
forall a. Maybe a
Nothing
                                             , userSearchTeamId :: Maybe TeamId
userSearchTeamId = Maybe TeamId
forall a. Maybe a
Nothing
                                             }
                        UserSearch -> Session -> IO (Seq User)
MM.mmSearchUsers UserSearch
req Session
session

                Maybe (MH ()) -> IO (Maybe (MH ()))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (MH ()) -> IO (Maybe (MH ())))
-> Maybe (MH ()) -> IO (Maybe (MH ()))
forall a b. (a -> b) -> a -> b
$ MH () -> Maybe (MH ())
forall a. a -> Maybe a
Just (MH () -> Maybe (MH ())) -> MH () -> Maybe (MH ())
forall a b. (a -> b) -> a -> b
$ do
                    [UserInfo]
infos <- [User] -> (User -> MH UserInfo) -> MH [UserInfo]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Seq User -> [User]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList Seq User
results) ((User -> MH UserInfo) -> MH [UserInfo])
-> (User -> MH UserInfo) -> MH [UserInfo]
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
                        UserInfo -> MH UserInfo
forall (m :: * -> *) a. Monad m => a -> m a
return UserInfo
info

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