{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveFunctor #-}

module Matterhorn.Types.Users
  ( UserInfo(..)
  , UserStatus(..)
  , Users   -- constructor remains internal
  -- * Lenses created for accessing UserInfo fields
  , uiName, uiId, uiStatus, uiInTeam, uiNickName, uiFirstName, uiLastName, uiEmail
  , uiDeleted
  -- * Various operations on UserInfo
  -- * Creating UserInfo objects
  , userInfoFromUser
  -- * Miscellaneous
  , getUsernameSet
  , trimUserSigil
  , addUserSigil
  , statusFromText
  , findUserById
  , findUserByUsername
  , findUserByNickname
  , noUsers, addUser, allUsers
  , modifyUserById
  , userDeleted
  , TypingUsers
  , noTypingUsers
  , addTypingUser
  , allTypingUsers
  , expireTypingUsers
  , getAllUserIds
  )
where

import           Prelude ()
import           Matterhorn.Prelude

import qualified Data.HashMap.Strict as HM
import qualified Data.Set as S
import           Data.Semigroup ( Max(..) )
import qualified Data.Text as T
import           Lens.Micro.Platform ( (%~), makeLenses, ix )

import           Network.Mattermost.Types ( UserId(..), User(..) )

import           Matterhorn.Types.Common
import           Matterhorn.Constants ( userSigil )

-- * 'UserInfo' Values

-- | A 'UserInfo' value represents everything we need to know at
--   runtime about a user
data UserInfo = UserInfo
  { UserInfo -> Text
_uiName      :: Text
  , UserInfo -> UserId
_uiId        :: UserId
  , UserInfo -> UserStatus
_uiStatus    :: UserStatus
  , UserInfo -> Bool
_uiInTeam    :: Bool
  , UserInfo -> Maybe Text
_uiNickName  :: Maybe Text
  , UserInfo -> Text
_uiFirstName :: Text
  , UserInfo -> Text
_uiLastName  :: Text
  , UserInfo -> Text
_uiEmail     :: Text
  , UserInfo -> Bool
_uiDeleted   :: Bool
  } deriving (UserInfo -> UserInfo -> Bool
(UserInfo -> UserInfo -> Bool)
-> (UserInfo -> UserInfo -> Bool) -> Eq UserInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UserInfo -> UserInfo -> Bool
$c/= :: UserInfo -> UserInfo -> Bool
== :: UserInfo -> UserInfo -> Bool
$c== :: UserInfo -> UserInfo -> Bool
Eq, Int -> UserInfo -> ShowS
[UserInfo] -> ShowS
UserInfo -> String
(Int -> UserInfo -> ShowS)
-> (UserInfo -> String) -> ([UserInfo] -> ShowS) -> Show UserInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UserInfo] -> ShowS
$cshowList :: [UserInfo] -> ShowS
show :: UserInfo -> String
$cshow :: UserInfo -> String
showsPrec :: Int -> UserInfo -> ShowS
$cshowsPrec :: Int -> UserInfo -> ShowS
Show)

-- | Is this user deleted?
userDeleted :: User -> Bool
userDeleted :: User -> Bool
userDeleted User
u =
    case User -> Maybe ServerTime
userCreateAt User
u of
        Maybe ServerTime
Nothing -> Bool
False
        Just ServerTime
c -> User -> ServerTime
userDeleteAt User
u ServerTime -> ServerTime -> Bool
forall a. Ord a => a -> a -> Bool
> ServerTime
c

