mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2024-12-17 17:20:21 +01:00
chats API for mobile (#230)
Co-authored-by: Efim Poberezkin <8711996+efim-poberezkin@users.noreply.github.com>
This commit is contained in:
Evgeny Poberezkin
committed by
GitHub
GitHub
parent
edc9560d36
commit
c3a8ae1eb5
+27
-17
@@ -36,6 +36,7 @@ import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (encodeUtf8)
|
||||
import Data.Time.Clock (UTCTime, getCurrentTime)
|
||||
import Data.Time.LocalTime (getCurrentTimeZone)
|
||||
import Data.Word (Word32)
|
||||
import Simplex.Chat.Controller
|
||||
import Simplex.Chat.Messages
|
||||
@@ -123,6 +124,11 @@ toView event = do
|
||||
|
||||
processChatCommand :: forall m. ChatMonad m => User -> ChatCommand -> m ChatResponse
|
||||
processChatCommand user@User {userId, profile} = \case
|
||||
APIGetChats -> CRApiChats <$> withStore (`getChatPreviews` user)
|
||||
APIGetChat cType cId -> case cType of
|
||||
CTDirect -> CRApiDirectChat <$> withStore (\st -> getDirectChat st user cId)
|
||||
CTGroup -> pure $ CRChatError ChatErrorNotImplemented
|
||||
APIGetChatItems _count -> pure $ CRChatError ChatErrorNotImplemented
|
||||
ChatHelp section -> pure $ CRChatHelp section
|
||||
Welcome -> pure $ CRWelcome user
|
||||
AddContact -> procCmd $ do
|
||||
@@ -179,7 +185,7 @@ processChatCommand user@User {userId, profile} = \case
|
||||
SendMessage cName msg -> do
|
||||
contact <- withStore $ \st -> getContact st userId cName
|
||||
let mc = MCText $ safeDecodeUtf8 msg
|
||||
ci <- sendDirectChatItem userId contact (XMsgNew mc) (CIMsgContent mc)
|
||||
ci <- sendDirectChatItem userId contact (XMsgNew mc) (CISndMsgContent mc)
|
||||
setActive $ ActiveC cName
|
||||
pure . CRNewChatItem $ AChatItem SCTDirect SMDSnd (DirectChat contact) ci
|
||||
NewGroup gProfile -> do
|
||||
@@ -257,7 +263,7 @@ processChatCommand user@User {userId, profile} = \case
|
||||
group@(Group gInfo@GroupInfo {membership} _) <- withStore $ \st -> getGroup st user gName
|
||||
unless (memberActive membership) $ throwChatError CEGroupMemberUserRemoved
|
||||
let mc = MCText $ safeDecodeUtf8 msg
|
||||
ci <- sendGroupChatItem userId group (XMsgNew mc) (CIMsgContent mc)
|
||||
ci <- sendGroupChatItem userId group (XMsgNew mc) (CISndMsgContent mc)
|
||||
setActive $ ActiveG gName
|
||||
pure . CRNewChatItem $ AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci
|
||||
SendFile cName f -> do
|
||||
@@ -288,9 +294,9 @@ processChatCommand user@User {userId, profile} = \case
|
||||
let ciContent = CISndFileInvitation fileId f
|
||||
createdAt <- liftIO getCurrentTime
|
||||
let ci = mkNewChatItem ciContent 0 createdAt createdAt
|
||||
ciMeta@CIMetaProps {itemId} <- saveChatItem userId (CDSndGroup gInfo) ci
|
||||
ciMeta@CIMeta {itemId} <- saveChatItem userId (CDGroupSnd gInfo) ci
|
||||
withStore $ \st -> updateFileTransferChatItemId st fileId itemId
|
||||
pure . CRNewChatItem $ AChatItem SCTGroup SMDSnd (GroupChat gInfo) $ SndGroupChatItem (CISndMeta ciMeta) ciContent
|
||||
pure . CRNewChatItem $ AChatItem SCTGroup SMDSnd (GroupChat gInfo) $ ChatItem CIGroupSnd ciMeta ciContent
|
||||
ReceiveFile fileId filePath_ -> do
|
||||
ft@RcvFileTransfer {fileInvitation = FileInvitation {fileName, fileConnReq}, fileStatus} <- withStore $ \st -> getRcvFileTransfer st userId fileId
|
||||
unless (fileStatus == RFSNew) . throwChatError $ CEFileAlreadyReceiving fileName
|
||||
@@ -804,14 +810,14 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
|
||||
|
||||
newContentMessage :: Contact -> MsgContent -> MessageId -> MsgMeta -> m ()
|
||||
newContentMessage ct@Contact {localDisplayName = c} mc msgId msgMeta = do
|
||||
ci <- saveRcvDirectChatItem userId ct msgId msgMeta (CIMsgContent mc)
|
||||
ci <- saveRcvDirectChatItem userId ct msgId msgMeta (CIRcvMsgContent mc)
|
||||
toView . CRNewChatItem $ AChatItem SCTDirect SMDRcv (DirectChat ct) ci
|
||||
showToast (c <> "> ") $ msgContentText mc
|
||||
setActive $ ActiveC c
|
||||
|
||||
newGroupContentMessage :: GroupInfo -> GroupMember -> MsgContent -> MessageId -> MsgMeta -> m ()
|
||||
newGroupContentMessage gInfo m@GroupMember {localDisplayName = c} mc msgId msgMeta = do
|
||||
ci <- saveRcvGroupChatItem userId gInfo m msgId msgMeta (CIMsgContent mc)
|
||||
ci <- saveRcvGroupChatItem userId gInfo m msgId msgMeta (CIRcvMsgContent mc)
|
||||
toView . CRNewChatItem $ AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci
|
||||
let g = groupName' gInfo
|
||||
showToast ("#" <> g <> " " <> c <> "> ") $ msgContentText mc
|
||||
@@ -1163,32 +1169,33 @@ sendDirectChatItem :: ChatMonad m => UserId -> Contact -> ChatMsgEvent -> CICont
|
||||
sendDirectChatItem userId contact@Contact {activeConn} chatMsgEvent ciContent = do
|
||||
msgId <- sendDirectMessage activeConn chatMsgEvent
|
||||
createdAt <- liftIO getCurrentTime
|
||||
ciMeta <- saveChatItem userId (CDDirect contact) $ mkNewChatItem ciContent msgId createdAt createdAt
|
||||
pure $ DirectChatItem (CISndMeta ciMeta) ciContent
|
||||
ciMeta <- saveChatItem userId (CDDirectSnd contact) $ mkNewChatItem ciContent msgId createdAt createdAt
|
||||
pure $ ChatItem CIDirectSnd ciMeta ciContent
|
||||
|
||||
sendGroupChatItem :: ChatMonad m => UserId -> Group -> ChatMsgEvent -> CIContent 'MDSnd -> m (ChatItem 'CTGroup 'MDSnd)
|
||||
sendGroupChatItem userId (Group g ms) chatMsgEvent ciContent = do
|
||||
msgId <- sendGroupMessage ms chatMsgEvent
|
||||
createdAt <- liftIO getCurrentTime
|
||||
ciMeta <- saveChatItem userId (CDSndGroup g) $ mkNewChatItem ciContent msgId createdAt createdAt
|
||||
pure $ SndGroupChatItem (CISndMeta ciMeta) ciContent
|
||||
ciMeta <- saveChatItem userId (CDGroupSnd g) $ mkNewChatItem ciContent msgId createdAt createdAt
|
||||
pure $ ChatItem CIGroupSnd ciMeta ciContent
|
||||
|
||||
saveRcvDirectChatItem :: ChatMonad m => UserId -> Contact -> MessageId -> MsgMeta -> CIContent 'MDRcv -> m (ChatItem 'CTDirect 'MDRcv)
|
||||
saveRcvDirectChatItem userId ct msgId MsgMeta {broker = (_, brokerTs)} ciContent = do
|
||||
createdAt <- liftIO getCurrentTime
|
||||
ciMeta <- saveChatItem userId (CDDirect ct) $ mkNewChatItem ciContent msgId brokerTs createdAt
|
||||
pure $ DirectChatItem (CIRcvMeta ciMeta) ciContent
|
||||
ciMeta <- saveChatItem userId (CDDirectRcv ct) $ mkNewChatItem ciContent msgId brokerTs createdAt
|
||||
pure $ ChatItem CIDirectRcv ciMeta ciContent
|
||||
|
||||
saveRcvGroupChatItem :: ChatMonad m => UserId -> GroupInfo -> GroupMember -> MessageId -> MsgMeta -> CIContent 'MDRcv -> m (ChatItem 'CTGroup 'MDRcv)
|
||||
saveRcvGroupChatItem userId g m msgId MsgMeta {broker = (_, brokerTs)} ciContent = do
|
||||
createdAt <- liftIO getCurrentTime
|
||||
ciMeta <- saveChatItem userId (CDRcvGroup g m) $ mkNewChatItem ciContent msgId brokerTs createdAt
|
||||
pure $ RcvGroupChatItem m (CIRcvMeta ciMeta) ciContent
|
||||
ciMeta <- saveChatItem userId (CDGroupRcv g m) $ mkNewChatItem ciContent msgId brokerTs createdAt
|
||||
pure $ ChatItem (CIGroupRcv m) ciMeta ciContent
|
||||
|
||||
saveChatItem :: (MsgDirectionI d, ChatMonad m) => UserId -> ChatDirection c d -> NewChatItem d -> m CIMetaProps
|
||||
saveChatItem :: ChatMonad m => UserId -> ChatDirection c d -> NewChatItem d -> m CIMeta
|
||||
saveChatItem userId cd ci@NewChatItem {itemTs, itemText, createdAt} = do
|
||||
tz <- liftIO getCurrentTimeZone
|
||||
ciId <- withStore $ \st -> createNewChatItem st userId cd ci
|
||||
liftIO $ mkCIMetaProps ciId itemTs itemText createdAt
|
||||
pure $ mkCIMeta ciId itemText tz itemTs createdAt
|
||||
|
||||
mkNewChatItem :: forall d. MsgDirectionI d => CIContent d -> MessageId -> UTCTime -> UTCTime -> NewChatItem d
|
||||
mkNewChatItem itemContent msgId itemTs createdAt =
|
||||
@@ -1289,7 +1296,10 @@ withStore action =
|
||||
|
||||
chatCommandP :: Parser ChatCommand
|
||||
chatCommandP =
|
||||
("/help files" <|> "/help file" <|> "/hf") $> ChatHelp HSFiles
|
||||
"/api/v1/chats" $> APIGetChats
|
||||
<|> "/api/v1/chat/" *> (APIGetChat <$> ("direct/" $> CTDirect <|> "group/" $> CTGroup) <*> A.decimal)
|
||||
<|> "/api/v1/chat/items?count=" *> (APIGetChatItems <$> A.decimal)
|
||||
<|> ("/help files" <|> "/help file" <|> "/hf") $> ChatHelp HSFiles
|
||||
<|> ("/help groups" <|> "/help group" <|> "/hg") $> ChatHelp HSGroups
|
||||
<|> ("/help address" <|> "/ha") $> ChatHelp HSMyAddress
|
||||
<|> ("/help" <|> "/h") $> ChatHelp HSMain
|
||||
|
||||
@@ -1,4 +1,5 @@
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
@@ -77,7 +78,10 @@ instance ToJSON HelpSection where
|
||||
toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "HS"
|
||||
|
||||
data ChatCommand
|
||||
= ChatHelp HelpSection
|
||||
= APIGetChats
|
||||
| APIGetChat ChatType Int64
|
||||
| APIGetChatItems Int
|
||||
| ChatHelp HelpSection
|
||||
| Welcome
|
||||
| AddContact
|
||||
| Connect (Maybe AConnectionRequestUri)
|
||||
@@ -112,7 +116,9 @@ data ChatCommand
|
||||
deriving (Show)
|
||||
|
||||
data ChatResponse
|
||||
= CRNewChatItem {chatItem :: AChatItem}
|
||||
= CRApiChats {chats :: [AChatPreview]}
|
||||
| CRApiDirectChat {chat :: Chat 'CTDirect}
|
||||
| CRNewChatItem {chatItem :: AChatItem}
|
||||
| CRCmdAccepted {corr :: CorrId}
|
||||
| CRChatHelp {helpSection :: HelpSection}
|
||||
| CRWelcome {user :: User}
|
||||
@@ -190,6 +196,7 @@ data ChatError
|
||||
| ChatErrorMessage {errorMessage :: String}
|
||||
| ChatErrorAgent {agentError :: AgentErrorType}
|
||||
| ChatErrorStore {storeError :: StoreError}
|
||||
| ChatErrorNotImplemented
|
||||
deriving (Show, Exception, Generic)
|
||||
|
||||
instance ToJSON ChatError where
|
||||
|
||||
@@ -22,7 +22,7 @@ import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
|
||||
import Data.Time.Clock (UTCTime)
|
||||
import Data.Time.LocalTime (ZonedTime, utcToLocalZonedTime)
|
||||
import Data.Time.LocalTime (TimeZone, ZonedTime, utcToZonedTime)
|
||||
import Data.Type.Equality
|
||||
import Data.Typeable (Typeable)
|
||||
import Database.SQLite.Simple.FromField (FromField (..))
|
||||
@@ -38,7 +38,11 @@ import Simplex.Messaging.Parsers (dropPrefix)
|
||||
import Simplex.Messaging.Protocol (MsgBody)
|
||||
|
||||
data ChatType = CTDirect | CTGroup
|
||||
deriving (Show)
|
||||
deriving (Show, Generic)
|
||||
|
||||
instance ToJSON ChatType where
|
||||
toJSON = J.genericToJSON . enumJSON $ dropPrefix "CT"
|
||||
toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "CT"
|
||||
|
||||
data ChatInfo (c :: ChatType) where
|
||||
DirectChat :: Contact -> ChatInfo 'CTDirect
|
||||
@@ -64,52 +68,63 @@ jsonChatInfo = \case
|
||||
DirectChat c -> JCInfoDirect c
|
||||
GroupChat g -> JCInfoGroup g
|
||||
|
||||
type ChatItemData d = (CIMeta d, CIContent d)
|
||||
data ChatItem (c :: ChatType) (d :: MsgDirection) = ChatItem
|
||||
{ chatDir :: CIDirection c d,
|
||||
meta :: CIMeta,
|
||||
content :: CIContent d
|
||||
}
|
||||
deriving (Show, Generic)
|
||||
|
||||
data ChatItem (c :: ChatType) (d :: MsgDirection) where
|
||||
DirectChatItem :: CIMeta d -> CIContent d -> ChatItem 'CTDirect d
|
||||
SndGroupChatItem :: CIMeta 'MDSnd -> CIContent 'MDSnd -> ChatItem 'CTGroup 'MDSnd
|
||||
RcvGroupChatItem :: GroupMember -> CIMeta 'MDRcv -> CIContent 'MDRcv -> ChatItem 'CTGroup 'MDRcv
|
||||
instance ToJSON (ChatItem c d) where
|
||||
toJSON = J.genericToJSON J.defaultOptions
|
||||
toEncoding = J.genericToEncoding J.defaultOptions
|
||||
|
||||
deriving instance Show (ChatItem c d)
|
||||
data CIDirection (c :: ChatType) (d :: MsgDirection) where
|
||||
CIDirectSnd :: CIDirection 'CTDirect 'MDSnd
|
||||
CIDirectRcv :: CIDirection 'CTDirect 'MDRcv
|
||||
CIGroupSnd :: CIDirection 'CTGroup 'MDSnd
|
||||
CIGroupRcv :: GroupMember -> CIDirection 'CTGroup 'MDRcv
|
||||
|
||||
data JSONChatItem d
|
||||
= JCItemDirect {dir :: MsgDirection, meta :: CIMeta d, content :: CIContent d}
|
||||
| JCItemSndGroup {dir :: MsgDirection, meta :: CIMeta d, content :: CIContent d}
|
||||
| JCItemRcvGroup {dir :: MsgDirection, member :: GroupMember, meta :: CIMeta d, content :: CIContent d}
|
||||
deriving instance Show (CIDirection c d)
|
||||
|
||||
data JSONCIDirection
|
||||
= JCIDirectSnd
|
||||
| JCIDirectRcv
|
||||
| JCIGroupSnd
|
||||
| JCIGroupRcv {groupMember :: GroupMember}
|
||||
deriving (Generic)
|
||||
|
||||
instance MsgDirectionI d => ToJSON (JSONChatItem d) where
|
||||
toJSON = J.genericToJSON . singleFieldJSON $ dropPrefix "JCItem"
|
||||
toEncoding = J.genericToEncoding . singleFieldJSON $ dropPrefix "JCItem"
|
||||
instance ToJSON JSONCIDirection where
|
||||
toJSON = J.genericToJSON . singleFieldJSON $ dropPrefix "JCI"
|
||||
toEncoding = J.genericToEncoding . singleFieldJSON $ dropPrefix "JCI"
|
||||
|
||||
instance MsgDirectionI d => ToJSON (ChatItem c d) where
|
||||
toJSON = J.toJSON . jsonChatItem
|
||||
toEncoding = J.toEncoding . jsonChatItem
|
||||
instance ToJSON (CIDirection c d) where
|
||||
toJSON = J.toJSON . jsonCIDirection
|
||||
toEncoding = J.toEncoding . jsonCIDirection
|
||||
|
||||
jsonChatItem :: forall c d. MsgDirectionI d => ChatItem c d -> JSONChatItem d
|
||||
jsonChatItem = \case
|
||||
DirectChatItem meta cic -> JCItemDirect md meta cic
|
||||
SndGroupChatItem meta cic -> JCItemSndGroup md meta cic
|
||||
RcvGroupChatItem m meta cic -> JCItemRcvGroup md m meta cic
|
||||
where
|
||||
md = toMsgDirection $ msgDirection @d
|
||||
jsonCIDirection :: CIDirection c d -> JSONCIDirection
|
||||
jsonCIDirection = \case
|
||||
CIDirectSnd -> JCIDirectSnd
|
||||
CIDirectRcv -> JCIDirectRcv
|
||||
CIGroupSnd -> JCIGroupSnd
|
||||
CIGroupRcv m -> JCIGroupRcv m
|
||||
|
||||
data CChatItem c = forall d. CChatItem (SMsgDirection d) (ChatItem c d)
|
||||
|
||||
deriving instance Show (CChatItem c)
|
||||
|
||||
instance ToJSON (CChatItem c) where
|
||||
toJSON (CChatItem _ ci) = J.toJSON ci
|
||||
toEncoding (CChatItem _ ci) = J.toEncoding ci
|
||||
|
||||
chatItemId :: ChatItem c d -> ChatItemId
|
||||
chatItemId = \case
|
||||
DirectChatItem (CISndMeta CIMetaProps {itemId}) _ -> itemId
|
||||
DirectChatItem (CIRcvMeta CIMetaProps {itemId}) _ -> itemId
|
||||
SndGroupChatItem (CISndMeta CIMetaProps {itemId}) _ -> itemId
|
||||
RcvGroupChatItem _ (CIRcvMeta CIMetaProps {itemId}) _ -> itemId
|
||||
chatItemId ChatItem {meta = CIMeta {itemId}} = itemId
|
||||
|
||||
data ChatDirection (c :: ChatType) (d :: MsgDirection) where
|
||||
CDDirect :: Contact -> ChatDirection 'CTDirect d
|
||||
CDSndGroup :: GroupInfo -> ChatDirection 'CTGroup 'MDSnd
|
||||
CDRcvGroup :: GroupInfo -> GroupMember -> ChatDirection 'CTGroup 'MDRcv
|
||||
CDDirectSnd :: Contact -> ChatDirection 'CTDirect 'MDSnd
|
||||
CDDirectRcv :: Contact -> ChatDirection 'CTDirect 'MDRcv
|
||||
CDGroupSnd :: GroupInfo -> ChatDirection 'CTGroup 'MDSnd
|
||||
CDGroupRcv :: GroupInfo -> GroupMember -> ChatDirection 'CTGroup 'MDRcv
|
||||
|
||||
data NewChatItem d = NewChatItem
|
||||
{ createdByMsgId :: Maybe MessageId,
|
||||
@@ -122,16 +137,38 @@ data NewChatItem d = NewChatItem
|
||||
deriving (Show)
|
||||
|
||||
-- | type to show one chat with messages
|
||||
data Chat c = Chat (ChatInfo c) [CChatItem c]
|
||||
deriving (Show)
|
||||
data Chat c = Chat {chatInfo :: ChatInfo c, chatItems :: [CChatItem c]}
|
||||
deriving (Show, Generic)
|
||||
|
||||
instance ToJSON (Chat c) where
|
||||
toJSON = J.genericToJSON J.defaultOptions
|
||||
toEncoding = J.genericToEncoding J.defaultOptions
|
||||
|
||||
data ChatPreview c = ChatPreview {chatInfo :: ChatInfo c, lastChatItem :: Maybe (CChatItem c)}
|
||||
deriving (Show, Generic)
|
||||
|
||||
instance ToJSON (ChatPreview c) where
|
||||
toJSON = J.genericToJSON J.defaultOptions
|
||||
toEncoding = J.genericToEncoding J.defaultOptions
|
||||
|
||||
-- | type to show the list of chats, with one last message in each
|
||||
data AChatPreview = forall c. AChatPreview (SChatType c) (ChatInfo c) (Maybe (CChatItem c))
|
||||
|
||||
deriving instance Show AChatPreview
|
||||
|
||||
instance ToJSON AChatPreview where
|
||||
toJSON (AChatPreview _ chat ccItem_) = J.toJSON $ JSONAnyChatPreview chat ccItem_
|
||||
toEncoding (AChatPreview _ chat ccItem_) = J.toEncoding $ J.toJSON $ JSONAnyChatPreview chat ccItem_
|
||||
|
||||
data JSONAnyChatPreview c d = JSONAnyChatPreview {chatInfo :: ChatInfo c, chatItem :: Maybe (CChatItem c)}
|
||||
deriving (Generic)
|
||||
|
||||
instance ToJSON (JSONAnyChatPreview c d) where
|
||||
toJSON = J.genericToJSON J.defaultOptions
|
||||
toEncoding = J.genericToEncoding J.defaultOptions
|
||||
|
||||
-- | type to show a mix of messages from multiple chats
|
||||
data AChatItem = forall c d. MsgDirectionI d => AChatItem (SChatType c) (SMsgDirection d) (ChatInfo c) (ChatItem c d)
|
||||
data AChatItem = forall c d. AChatItem (SChatType c) (SMsgDirection d) (ChatInfo c) (ChatItem c d)
|
||||
|
||||
deriving instance Show AChatItem
|
||||
|
||||
@@ -142,35 +179,11 @@ instance ToJSON AChatItem where
|
||||
data JSONAnyChatItem c d = JSONAnyChatItem {chatInfo :: ChatInfo c, chatItem :: ChatItem c d}
|
||||
deriving (Generic)
|
||||
|
||||
instance MsgDirectionI d => ToJSON (JSONAnyChatItem c d) where
|
||||
instance ToJSON (JSONAnyChatItem c d) where
|
||||
toJSON = J.genericToJSON J.defaultOptions
|
||||
toEncoding = J.genericToEncoding J.defaultOptions
|
||||
|
||||
data CIMeta (d :: MsgDirection) where
|
||||
CISndMeta :: CIMetaProps -> CIMeta 'MDSnd
|
||||
CIRcvMeta :: CIMetaProps -> CIMeta 'MDRcv
|
||||
|
||||
deriving instance Show (CIMeta d)
|
||||
|
||||
instance ToJSON (CIMeta d) where
|
||||
toJSON = J.toJSON . jsonCIMeta
|
||||
toEncoding = J.toEncoding . jsonCIMeta
|
||||
|
||||
data JSONCIMeta
|
||||
= JCIMetaSnd {meta :: CIMetaProps}
|
||||
| JCIMetaRcv {meta :: CIMetaProps}
|
||||
deriving (Generic)
|
||||
|
||||
instance ToJSON JSONCIMeta where
|
||||
toJSON = J.genericToJSON . singleFieldJSON $ dropPrefix "JCIMeta"
|
||||
toEncoding = J.genericToEncoding . singleFieldJSON $ dropPrefix "JCIMeta"
|
||||
|
||||
jsonCIMeta :: CIMeta d -> JSONCIMeta
|
||||
jsonCIMeta = \case
|
||||
CISndMeta meta -> JCIMetaSnd meta
|
||||
CIRcvMeta meta -> JCIMetaRcv meta
|
||||
|
||||
data CIMetaProps = CIMetaProps
|
||||
data CIMeta = CIMeta
|
||||
{ itemId :: ChatItemId,
|
||||
itemTs :: ChatItemTs,
|
||||
itemText :: Text,
|
||||
@@ -179,19 +192,20 @@ data CIMetaProps = CIMetaProps
|
||||
}
|
||||
deriving (Show, Generic, FromJSON)
|
||||
|
||||
mkCIMetaProps :: ChatItemId -> ChatItemTs -> Text -> UTCTime -> IO CIMetaProps
|
||||
mkCIMetaProps itemId itemTs itemText createdAt = do
|
||||
localItemTs <- utcToLocalZonedTime itemTs
|
||||
pure CIMetaProps {itemId, itemTs, itemText, localItemTs, createdAt}
|
||||
mkCIMeta :: ChatItemId -> Text -> TimeZone -> ChatItemTs -> UTCTime -> CIMeta
|
||||
mkCIMeta itemId itemText tz itemTs createdAt =
|
||||
let localItemTs = utcToZonedTime tz itemTs
|
||||
in CIMeta {itemId, itemTs, itemText, localItemTs, createdAt}
|
||||
|
||||
instance ToJSON CIMetaProps where toEncoding = J.genericToEncoding J.defaultOptions
|
||||
instance ToJSON CIMeta where toEncoding = J.genericToEncoding J.defaultOptions
|
||||
|
||||
type ChatItemId = Int64
|
||||
|
||||
type ChatItemTs = UTCTime
|
||||
|
||||
data CIContent (d :: MsgDirection) where
|
||||
CIMsgContent :: MsgContent -> CIContent d
|
||||
CISndMsgContent :: MsgContent -> CIContent 'MDSnd
|
||||
CIRcvMsgContent :: MsgContent -> CIContent 'MDRcv
|
||||
CISndFileInvitation :: FileTransferId -> FilePath -> CIContent 'MDSnd
|
||||
CIRcvFileInvitation :: RcvFileTransfer -> CIContent 'MDRcv
|
||||
|
||||
@@ -199,14 +213,15 @@ deriving instance Show (CIContent d)
|
||||
|
||||
ciContentToText :: CIContent d -> Text
|
||||
ciContentToText = \case
|
||||
CIMsgContent mc -> msgContentText mc
|
||||
CISndMsgContent mc -> msgContentText mc
|
||||
CIRcvMsgContent mc -> msgContentText mc
|
||||
CISndFileInvitation fId fPath -> "you sent file #" <> T.pack (show fId) <> ": " <> T.pack fPath
|
||||
CIRcvFileInvitation RcvFileTransfer {fileInvitation = FileInvitation {fileName}} -> "file " <> T.pack fileName
|
||||
|
||||
instance MsgDirectionI d => ToField (CIContent d) where
|
||||
instance ToField (CIContent d) where
|
||||
toField = toField . decodeLatin1 . LB.toStrict . J.encode
|
||||
|
||||
instance MsgDirectionI d => ToJSON (CIContent d) where
|
||||
instance ToJSON (CIContent d) where
|
||||
toJSON = J.toJSON . jsonCIContent
|
||||
toEncoding = J.toEncoding . jsonCIContent
|
||||
|
||||
@@ -218,7 +233,8 @@ instance FromJSON ACIContent where
|
||||
instance FromField ACIContent where fromField = fromTextField_ $ J.decode . LB.fromStrict . encodeUtf8
|
||||
|
||||
data JSONCIContent
|
||||
= JCIMsgContent {msgDir :: MsgDirection, msgContent :: MsgContent}
|
||||
= JCISndMsgContent {msgContent :: MsgContent}
|
||||
| JCIRcvMsgContent {msgContent :: MsgContent}
|
||||
| JCISndFileInvitation {fileId :: FileTransferId, filePath :: FilePath}
|
||||
| JCIRcvFileInvitation {rcvFileTransfer :: RcvFileTransfer}
|
||||
deriving (Generic)
|
||||
@@ -230,19 +246,17 @@ instance ToJSON JSONCIContent where
|
||||
toJSON = J.genericToJSON . singleFieldJSON $ dropPrefix "JCI"
|
||||
toEncoding = J.genericToEncoding . singleFieldJSON $ dropPrefix "JCI"
|
||||
|
||||
jsonCIContent :: forall d. MsgDirectionI d => CIContent d -> JSONCIContent
|
||||
jsonCIContent :: CIContent d -> JSONCIContent
|
||||
jsonCIContent = \case
|
||||
CIMsgContent mc -> JCIMsgContent md mc
|
||||
CISndMsgContent mc -> JCISndMsgContent mc
|
||||
CIRcvMsgContent mc -> JCIRcvMsgContent mc
|
||||
CISndFileInvitation fId fPath -> JCISndFileInvitation fId fPath
|
||||
CIRcvFileInvitation ft -> JCIRcvFileInvitation ft
|
||||
where
|
||||
md = toMsgDirection $ msgDirection @d
|
||||
|
||||
aciContentJSON :: JSONCIContent -> ACIContent
|
||||
aciContentJSON = \case
|
||||
JCIMsgContent md mc -> case md of
|
||||
MDSnd -> ACIContent SMDSnd $ CIMsgContent mc
|
||||
MDRcv -> ACIContent SMDRcv $ CIMsgContent mc
|
||||
JCISndMsgContent mc -> ACIContent SMDSnd $ CISndMsgContent mc
|
||||
JCIRcvMsgContent mc -> ACIContent SMDRcv $ CIRcvMsgContent mc
|
||||
JCISndFileInvitation fId fPath -> ACIContent SMDSnd $ CISndFileInvitation fId fPath
|
||||
JCIRcvFileInvitation ft -> ACIContent SMDRcv $ CIRcvFileInvitation ft
|
||||
|
||||
@@ -351,8 +365,6 @@ data MsgMetaJSON = MsgMetaJSON
|
||||
|
||||
instance ToJSON MsgMetaJSON where toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
|
||||
|
||||
-- instance FromJson MsgMetaJSON where fromEncoding = J.genericFromEncoding JSONKeyOptions
|
||||
|
||||
msgMetaToJson :: MsgMeta -> MsgMetaJSON
|
||||
msgMetaToJson MsgMeta {integrity, recipient = (rcvId, rcvTs), broker = (serverId, serverTs), sndMsgId = sndId} =
|
||||
MsgMetaJSON
|
||||
|
||||
+22
-25
@@ -129,6 +129,7 @@ import Data.Maybe (listToMaybe)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Time.Clock (UTCTime, getCurrentTime)
|
||||
import Data.Time.LocalTime (TimeZone, getCurrentTimeZone)
|
||||
import Database.SQLite.Simple (NamedParam (..), Only (..), Query (..), SQLError, (:.) (..))
|
||||
import qualified Database.SQLite.Simple as DB
|
||||
import Database.SQLite.Simple.QQ (sql)
|
||||
@@ -1810,7 +1811,7 @@ deletePendingGroupMessage st groupMemberId messageId =
|
||||
liftIO . withTransaction st $ \db ->
|
||||
DB.execute db "DELETE FROM pending_group_messages WHERE group_member_id = ? AND message_id = ?" (groupMemberId, messageId)
|
||||
|
||||
createNewChatItem :: (MsgDirectionI d, MonadUnliftIO m) => SQLiteStore -> UserId -> ChatDirection c d -> NewChatItem d -> m ChatItemId
|
||||
createNewChatItem :: MonadUnliftIO m => SQLiteStore -> UserId -> ChatDirection c d -> NewChatItem d -> m ChatItemId
|
||||
createNewChatItem st userId chatDirection NewChatItem {createdByMsgId, itemSent, itemTs, itemContent, itemText, createdAt} =
|
||||
liftIO . withTransaction st $ \db -> do
|
||||
let (contactId_, groupId_, groupMemberId_) = ids
|
||||
@@ -1834,9 +1835,10 @@ createNewChatItem st userId chatDirection NewChatItem {createdByMsgId, itemSent,
|
||||
where
|
||||
ids :: (Maybe Int64, Maybe Int64, Maybe Int64)
|
||||
ids = case chatDirection of
|
||||
CDDirect Contact {contactId} -> (Just contactId, Nothing, Nothing)
|
||||
CDSndGroup GroupInfo {groupId} -> (Nothing, Just groupId, Nothing)
|
||||
CDRcvGroup GroupInfo {groupId} GroupMember {groupMemberId} -> (Nothing, Just groupId, Just groupMemberId)
|
||||
CDDirectSnd Contact {contactId} -> (Just contactId, Nothing, Nothing)
|
||||
CDDirectRcv Contact {contactId} -> (Just contactId, Nothing, Nothing)
|
||||
CDGroupSnd GroupInfo {groupId} -> (Nothing, Just groupId, Nothing)
|
||||
CDGroupRcv GroupInfo {groupId} GroupMember {groupMemberId} -> (Nothing, Just groupId, Just groupMemberId)
|
||||
|
||||
getChatPreviews :: MonadUnliftIO m => SQLiteStore -> User -> m [AChatPreview]
|
||||
getChatPreviews st user =
|
||||
@@ -1936,28 +1938,23 @@ getContact_' db User {userId} contactId =
|
||||
|
||||
getDirectChatItems_ :: DB.Connection -> User -> Int64 -> IO [CChatItem 'CTDirect]
|
||||
getDirectChatItems_ db User {userId} contactId = do
|
||||
chatItems_ <-
|
||||
liftIO $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT
|
||||
-- CChatItem
|
||||
ci.chat_item_id, ci.item_ts, ci.item_content, ci.item_text, ci.created_at
|
||||
FROM chat_items ci
|
||||
LEFT JOIN messages m ON m.message_id == ci.created_by_msg_id
|
||||
LEFT JOIN msg_deliveries md ON md.message_id = m.message_id
|
||||
WHERE ci.user_id = ? AND ci.contact_id = ?
|
||||
|]
|
||||
(userId, contactId)
|
||||
liftIO $ mapM toDirectChatItem chatItems_
|
||||
tz <- getCurrentTimeZone
|
||||
map (toDirectChatItem tz)
|
||||
<$> DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT chat_item_id, item_ts, item_content, item_text, created_at
|
||||
FROM chat_items
|
||||
WHERE user_id = ? AND contact_id = ?
|
||||
|]
|
||||
(userId, contactId)
|
||||
where
|
||||
toDirectChatItem :: (Int64, ChatItemTs, ACIContent, Text, UTCTime) -> IO (CChatItem 'CTDirect)
|
||||
toDirectChatItem (itemId, itemTs, itemContent, itemText, createdAt) = do
|
||||
ciMeta <- liftIO $ mkCIMetaProps itemId itemTs itemText createdAt
|
||||
pure $ case itemContent of
|
||||
ACIContent SMDRcv ciContent -> CChatItem SMDRcv (DirectChatItem (CIRcvMeta ciMeta) ciContent)
|
||||
ACIContent SMDSnd ciContent -> CChatItem SMDSnd (DirectChatItem (CISndMeta ciMeta) ciContent)
|
||||
toDirectChatItem :: TimeZone -> (Int64, ChatItemTs, ACIContent, Text, UTCTime) -> (CChatItem 'CTDirect)
|
||||
toDirectChatItem tz (itemId, itemTs, itemContent, itemText, createdAt) =
|
||||
let ciMeta = mkCIMeta itemId itemText tz itemTs createdAt
|
||||
in case itemContent of
|
||||
ACIContent d@SMDSnd ciContent -> CChatItem d $ ChatItem CIDirectSnd ciMeta ciContent
|
||||
ACIContent d@SMDRcv ciContent -> CChatItem d $ ChatItem CIDirectRcv ciMeta ciContent
|
||||
|
||||
-- getGroupChatItemList :: MonadUnliftIO m => SQLiteStore -> UserId -> Int64 -> m ChatItemList
|
||||
-- getGroupChatItemList st userId groupId =
|
||||
|
||||
+26
-22
@@ -1,3 +1,4 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
@@ -33,6 +34,8 @@ serializeChatResponse = unlines . map unStyle . responseToView ""
|
||||
|
||||
responseToView :: String -> ChatResponse -> [StyledString]
|
||||
responseToView cmd = \case
|
||||
CRApiChats chats -> [sShow chats]
|
||||
CRApiDirectChat chat -> [sShow chat]
|
||||
CRNewChatItem (AChatItem _ _ chat item) -> viewChatItem chat item
|
||||
CRCmdAccepted _ -> r []
|
||||
CRChatHelp section -> case section of
|
||||
@@ -116,31 +119,31 @@ responseToView cmd = \case
|
||||
r' = r
|
||||
|
||||
viewChatItem :: ChatInfo c -> ChatItem c d -> [StyledString]
|
||||
viewChatItem chat item = case (chat, item) of
|
||||
(DirectChat c, DirectChatItem ciMeta content) -> case ciMeta of
|
||||
CISndMeta meta -> case content of
|
||||
CIMsgContent mc -> viewSentMessage to mc meta
|
||||
CISndFileInvitation fId fPath -> viewSentFileInvitation to fId fPath meta
|
||||
CIRcvMeta meta -> case content of
|
||||
CIMsgContent mc -> viewReceivedMessage from meta mc -- mOk
|
||||
CIRcvFileInvitation ft -> viewReceivedFileInvitation from meta ft -- mOk
|
||||
viewChatItem chat (ChatItem cd meta content) = case (chat, cd) of
|
||||
(DirectChat c, CIDirectSnd) -> case content of
|
||||
CISndMsgContent mc -> viewSentMessage to mc meta
|
||||
CISndFileInvitation fId fPath -> viewSentFileInvitation to fId fPath meta
|
||||
where
|
||||
to = ttyToContact' c
|
||||
(DirectChat c, CIDirectRcv) -> case content of
|
||||
CIRcvMsgContent mc -> viewReceivedMessage from meta mc -- mOk
|
||||
CIRcvFileInvitation ft -> viewReceivedFileInvitation from meta ft -- mOk
|
||||
where
|
||||
from = ttyFromContact' c
|
||||
(GroupChat g, SndGroupChatItem (CISndMeta meta) content) -> case content of
|
||||
CIMsgContent mc -> viewSentMessage to mc meta
|
||||
(GroupChat g, CIGroupSnd) -> case content of
|
||||
CISndMsgContent mc -> viewSentMessage to mc meta
|
||||
CISndFileInvitation fId fPath -> viewSentFileInvitation to fId fPath meta
|
||||
where
|
||||
to = ttyToGroup g
|
||||
(GroupChat g, RcvGroupChatItem c (CIRcvMeta meta) content) -> case content of
|
||||
CIMsgContent mc -> viewReceivedMessage from meta mc -- mOk
|
||||
(GroupChat g, CIGroupRcv m) -> case content of
|
||||
CIRcvMsgContent mc -> viewReceivedMessage from meta mc -- mOk
|
||||
CIRcvFileInvitation ft -> viewReceivedFileInvitation from meta ft -- mOk
|
||||
where
|
||||
from = ttyFromGroup' g c
|
||||
from = ttyFromGroup' g m
|
||||
where
|
||||
ttyToContact' Contact {localDisplayName = c} = ttyToContact c
|
||||
ttyFromContact' Contact {localDisplayName = c} = ttyFromContact c
|
||||
ttyFromGroup' g GroupMember {localDisplayName = c} = ttyFromGroup g c
|
||||
ttyFromGroup' g GroupMember {localDisplayName = m} = ttyFromGroup g m
|
||||
|
||||
viewInvalidConnReq :: [StyledString]
|
||||
viewInvalidConnReq =
|
||||
@@ -289,11 +292,11 @@ viewContactUpdated
|
||||
where
|
||||
fullNameUpdate = if T.null fullName' || fullName' == n' then " removed full name" else " updated full name: " <> plain fullName'
|
||||
|
||||
viewReceivedMessage :: StyledString -> CIMetaProps -> MsgContent -> [StyledString]
|
||||
viewReceivedMessage :: StyledString -> CIMeta -> MsgContent -> [StyledString]
|
||||
viewReceivedMessage from meta mc = receivedWithTime_ from meta (ttyMsgContent mc)
|
||||
|
||||
receivedWithTime_ :: StyledString -> CIMetaProps -> [StyledString] -> [StyledString]
|
||||
receivedWithTime_ from CIMetaProps {localItemTs, createdAt} styledMsg = do
|
||||
receivedWithTime_ :: StyledString -> CIMeta -> [StyledString] -> [StyledString]
|
||||
receivedWithTime_ from CIMeta {localItemTs, createdAt} styledMsg = do
|
||||
prependFirst (formattedTime <> " " <> from) styledMsg -- ++ showIntegrity mOk
|
||||
where
|
||||
formattedTime :: StyledString
|
||||
@@ -318,14 +321,14 @@ receivedWithTime_ from CIMetaProps {localItemTs, createdAt} styledMsg = do
|
||||
msgError :: String -> [StyledString]
|
||||
msgError s = [styled (Colored Red) s]
|
||||
|
||||
viewSentMessage :: StyledString -> MsgContent -> CIMetaProps -> [StyledString]
|
||||
viewSentMessage :: StyledString -> MsgContent -> CIMeta -> [StyledString]
|
||||
viewSentMessage to = sentWithTime_ . prependFirst to . ttyMsgContent
|
||||
|
||||
viewSentFileInvitation :: StyledString -> FileTransferId -> FilePath -> CIMetaProps -> [StyledString]
|
||||
viewSentFileInvitation :: StyledString -> FileTransferId -> FilePath -> CIMeta -> [StyledString]
|
||||
viewSentFileInvitation to fId fPath = sentWithTime_ $ ttySentFile to fId fPath
|
||||
|
||||
sentWithTime_ :: [StyledString] -> CIMetaProps -> [StyledString]
|
||||
sentWithTime_ styledMsg CIMetaProps {localItemTs} =
|
||||
sentWithTime_ :: [StyledString] -> CIMeta -> [StyledString]
|
||||
sentWithTime_ styledMsg CIMeta {localItemTs} =
|
||||
prependFirst (ttyMsgTime localItemTs <> " ") styledMsg
|
||||
|
||||
ttyMsgTime :: ZonedTime -> StyledString
|
||||
@@ -363,7 +366,7 @@ sendingFile_ status ft@SndFileTransfer {recipientDisplayName = c} =
|
||||
sndFile :: SndFileTransfer -> StyledString
|
||||
sndFile SndFileTransfer {fileId, fileName} = fileTransferStr fileId fileName
|
||||
|
||||
viewReceivedFileInvitation :: StyledString -> CIMetaProps -> RcvFileTransfer -> [StyledString]
|
||||
viewReceivedFileInvitation :: StyledString -> CIMeta -> RcvFileTransfer -> [StyledString]
|
||||
viewReceivedFileInvitation from meta ft = receivedWithTime_ from meta (receivedFileInvitation_ ft)
|
||||
|
||||
receivedFileInvitation_ :: RcvFileTransfer -> [StyledString]
|
||||
@@ -481,6 +484,7 @@ viewChatError = \case
|
||||
SMP SMP.AUTH -> ["error: this connection is deleted"]
|
||||
e -> ["smp agent error: " <> sShow e]
|
||||
ChatErrorMessage e -> ["chat message error: " <> sShow e]
|
||||
ChatErrorNotImplemented -> ["chat error: not implemented"]
|
||||
where
|
||||
fileNotFound fileId = ["file " <> sShow fileId <> " not found"]
|
||||
|
||||
|
||||
Reference in New Issue
Block a user