{-# 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 a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq User
nUsers
[UserInfo] -> IO [UserInfo]
forall a. a -> IO a
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 a b. MH a -> MH b -> MH b
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 <- 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 a. IO a -> MH a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
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 (f :: * -> *).
Functor f =>
(EditState n -> f (EditState n))
-> MessageInterface n i -> f (MessageInterface n i)
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 (f :: * -> *).
Functor f =>
(EphemeralEditState -> f EphemeralEditState)
-> EditState n -> f (EditState n)
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
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 i1 i2 (f :: * -> *).
Functor f =>
(i1 -> f i2) -> MessageInterface n i1 -> f (MessageInterface n 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 (f :: * -> *).
Functor f =>
(EditState n -> f (EditState n))
-> MessageInterface n i -> f (MessageInterface n i)
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 (f :: * -> *).
Functor f =>
(EphemeralEditState -> f EphemeralEditState)
-> EditState n -> f (EditState n)
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
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))
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 { 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 a. a -> IO a
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 a. Seq a -> [a]
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 a. a -> MH a
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"