1{-# LANGUAGE TemplateHaskell #-}
2{-# LANGUAGE DeriveFunctor #-}
3
4module Matterhorn.Types.Users
5  ( UserInfo(..)
6  , UserStatus(..)
7  , Users   -- constructor remains internal
8  -- * Lenses created for accessing UserInfo fields
9  , uiName, uiId, uiStatus, uiInTeam, uiNickName, uiFirstName, uiLastName, uiEmail
10  , uiDeleted
11  -- * Various operations on UserInfo
12  -- * Creating UserInfo objects
13  , userInfoFromUser
14  -- * Miscellaneous
15  , getUsernameSet
16  , trimUserSigil
17  , statusFromText
18  , findUserById
19  , findUserByUsername
20  , findUserByNickname
21  , noUsers, addUser, allUsers
22  , modifyUserById
23  , userDeleted
24  , TypingUsers
25  , noTypingUsers
26  , addTypingUser
27  , allTypingUsers
28  , expireTypingUsers
29  , getAllUserIds
30  )
31where
32
33import           Prelude ()
34import           Matterhorn.Prelude
35
36import qualified Data.HashMap.Strict as HM
37import qualified Data.Set as S
38import           Data.Semigroup ( Max(..) )
39import qualified Data.Text as T
40import           Lens.Micro.Platform ( (%~), makeLenses, ix )
41
42import           Network.Mattermost.Types ( UserId(..), User(..) )
43
44import           Matterhorn.Types.Common
45import           Matterhorn.Constants ( userSigil )
46
47-- * 'UserInfo' Values
48
49-- | A 'UserInfo' value represents everything we need to know at
50--   runtime about a user
51data UserInfo = UserInfo
52  { _uiName      :: Text
53  , _uiId        :: UserId
54  , _uiStatus    :: UserStatus
55  , _uiInTeam    :: Bool
56  , _uiNickName  :: Maybe Text
57  , _uiFirstName :: Text
58  , _uiLastName  :: Text
59  , _uiEmail     :: Text
60  , _uiDeleted   :: Bool
61  } deriving (Eq, Show)
62
63-- | Is this user deleted?
64userDeleted :: User -> Bool
65userDeleted u =
66    case userCreateAt u of
67        Nothing -> False
68        Just c -> userDeleteAt u > c
69
70-- | Create a 'UserInfo' value from a Mattermost 'User' value
71userInfoFromUser :: User -> Bool -> UserInfo
72userInfoFromUser up inTeam = UserInfo
73  { _uiName      = userUsername up
74  , _uiId        = userId up
75  , _uiStatus    = Offline
76  , _uiInTeam    = inTeam
77  , _uiNickName  =
78      let nick = sanitizeUserText $ userNickname up
79      in if T.null nick then Nothing else Just nick
80  , _uiFirstName = sanitizeUserText $ userFirstName up
81  , _uiLastName  = sanitizeUserText $ userLastName up
82  , _uiEmail     = sanitizeUserText $ userEmail up
83  , _uiDeleted   = userDeleted up
84  }
85
86-- | The 'UserStatus' value represents possible current status for
87--   a user
88data UserStatus
89  = Online
90  | Away
91  | Offline
92  | DoNotDisturb
93  | Other Text
94    deriving (Eq, Show)
95
96statusFromText :: Text -> UserStatus
97statusFromText t = case t of
98  "online"  -> Online
99  "offline" -> Offline
100  "away"    -> Away
101  "dnd"     -> DoNotDisturb
102  _         -> Other t
103
104-- ** 'UserInfo' lenses
105
106makeLenses ''UserInfo
107
108-- ** Manage the collection of all Users
109
110-- | Define a binary kinded type to allow derivation of functor.
111data AllMyUsers a =
112    AllUsers { _ofUsers :: HashMap UserId a
113             , _usernameSet :: S.Set Text
114             }
115             deriving Functor
116
117makeLenses ''AllMyUsers
118
119-- | Define the exported typename which universally binds the
120-- collection to the UserInfo type.
121type Users = AllMyUsers UserInfo
122
123getUsernameSet :: Users -> S.Set Text
124getUsernameSet = _usernameSet
125
126-- | Initial collection of Users with no members
127noUsers :: Users
128noUsers = AllUsers HM.empty mempty
129
130getAllUserIds :: Users -> [UserId]
131getAllUserIds = HM.keys . _ofUsers
132
133-- | Add a member to the existing collection of Users
134addUser :: UserInfo -> Users -> Users
135addUser userinfo u =
136    u & ofUsers %~ HM.insert (userinfo^.uiId) userinfo
137      & usernameSet %~ S.insert (userinfo^.uiName)
138
139-- | Get a list of all known users
140allUsers :: Users -> [UserInfo]
141allUsers = HM.elems . _ofUsers
142
143-- | Define the exported typename to represent the collection of users
144-- | who are currently typing. The values kept against the user id keys are the
145-- | latest timestamps of typing events from the server.
146type TypingUsers = AllMyUsers (Max UTCTime)
147
148-- | Initial collection of TypingUsers with no members
149noTypingUsers :: TypingUsers
150noTypingUsers = AllUsers HM.empty mempty
151
152-- | Add a member to the existing collection of TypingUsers
153addTypingUser :: UserId -> UTCTime -> TypingUsers -> TypingUsers
154addTypingUser uId ts = ofUsers %~ HM.insertWith (<>) uId (Max ts)
155
156-- | Get a list of all typing users
157allTypingUsers :: TypingUsers -> [UserId]
158allTypingUsers = HM.keys . _ofUsers
159
160-- | Remove all the expired users from the collection of TypingUsers.
161-- | Expiry is decided by the given timestamp.
162expireTypingUsers :: UTCTime -> TypingUsers -> TypingUsers
163expireTypingUsers expiryTimestamp =
164    ofUsers %~ HM.filter (\(Max ts') -> ts' >= expiryTimestamp)
165
166-- | Get the User information given the UserId
167findUserById :: UserId -> Users -> Maybe UserInfo
168findUserById uId = HM.lookup uId . _ofUsers
169
170-- | Get the User information given the user's name. This is an exact
171-- match on the username field. It will automatically trim a user sigil
172-- from the input.
173findUserByUsername :: Text -> Users -> Maybe (UserId, UserInfo)
174findUserByUsername name allusers =
175  case filter ((== trimUserSigil name) . _uiName . snd) $ HM.toList $ _ofUsers allusers of
176    (usr : []) -> Just usr
177    _ -> Nothing
178
179-- | Get the User information given the user's name. This is an exact
180-- match on the nickname field, not necessarily the presented name. It
181-- will automatically trim a user sigil from the input.
182findUserByNickname:: Text -> Users -> Maybe (UserId, UserInfo)
183findUserByNickname nick us =
184  case filter ((== (Just $ trimUserSigil nick)) . _uiNickName . snd) $ HM.toList $ _ofUsers us of
185    (pair : []) -> Just pair
186    _ -> Nothing
187
188trimUserSigil :: Text -> Text
189trimUserSigil n
190    | userSigil `T.isPrefixOf` n = T.tail n
191    | otherwise                  = n
192
193-- | Extract a specific user from the collection and perform an
194-- endomorphism operation on it, then put it back into the collection.
195modifyUserById :: UserId -> (UserInfo -> UserInfo) -> Users -> Users
196modifyUserById uId f = ofUsers.ix(uId) %~ f
197