diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 894d142925..4f9aff7650 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -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 diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index fbdbae3054..7ef963d598 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -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 diff --git a/src/Simplex/Chat/Messages.hs b/src/Simplex/Chat/Messages.hs index 4d5c4d9344..b0cda969eb 100644 --- a/src/Simplex/Chat/Messages.hs +++ b/src/Simplex/Chat/Messages.hs @@ -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 diff --git a/src/Simplex/Chat/Store.hs b/src/Simplex/Chat/Store.hs index 29823e02c0..af13503d2a 100644 --- a/src/Simplex/Chat/Store.hs +++ b/src/Simplex/Chat/Store.hs @@ -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 = diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 6d027ed45b..225715e04a 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -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"]