-- | Create a 'UserInfo' value from a Mattermost 'User' value
userInfoFromUser :: User -> Bool -> UserInfo
userInfoFromUser :: User -> Bool -> UserInfo
userInfoFromUser User
up Bool
inTeam = UserInfo :: Text
-> UserId
-> UserStatus
-> Bool
-> Maybe Text
-> Text
-> Text
-> Text
-> Bool
-> UserInfo
UserInfo
  { _uiName :: Text
_uiName      = User -> Text
userUsername User
up
  , _uiId :: UserId
_uiId        = User -> UserId
userId User
up
  , _uiStatus :: UserStatus
_uiStatus    = UserStatus
Offline
  , _uiInTeam :: Bool
_uiInTeam    = Bool
inTeam
  , _uiNickName :: Maybe Text
_uiNickName  =
      let nick :: Text
nick = UserText -> Text
sanitizeUserText (UserText -> Text) -> UserText -> Text
forall a b. (a -> b) -> a -> b
$ User -> UserText
userNickname User
up
      in if Text -> Bool
T.null Text
nick then Maybe Text
forall a. Maybe a
Nothing else Text -> Maybe Text
forall a. a -> Maybe a
Just Text
nick
  , _uiFirstName :: Text
_uiFirstName = UserText -> Text
sanitizeUserText (UserText -> Text) -> UserText -> Text
forall a b. (a -> b) -> a -> b
$ User -> UserText
userFirstName User
up
  , _uiLastName :: Text
_uiLastName  = UserText -> Text
sanitizeUserText (UserText -> Text) -> UserText -> Text
forall a b. (a -> b) -> a -> b
$ User -> UserText
userLastName User
up
  , _uiEmail :: Text
_uiEmail     = UserText -> Text
sanitizeUserText (UserText -> Text) -> UserText -> Text
forall a b. (a -> b) -> a -> b
$ User -> UserText
userEmail User
up
  , _uiDeleted :: Bool
_uiDeleted   = User -> Bool
userDeleted User
up
  }

-- | The 'UserStatus' value represents possible current status for
--   a user
data UserStatus
  = Online
  | Away
  | Offline
  | DoNotDisturb
  | Other Text
    deriving (UserStatus -> UserStatus -> Bool
(UserStatus -> UserStatus -> Bool)
-> (UserStatus -> UserStatus -> Bool) -> Eq UserStatus
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UserStatus -> UserStatus -> Bool
$c/= :: UserStatus -> UserStatus -> Bool
== :: UserStatus -> UserStatus -> Bool
$c== :: UserStatus -> UserStatus -> Bool
Eq, Int -> UserStatus -> ShowS
[UserStatus] -> ShowS
UserStatus -> String
(Int -> UserStatus -> ShowS)
-> (UserStatus -> String)
-> ([UserStatus] -> ShowS)
-> Show UserStatus
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UserStatus] -> ShowS
$cshowList :: [UserStatus] -> ShowS
show :: UserStatus -> String
$cshow :: UserStatus -> String
showsPrec :: Int -> UserStatus -> ShowS
$cshowsPrec :: Int -> UserStatus -> ShowS
Show)

statusFromText :: Text -> UserStatus
statusFromText :: Text -> UserStatus
statusFromText Text
t = case Text
t of
  Text
"online"  -> UserStatus
Online
  Text
"offline" -> UserStatus
Offline
  Text
"away"    -> UserStatus
Away
  Text
"dnd"     -> UserStatus
DoNotDisturb
  Text
_         -> Text -> UserStatus
Other Text
t

-- ** 'UserInfo' lenses

makeLenses ''UserInfo

-- ** Manage the collection of all Users

-- | Define a binary kinded type to allow derivation of functor.
data AllMyUsers a =
    AllUsers { AllMyUsers a -> HashMap UserId a
_ofUsers :: HashMap UserId a
             , AllMyUsers a -> Set Text
_usernameSet :: S.Set Text
             }
             deriving a -> AllMyUsers b -> AllMyUsers a
(a -> b) -> AllMyUsers a -> AllMyUsers b
(forall a b. (a -> b) -> AllMyUsers a -> AllMyUsers b)
-> (forall a b. a -> AllMyUsers b -> AllMyUsers a)
-> Functor AllMyUsers
forall a b. a -> AllMyUsers b -> AllMyUsers a
forall a b. (a -> b) -> AllMyUsers a -> AllMyUsers b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> AllMyUsers b -> AllMyUsers a
$c<$ :: forall a b. a -> AllMyUsers b -> AllMyUsers a
fmap :: (a -> b) -> AllMyUsers a -> AllMyUsers b
$cfmap :: forall a b. (a -> b) -> AllMyUsers a -> AllMyUsers b
Functor

makeLenses ''AllMyUsers

-- | Define the exported typename which universally binds the
-- collection to the UserInfo type.
type Users = AllMyUsers UserInfo

getUsernameSet :: Users -> S.Set Text
getUsernameSet :: Users -> Set Text
getUsernameSet = Users -> Set Text
forall a. AllMyUsers a -> Set Text
_usernameSet

-- | Initial collection of Users with no members
noUsers :: Users
noUsers :: Users
noUsers = HashMap UserId UserInfo -> Set Text -> Users
forall a. HashMap UserId a -> Set Text -> AllMyUsers a
AllUsers HashMap UserId UserInfo
forall k v. HashMap k v
HM.empty Set Text
forall a. Monoid a => a
mempty

