Users.hs

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

module 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
  , userSigil
  , trimUserSigil
  , statusFromText
  , findUserById
  , findUserByUsername
  , findUserByNickname
  , noUsers, addUser, allUsers
  , modifyUserById
  , userDeleted
  , TypingUsers
  , noTypingUsers
  , addTypingUser
  , allTypingUsers
  , expireTypingUsers
  , getAllUserIds
  )
where

import           Prelude ()
import           Prelude.MH

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           Types.Common

-- * 'UserInfo' Values

-- | A 'UserInfo' value represents everything we need to know at
--   runtime about a user
data UserInfo = UserInfo
  { _uiName      :: Text
  , _uiId        :: UserId
  , _uiStatus    :: UserStatus
  , _uiInTeam    :: Bool
  , _uiNickName  :: Maybe Text
  , _uiFirstName :: Text
  , _uiLastName  :: Text
  , _uiEmail     :: Text
  , _uiDeleted   :: Bool
  } deriving (Eq, Show)

-- | Is this user deleted?
userDeleted :: User -> Bool
userDeleted u =
    case userCreateAt u of
        Nothing -> False
        Just c -> userDeleteAt u > c

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

-- | The 'UserStatus' value represents possible current status for
--   a user
data UserStatus
  = Online
  | Away
  | Offline
  | DoNotDisturb
  | Other Text
    deriving (Eq, Show)

statusFromText :: Text -> UserStatus
statusFromText t = case t of
  "online"  -> Online
  "offline" -> Offline
  "away"    -> Away
  "dnd"     -> DoNotDisturb
  _         -> Other 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 { _ofUsers :: HashMap UserId a
             , _usernameSet :: S.Set Text
             }
             deriving 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 = _usernameSet

-- | Initial collection of Users with no members
noUsers :: Users
noUsers = AllUsers HM.empty mempty

getAllUserIds :: Users -> [UserId]
getAllUserIds = HM.keys . _ofUsers

-- | Add a member to the existing collection of Users
addUser :: UserInfo -> Users -> Users
addUser userinfo u =
    u & ofUsers %~ HM.insert (userinfo^.uiId) userinfo
      & usernameSet %~ S.insert (userinfo^.uiName)

-- | Get a list of all known users
allUsers :: Users -> [UserInfo]
allUsers = HM.elems . _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 = AllUsers HM.empty mempty

-- | Add a member to the existing collection of TypingUsers
addTypingUser :: UserId -> UTCTime -> TypingUsers -> TypingUsers
addTypingUser uId ts = ofUsers %~ HM.insertWith (<>) uId (Max ts)

-- | Get a list of all typing users
allTypingUsers :: TypingUsers -> [UserId]
allTypingUsers = HM.keys . _ofUsers

-- | Remove all the expired users from the collection of TypingUsers.
-- | Expiry is decided by the given timestamp.
expireTypingUsers :: UTCTime -> TypingUsers -> TypingUsers
expireTypingUsers expiryTimestamp =
    ofUsers %~ HM.filter (\(Max ts') -> ts' >= expiryTimestamp)

-- | Get the User information given the UserId
findUserById :: UserId -> Users -> Maybe UserInfo
findUserById uId = HM.lookup uId . _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 name allusers =
  case filter ((== trimUserSigil name) . _uiName . snd) $ HM.toList $ _ofUsers allusers of
    (usr : []) -> Just usr
    _ -> 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 nick us =
  case filter ((== (Just $ trimUserSigil nick)) . _uiNickName . snd) $ HM.toList $ _ofUsers us of
    (pair : []) -> Just pair
    _ -> Nothing

userSigil :: Text
userSigil = "@"

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

-- | 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 uId f = ofUsers.ix(uId) %~ f