{-# 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
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
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
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
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))
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"