getAllUserIds :: Users -> [UserId]
getAllUserIds :: Users -> [UserId]
getAllUserIds = HashMap UserId UserInfo -> [UserId]
forall k v. HashMap k v -> [k]
HM.keys (HashMap UserId UserInfo -> [UserId])
-> (Users -> HashMap UserId UserInfo) -> Users -> [UserId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Users -> HashMap UserId UserInfo
forall a. AllMyUsers a -> HashMap UserId a
_ofUsers

-- | Add a member to the existing collection of Users
addUser :: UserInfo -> Users -> Users
addUser :: UserInfo -> Users -> Users
addUser UserInfo
userinfo Users
u =
    Users
u Users -> (Users -> Users) -> Users
forall a b. a -> (a -> b) -> b
& (HashMap UserId UserInfo -> Identity (HashMap UserId UserInfo))
-> Users -> Identity Users
forall a a.
Lens
  (AllMyUsers a) (AllMyUsers a) (HashMap UserId a) (HashMap UserId a)
ofUsers ((HashMap UserId UserInfo -> Identity (HashMap UserId UserInfo))
 -> Users -> Identity Users)
-> (HashMap UserId UserInfo -> HashMap UserId UserInfo)
-> Users
-> Users
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ UserId
-> UserInfo -> HashMap UserId UserInfo -> HashMap UserId UserInfo
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert (UserInfo
userinfoUserInfo -> Getting UserId UserInfo UserId -> UserId
forall s a. s -> Getting a s a -> a
^.Getting UserId UserInfo UserId
Lens' UserInfo UserId
uiId) UserInfo
userinfo
      Users -> (Users -> Users) -> Users
forall a b. a -> (a -> b) -> b
& (Set Text -> Identity (Set Text)) -> Users -> Identity Users
forall a. Lens' (AllMyUsers a) (Set Text)
usernameSet ((Set Text -> Identity (Set Text)) -> Users -> Identity Users)
-> (Set Text -> Set Text) -> Users -> Users
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Text -> Set Text -> Set Text
forall a. Ord a => a -> Set a -> Set a
S.insert (UserInfo
userinfoUserInfo -> Getting Text UserInfo Text -> Text
forall s a. s -> Getting a s a -> a
^.Getting Text UserInfo Text
Lens' UserInfo Text
uiName)

-- | Get a list of all known users
allUsers :: Users -> [UserInfo]
allUsers :: Users -> [UserInfo]
allUsers = HashMap UserId UserInfo -> [UserInfo]
forall k v. HashMap k v -> [v]
HM.elems (HashMap UserId UserInfo -> [UserInfo])
-> (Users -> HashMap UserId UserInfo) -> Users -> [UserInfo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Users -> HashMap UserId UserInfo
forall a. AllMyUsers a -> HashMap UserId a
_ofUsers

-- | Define the exported typename to represent the collection of users
-- | who are currently typing. The values kept against the user id keys are the
-- | latest timestamps of typing events from the server.
type TypingUsers = AllMyUsers (Max UTCTime)

-- | Initial collection of TypingUsers with no members
noTypingUsers :: TypingUsers
noTypingUsers :: TypingUsers
noTypingUsers = HashMap UserId (Max UTCTime) -> Set Text -> TypingUsers
forall a. HashMap UserId a -> Set Text -> AllMyUsers a
AllUsers HashMap UserId (Max UTCTime)
forall k v. HashMap k v
HM.empty Set Text
forall a. Monoid a => a
mempty

-- | Add a member to the existing collection of TypingUsers
addTypingUser :: UserId -> UTCTime -> TypingUsers -> TypingUsers
addTypingUser :: UserId -> UTCTime -> TypingUsers -> TypingUsers
addTypingUser UserId
uId UTCTime
ts = (HashMap UserId (Max UTCTime)
 -> Identity (HashMap UserId (Max UTCTime)))
-> TypingUsers -> Identity TypingUsers
forall a a.
Lens
  (AllMyUsers a) (AllMyUsers a) (HashMap UserId a) (HashMap UserId a)
ofUsers ((HashMap UserId (Max UTCTime)
  -> Identity (HashMap UserId (Max UTCTime)))
 -> TypingUsers -> Identity TypingUsers)
-> (HashMap UserId (Max UTCTime) -> HashMap UserId (Max UTCTime))
-> TypingUsers
-> TypingUsers
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Max UTCTime -> Max UTCTime -> Max UTCTime)
-> UserId
-> Max UTCTime
-> HashMap UserId (Max UTCTime)
-> HashMap UserId (Max UTCTime)
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> k -> v -> HashMap k v -> HashMap k v
HM.insertWith Max UTCTime -> Max UTCTime -> Max UTCTime
forall a. Semigroup a => a -> a -> a
(<>) UserId
uId (UTCTime -> Max UTCTime
forall a. a -> Max a
Max UTCTime
ts)

-- | Get a list of all typing users
allTypingUsers :: TypingUsers -> [UserId]
allTypingUsers :: TypingUsers -> [UserId]
allTypingUsers = HashMap UserId (Max UTCTime) -> [UserId]
forall k v. HashMap k v -> [k]
HM.keys (HashMap UserId (Max UTCTime) -> [UserId])
-> (TypingUsers -> HashMap UserId (Max UTCTime))
-> TypingUsers
-> [UserId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypingUsers -> HashMap UserId (Max UTCTime)
forall a. AllMyUsers a -> HashMap UserId a
_ofUsers

-- | Remove all the expired users from the collection of TypingUsers.
-- | Expiry is decided by the given timestamp.
expireTypingUsers :: UTCTime -> TypingUsers -> TypingUsers
expireTypingUsers :: UTCTime -> TypingUsers -> TypingUsers
expireTypingUsers UTCTime
expiryTimestamp =
    (HashMap UserId (Max UTCTime)
 -> Identity (HashMap UserId (Max UTCTime)))
-> TypingUsers -> Identity TypingUsers
forall a a.
Lens
  (AllMyUsers a) (AllMyUsers a) (HashMap UserId a) (HashMap UserId a)
ofUsers ((HashMap UserId (Max UTCTime)
  -> Identity (HashMap UserId (Max UTCTime)))
 -> TypingUsers -> Identity TypingUsers)
-> (HashMap UserId (Max UTCTime) -> HashMap UserId (Max UTCTime))
-> TypingUsers
-> TypingUsers
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Max UTCTime -> Bool)
-> HashMap UserId (Max UTCTime) -> HashMap UserId (Max UTCTime)
forall v k. (v -> Bool) -> HashMap k v -> HashMap k v
HM.filter (\(Max UTCTime
ts') -> UTCTime
ts' UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
>= UTCTime
expiryTimestamp)

-- | Get the User information given the UserId
findUserById :: UserId -> Users -> Maybe UserInfo
findUserById :: UserId -> Users -> Maybe UserInfo
findUserById UserId
uId = UserId -> HashMap UserId UserInfo -> Maybe UserInfo
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup UserId
uId (HashMap UserId UserInfo -> Maybe UserInfo)
-> (Users -> HashMap UserId UserInfo) -> Users -> Maybe UserInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Users -> HashMap UserId UserInfo
forall a. AllMyUsers a -> HashMap UserId a
_ofUsers

-- | Get the User information given the user's name. This is an exact
-- match on the username field. It will automatically trim a user sigil
-- from the input.
findUserByUsername :: Text -> Users -> Maybe (UserId, UserInfo)
findUserByUsername :: Text -> Users -> Maybe (UserId, UserInfo)
findUserByUsername Text
name Users
allusers =
  case ((UserId, UserInfo) -> Bool)
-> [(UserId, UserInfo)] -> [(UserId, UserInfo)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Text
trimUserSigil Text
name) (Text -> Bool)
-> ((UserId, UserInfo) -> Text) -> (UserId, UserInfo) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UserInfo -> Text
_uiName (UserInfo -> Text)
-> ((UserId, UserInfo) -> UserInfo) -> (UserId, UserInfo) -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UserId, UserInfo) -> UserInfo
forall a b. (a, b) -> b
snd) ([(UserId, UserInfo)] -> [(UserId, UserInfo)])
-> [(UserId, UserInfo)] -> [(UserId, UserInfo)]
forall a b. (a -> b) -> a -> b
$ HashMap UserId UserInfo -> [(UserId, UserInfo)]
forall k v. HashMap k v -> [(k, v)]
HM.toList (HashMap UserId UserInfo -> [(UserId, UserInfo)])
-> HashMap UserId UserInfo -> [(UserId, UserInfo)]
forall a b. (a -> b) -> a -> b
$ Users -> HashMap UserId UserInfo
forall a. AllMyUsers a -> HashMap UserId a
_ofUsers Users
allusers of
    ((UserId, UserInfo)
usr : []) -> (UserId, UserInfo) -> Maybe (UserId, UserInfo)
forall a. a -> Maybe a
Just (UserId, UserInfo)
usr
    [(UserId, UserInfo)]
