{-# 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.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 -> MH ()
handleTypingUser :: UserId -> ChannelId -> MH ()
handleTypingUser UserId
uId ChannelId
cId = 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
            (ClientChannels -> Identity ClientChannels)
-> ChatState -> Identity ChatState
Lens' ChatState ClientChannels
csChannels ((ClientChannels -> Identity ClientChannels)
 -> ChatState -> Identity ChatState)
-> (ClientChannels -> ClientChannels) -> MH ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= ChannelId
-> (ClientChannel -> ClientChannel)
-> ClientChannels
-> ClientChannels
modifyChannelById ChannelId
cId (UserId -> UTCTime -> ClientChannel -> ClientChannel
addChannelTypingUser 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"