1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
|
{-# LANGUAGE OverloadedStrings #-}
module Erebos.Conversation (
Message,
messageFrom,
messageTime,
messageText,
messageUnread,
formatMessage,
formatMessageFT,
Conversation,
isSameConversation,
directMessageConversation,
chatroomConversation,
chatroomConversationByStateData,
isChatroomStateConversation,
reloadConversation,
lookupConversations,
conversationName,
conversationPeer,
conversationHistory,
sendMessage,
deleteConversation,
) where
import Control.Monad.Except
import Data.List
import Data.Maybe
import Data.Text (Text)
import Data.Text qualified as T
import Data.Time.Format
import Data.Time.LocalTime
import Erebos.Chatroom
import Erebos.Conversation.Class
import Erebos.DirectMessage
import Erebos.Identity
import Erebos.State
import Erebos.Storable
import Erebos.TextFormat
import Erebos.TextFormat.Types
data Message = forall conv msg. ConversationType conv msg => Message msg Bool
withMessage :: (forall conv msg. ConversationType conv msg => msg -> a) -> Message -> a
withMessage f (Message msg _) = f msg
messageFrom :: Message -> ComposedIdentity
messageFrom = withMessage convMessageFrom
messageTime :: Message -> ZonedTime
messageTime = withMessage convMessageTime
messageText :: Message -> Maybe Text
messageText = withMessage convMessageText
messageUnread :: Message -> Bool
messageUnread (Message _ unread) = unread
formatMessage :: TimeZone -> Message -> String
formatMessage tzone = T.unpack . renderPlainText . formatMessageFT tzone
formatMessageFT :: TimeZone -> Message -> FormattedText
formatMessageFT tzone msg =
(if messageUnread msg then FormattedText (CustomTextColor (Just BrightYellow) Nothing) else id) $ mconcat
[ PlainText $ T.pack $ formatTime defaultTimeLocale "[%H:%M] " $ utcToLocalTime tzone $ zonedTimeToUTC $ messageTime msg
, maybe "<unnamed>" PlainText $ idName $ messageFrom msg
, maybe "" ((": " <>) . PlainText) $ messageText msg
]
data Conversation
= DirectMessageConversation DirectMessageThread
| ChatroomConversation ChatroomState
withConversation :: (forall conv msg. ConversationType conv msg => conv -> a) -> Conversation -> a
withConversation f (DirectMessageConversation conv) = f conv
withConversation f (ChatroomConversation conv) = f conv
isSameConversation :: Conversation -> Conversation -> Bool
isSameConversation (DirectMessageConversation t) (DirectMessageConversation t')
= sameIdentity (msgPeer t) (msgPeer t')
isSameConversation (ChatroomConversation rstate) (ChatroomConversation rstate') = isSameChatroom rstate rstate'
isSameConversation _ _ = False
directMessageConversation :: MonadHead LocalState m => ComposedIdentity -> m Conversation
directMessageConversation peer = do
createOrUpdateDirectMessagePeer peer
(find (sameIdentity peer . msgPeer) . dmThreadList . lookupSharedValue . lsShared . fromStored <$> getLocalHead) >>= \case
Just thread -> return $ DirectMessageConversation thread
Nothing -> return $ DirectMessageConversation $ DirectMessageThread peer [] [] [] []
chatroomConversation :: MonadHead LocalState m => ChatroomState -> m (Maybe Conversation)
chatroomConversation rstate = chatroomConversationByStateData (head $ roomStateData rstate)
chatroomConversationByStateData :: MonadHead LocalState m => Stored ChatroomStateData -> m (Maybe Conversation)
chatroomConversationByStateData sdata = fmap ChatroomConversation <$> findChatroomByStateData sdata
isChatroomStateConversation :: ChatroomState -> Conversation -> Bool
isChatroomStateConversation rstate (ChatroomConversation rstate') = isSameChatroom rstate rstate'
isChatroomStateConversation _ _ = False
reloadConversation :: MonadHead LocalState m => Conversation -> m Conversation
reloadConversation (DirectMessageConversation thread) = directMessageConversation (msgPeer thread)
reloadConversation cur@(ChatroomConversation rstate) =
fromMaybe cur <$> chatroomConversation rstate
lookupConversations :: MonadHead LocalState m => m [ Conversation ]
lookupConversations = map DirectMessageConversation . dmThreadList . lookupSharedValue . lsShared . fromStored <$> getLocalHead
conversationName :: Conversation -> Text
conversationName (DirectMessageConversation thread) = fromMaybe (T.pack "<unnamed>") $ idName $ msgPeer thread
conversationName (ChatroomConversation rstate) = fromMaybe (T.pack "<unnamed>") $ roomName =<< roomStateRoom rstate
conversationPeer :: Conversation -> Maybe ComposedIdentity
conversationPeer (DirectMessageConversation thread) = Just $ msgPeer thread
conversationPeer (ChatroomConversation _) = Nothing
conversationHistory :: Conversation -> [ Message ]
conversationHistory = withConversation $ map (uncurry Message) . convMessageListSince Nothing
sendMessage :: (MonadHead LocalState m, MonadError e m, FromErebosError e) => Conversation -> Text -> m ()
sendMessage (DirectMessageConversation thread) text = sendDirectMessage (msgPeer thread) text
sendMessage (ChatroomConversation rstate) text = sendChatroomMessage rstate text
deleteConversation :: (MonadHead LocalState m, MonadError e m, FromErebosError e) => Conversation -> m ()
deleteConversation (DirectMessageConversation _) = throwOtherError "deleting direct message conversation is not supported"
deleteConversation (ChatroomConversation rstate) = deleteChatroomByStateData (head $ roomStateData rstate)
|