_ -> Maybe (UserId, UserInfo)
forall a. Maybe a
Nothing

-- | Get the User information given the user's name. This is an exact
-- match on the nickname field, not necessarily the presented name. It
-- will automatically trim a user sigil from the input.
findUserByNickname:: Text -> Users -> Maybe (UserId, UserInfo)
findUserByNickname :: Text -> Users -> Maybe (UserId, UserInfo)
findUserByNickname Text
nick Users
us =
  case ((UserId, UserInfo) -> Bool)
-> [(UserId, UserInfo)] -> [(UserId, UserInfo)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== (Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
trimUserSigil Text
nick)) (Maybe Text -> Bool)
-> ((UserId, UserInfo) -> Maybe Text) -> (UserId, UserInfo) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UserInfo -> Maybe Text
_uiNickName (UserInfo -> Maybe Text)
-> ((UserId, UserInfo) -> UserInfo)
-> (UserId, UserInfo)
-> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UserId, UserInfo) -> UserInfo
forall a b. (a, b) -> b
snd) ([(UserId, UserInfo)] -> [(UserId, UserInfo)])
-> [(UserId, UserInfo)] -> [(UserId, UserInfo)]
forall a b. (a -> b) -> a -> b
$ HashMap UserId UserInfo -> [(UserId, UserInfo)]
forall k v. HashMap k v -> [(k, v)]
HM.toList (HashMap UserId UserInfo -> [(UserId, UserInfo)])
-> HashMap UserId UserInfo -> [(UserId, UserInfo)]
forall a b. (a -> b) -> a -> b
$ Users -> HashMap UserId UserInfo
forall a. AllMyUsers a -> HashMap UserId a
_ofUsers Users
us of
    ((UserId, UserInfo)
pair : []) -> (UserId, UserInfo) -> Maybe (UserId, UserInfo)
forall a. a -> Maybe a
Just (UserId, UserInfo)
pair
    [(UserId, UserInfo)]
_ -> Maybe (UserId, UserInfo)
forall a. Maybe a
Nothing

trimUserSigil :: Text -> Text
trimUserSigil :: Text -> Text
trimUserSigil Text
n
    | Text
userSigil Text -> Text -> Bool
`T.isPrefixOf` Text
n = Text -> Text
T.tail Text
n
    | Bool
otherwise                  = Text
n

addUserSigil :: T.Text -> T.Text
addUserSigil :: Text -> Text
addUserSigil Text
t | Text
userSigil Text -> Text -> Bool
`T.isPrefixOf` Text
t = Text
t
               | Bool
otherwise                  = Text
userSigil Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t

-- | Extract a specific user from the collection and perform an
-- endomorphism operation on it, then put it back into the collection.
modifyUserById :: UserId -> (UserInfo -> UserInfo) -> Users -> Users
modifyUserById :: UserId -> (UserInfo -> UserInfo) -> Users -> Users
modifyUserById UserId
uId UserInfo -> UserInfo
f = (HashMap UserId UserInfo -> Identity (HashMap UserId UserInfo))
-> Users -> Identity Users
forall a a.
Lens
  (AllMyUsers a) (AllMyUsers a) (HashMap UserId a) (HashMap UserId a)
ofUsers((HashMap UserId UserInfo -> Identity (HashMap UserId UserInfo))
 -> Users -> Identity Users)
-> ((UserInfo -> Identity UserInfo)
    -> HashMap UserId UserInfo -> Identity (HashMap UserId UserInfo))
-> (UserInfo -> Identity UserInfo)
-> Users
-> Identity Users
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Index (HashMap UserId UserInfo)
-> Traversal'
     (HashMap UserId UserInfo) (IxValue (HashMap UserId UserInfo))
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix(UserId
Index (HashMap UserId UserInfo)
uId) ((UserInfo -> Identity UserInfo) -> Users -> Identity Users)
-> (UserInfo -> UserInfo) -> Users -> Users
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ UserInfo -> UserInfo
f