From f5507436f3239640d61e6ff522d5fec873b3e647 Mon Sep 17 00:00:00 2001 From: Efim Poberezkin <8711996+efim-poberezkin@users.noreply.github.com> Date: Mon, 7 Feb 2022 15:19:34 +0400 Subject: [PATCH] chat item status, CRChatItemUpdated api response (#269) --- cabal.project | 2 +- sha256map.nix | 2 +- simplex-chat.cabal | 1 + src/Simplex/Chat.hs | 46 ++-- src/Simplex/Chat/Controller.hs | 2 + src/Simplex/Chat/Messages.hs | 102 ++++++++- .../Migrations/M20220205_chat_item_status.hs | 20 ++ src/Simplex/Chat/Mobile.hs | 11 +- src/Simplex/Chat/Store.hs | 206 ++++++++++++------ src/Simplex/Chat/Terminal.hs | 5 +- src/Simplex/Chat/View.hs | 13 +- stack.yaml | 2 +- tests/ChatClient.hs | 2 +- tests/MobileTests.hs | 2 +- 14 files changed, 309 insertions(+), 107 deletions(-) create mode 100644 src/Simplex/Chat/Migrations/M20220205_chat_item_status.hs diff --git a/cabal.project b/cabal.project index 2d18b117c..d072754b5 100644 --- a/cabal.project +++ b/cabal.project @@ -3,7 +3,7 @@ packages: . source-repository-package type: git location: git://github.com/simplex-chat/simplexmq.git - tag: 137ff7043d49feb3b350f56783c9b64a62bc636a + tag: c9994c3a2ca945b9b67e250163cf8d560d2ed554 source-repository-package type: git diff --git a/sha256map.nix b/sha256map.nix index fc95b7a30..f673f7fab 100644 --- a/sha256map.nix +++ b/sha256map.nix @@ -1,5 +1,5 @@ { - "git://github.com/simplex-chat/simplexmq.git"."137ff7043d49feb3b350f56783c9b64a62bc636a" = "1jlxpmg40qkvisbf03082yrw6k2ah9dsw8pn1jqc0cyz5250qc49"; + "git://github.com/simplex-chat/simplexmq.git"."c9994c3a2ca945b9b67e250163cf8d560d2ed554" = "0lc4jb46ys0hllv5p3i3x2rw8j4s8xxmz66kp893a23ki68ljyhp"; "git://github.com/simplex-chat/aeson.git"."3eb66f9a68f103b5f1489382aad89f5712a64db7" = "0kilkx59fl6c3qy3kjczqvm8c3f4n3p0bdk9biyflf51ljnzp4yp"; "git://github.com/simplex-chat/haskell-terminal.git"."f708b00009b54890172068f168bf98508ffcd495" = "0zmq7lmfsk8m340g47g5963yba7i88n4afa6z93sg9px5jv1mijj"; "git://github.com/zw3rk/android-support.git"."3c3a5ab0b8b137a072c98d3d0937cbdc96918ddb" = "1r6jyxbim3dsvrmakqfyxbd6ms6miaghpbwyl0sr6dzwpgaprz97"; diff --git a/simplex-chat.cabal b/simplex-chat.cabal index 01568eb81..457a74f60 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -26,6 +26,7 @@ library Simplex.Chat.Messages Simplex.Chat.Migrations.M20220101_initial Simplex.Chat.Migrations.M20220122_v1_1 + Simplex.Chat.Migrations.M20220205_chat_item_status Simplex.Chat.Mobile Simplex.Chat.Options Simplex.Chat.Protocol diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 308810edb..e85997981 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -51,7 +51,7 @@ import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (parseAll) -import Simplex.Messaging.Protocol (MsgBody) +import Simplex.Messaging.Protocol (ErrorType (..), MsgBody) import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.Util (tryError) import System.Exit (exitFailure, exitSuccess) @@ -73,9 +73,11 @@ defaultChatConfig = { tcpPort = undefined, -- agent does not listen to TCP smpServers = undefined, -- filled in from options dbFile = undefined, -- filled in from options - dbPoolSize = 1 + dbPoolSize = 1, + yesToMigrations = False }, dbPoolSize = 1, + yesToMigrations = False, tbqSize = 16, fileChunkSize = 15780 } @@ -218,7 +220,7 @@ processChatCommand = \case deleteConnection a (aConnId conn) `catchError` \(_ :: AgentErrorType) -> pure () withStore $ \st -> deleteUserContactLink st userId pure CRUserContactLinkDeleted - ShowMyAddress -> CRUserContactLink <$> (withUser $ \User {userId} -> withStore (`getUserContactLink` userId)) + ShowMyAddress -> CRUserContactLink <$> withUser (\User {userId} -> withStore (`getUserContactLink` userId)) AcceptContact cName -> withUser $ \User {userId} -> do connReqId <- withStore $ \st -> getContactRequestIdByName st userId cName processChatCommand $ APIAcceptContact connReqId @@ -298,7 +300,7 @@ processChatCommand = \case mapM_ deleteMemberConnection members withStore $ \st -> deleteGroup st user g pure $ CRGroupDeletedUser gInfo - ListMembers gName -> CRGroupMembers <$> (withUser $ \user -> withStore (\st -> getGroupByName st user gName)) + ListMembers gName -> CRGroupMembers <$> withUser (\user -> withStore (\st -> getGroupByName st user gName)) ListGroups -> CRGroupsList <$> withUser (\user -> withStore (`getUserGroupDetails` user)) SendGroupMessage gName msg -> withUser $ \user -> do groupId <- withStore $ \st -> getGroupIdByName st user gName @@ -312,7 +314,7 @@ processChatCommand = \case SndFileTransfer {fileId} <- withStore $ \st -> createSndFileTransfer st userId contact f fileInv agentConnId chSize ci <- sendDirectChatItem userId contact (XFile fileInv) (CISndFileInvitation fileId f) - withStore $ \st -> updateFileTransferChatItemId st fileId $ chatItemId ci + withStore $ \st -> updateFileTransferChatItemId st fileId $ chatItemId' ci setActive $ ActiveC cName pure . CRNewChatItem $ AChatItem SCTDirect SMDSnd (DirectChat contact) ci SendGroupFile gName f -> withUser $ \user@User {userId} -> withChatLock $ do @@ -546,7 +548,7 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage _ -> Nothing processDirectMessage :: ACommand 'Agent -> Connection -> Maybe Contact -> m () - processDirectMessage agentMsg conn = \case + processDirectMessage agentMsg conn@Connection {connId} = \case Nothing -> case agentMsg of CONF confId connInfo -> do saveConnInfo conn connInfo @@ -558,9 +560,10 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage withAckMessage agentConnId meta $ pure () ackMsgDeliveryEvent conn meta SENT msgId -> + -- ? updateDirectChatItem sentMsgDeliveryEvent conn msgId -- TODO print errors - MERR _ _ -> pure () + MERR _ _ -> pure () -- ? updateDirectChatItem ERR _ -> pure () -- TODO add debugging output _ -> pure () @@ -609,8 +612,14 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage when (memberIsReady m) $ do notifyMemberConnected gInfo m when (memberCategory m == GCPreMember) $ probeMatchingContacts ct - SENT msgId -> + SENT msgId -> do sentMsgDeliveryEvent conn msgId + chatItemId_ <- withStore $ \st -> getChatItemIdByAgentMsgId st connId msgId + case chatItemId_ of + Nothing -> pure () + Just chatItemId -> do + chatItem <- withStore $ \st -> updateDirectChatItem st chatItemId CISSndSent + toView $ CRChatItemUpdated (AChatItem SCTDirect SMDSnd (DirectChat ct) chatItem) END -> do toView $ CRContactAnotherClient ct showToast (c <> "> ") "connected to another client" @@ -623,7 +632,13 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage showToast (c <> "> ") "is active" setActive $ ActiveC c -- TODO print errors - MERR _ _ -> pure () + MERR msgId err -> do + chatItemId_ <- withStore $ \st -> getChatItemIdByAgentMsgId st connId msgId + case chatItemId_ of + Nothing -> pure () + Just chatItemId -> do + chatItem <- withStore $ \st -> updateDirectChatItem st chatItemId (agentErrToItemStatus err) + toView $ CRChatItemUpdated (AChatItem SCTDirect SMDSnd (DirectChat ct) chatItem) ERR _ -> pure () -- TODO add debugging output _ -> pure () @@ -821,6 +836,10 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage sentMsgDeliveryEvent Connection {connId} msgId = withStore $ \st -> createSndMsgDeliveryEvent st connId msgId MDSSndSent + agentErrToItemStatus :: AgentErrorType -> CIStatus 'MDSnd + agentErrToItemStatus (SMP AUTH) = CISSndErrorAuth + agentErrToItemStatus err = CISSndError err + badRcvFileChunk :: RcvFileTransfer -> String -> m () badRcvFileChunk ft@RcvFileTransfer {fileStatus} err = case fileStatus of @@ -879,7 +898,7 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage chSize <- asks $ fileChunkSize . config ft@RcvFileTransfer {fileId} <- withStore $ \st -> createRcvFileTransfer st userId ct fInv chSize ci <- saveRcvDirectChatItem userId ct msgId msgMeta (CIRcvFileInvitation ft) - withStore $ \st -> updateFileTransferChatItemId st fileId $ chatItemId ci + withStore $ \st -> updateFileTransferChatItemId st fileId $ chatItemId' ci toView . CRNewChatItem $ AChatItem SCTDirect SMDRcv (DirectChat ct) ci checkIntegrity msgMeta $ toView . CRMsgIntegrityError showToast (c <> "> ") "wants to send a file" @@ -890,7 +909,7 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage chSize <- asks $ fileChunkSize . config ft@RcvFileTransfer {fileId} <- withStore $ \st -> createRcvGroupFileTransfer st userId m fInv chSize ci <- saveRcvGroupChatItem userId gInfo m msgId msgMeta (CIRcvFileInvitation ft) - withStore $ \st -> updateFileTransferChatItemId st fileId $ chatItemId ci + withStore $ \st -> updateFileTransferChatItemId st fileId $ chatItemId' ci toView . CRNewChatItem $ AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci checkIntegrity msgMeta $ toView . CRMsgIntegrityError let g = groupName' gInfo @@ -1248,11 +1267,11 @@ saveRcvGroupChatItem userId g m msgId MsgMeta {broker = (_, brokerTs)} ciContent ciMeta <- saveChatItem userId (CDGroupRcv g m) $ mkNewChatItem ciContent msgId brokerTs createdAt pure $ ChatItem (CIGroupRcv m) ciMeta ciContent -saveChatItem :: ChatMonad m => UserId -> ChatDirection c d -> NewChatItem d -> m CIMeta +saveChatItem :: (ChatMonad m, MsgDirectionI d) => UserId -> ChatDirection c d -> NewChatItem d -> m (CIMeta d) saveChatItem userId cd ci@NewChatItem {itemTs, itemText, createdAt} = do tz <- liftIO getCurrentTimeZone ciId <- withStore $ \st -> createNewChatItem st userId cd ci - pure $ mkCIMeta ciId itemText tz itemTs createdAt + pure $ mkCIMeta ciId itemText ciStatusNew tz itemTs createdAt mkNewChatItem :: forall d. MsgDirectionI d => CIContent d -> MessageId -> UTCTime -> UTCTime -> NewChatItem d mkNewChatItem itemContent msgId itemTs createdAt = @@ -1262,6 +1281,7 @@ mkNewChatItem itemContent msgId itemTs createdAt = itemTs, itemContent, itemText = ciContentToText itemContent, + itemStatus = ciStatusNew, createdAt } diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index d38b5f2da..5ac7092fc 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -47,6 +47,7 @@ updateStr = "To update run: curl -o- https://raw.githubusercontent.com/simplex-c data ChatConfig = ChatConfig { agentConfig :: AgentConfig, dbPoolSize :: Int, + yesToMigrations :: Bool, tbqSize :: Natural, fileChunkSize :: Integer } @@ -130,6 +131,7 @@ data ChatResponse | CRApiChats {chats :: [AChat]} | CRApiChat {chat :: AChat} | CRNewChatItem {chatItem :: AChatItem} + | CRChatItemUpdated {chatItem :: AChatItem} | CRMsgIntegrityError {msgerror :: MsgErrorType} -- TODO make it chat item to support in mobile | CRCmdAccepted {corr :: CorrId} | CRChatHelp {helpSection :: HelpSection} diff --git a/src/Simplex/Chat/Messages.hs b/src/Simplex/Chat/Messages.hs index edf42d265..f502f5d60 100644 --- a/src/Simplex/Chat/Messages.hs +++ b/src/Simplex/Chat/Messages.hs @@ -15,6 +15,7 @@ module Simplex.Chat.Messages where import Data.Aeson (FromJSON, ToJSON) import qualified Data.Aeson as J +import qualified Data.Attoparsec.ByteString.Char8 as A import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Lazy.Char8 as LB import Data.Int (Int64) @@ -30,12 +31,13 @@ import Database.SQLite.Simple.ToField (ToField (..)) import GHC.Generics (Generic) import Simplex.Chat.Protocol import Simplex.Chat.Types -import Simplex.Messaging.Agent.Protocol (AgentMsgId, MsgMeta (..)) +import Simplex.Chat.Util (eitherToMaybe, safeDecodeUtf8) +import Simplex.Messaging.Agent.Protocol (AgentErrorType, AgentMsgId, MsgMeta (..)) import Simplex.Messaging.Agent.Store.SQLite (fromTextField_) import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (dropPrefix, enumJSON, sumTypeJSON) import Simplex.Messaging.Protocol (MsgBody) -import Simplex.Chat.Util (safeDecodeUtf8) +import Simplex.Messaging.Util ((<$?>)) data ChatType = CTDirect | CTGroup | CTContactRequest deriving (Show, Generic) @@ -73,7 +75,7 @@ jsonChatInfo = \case data ChatItem (c :: ChatType) (d :: MsgDirection) = ChatItem { chatDir :: CIDirection c d, - meta :: CIMeta, + meta :: CIMeta d, content :: CIContent d } deriving (Show, Generic) @@ -115,7 +117,7 @@ jsonCIDirection = \case CIGroupSnd -> JCIGroupSnd CIGroupRcv m -> JCIGroupRcv m -data CChatItem c = forall d. CChatItem (SMsgDirection d) (ChatItem c d) +data CChatItem c = forall d. MsgDirectionI d => CChatItem (SMsgDirection d) (ChatItem c d) deriving instance Show (CChatItem c) @@ -123,8 +125,8 @@ instance ToJSON (CChatItem c) where toJSON (CChatItem _ ci) = J.toJSON ci toEncoding (CChatItem _ ci) = J.toEncoding ci -chatItemId :: ChatItem c d -> ChatItemId -chatItemId ChatItem {meta = CIMeta {itemId}} = itemId +chatItemId' :: ChatItem c d -> ChatItemId +chatItemId' ChatItem {meta = CIMeta {itemId}} = itemId data ChatDirection (c :: ChatType) (d :: MsgDirection) where CDDirectSnd :: Contact -> ChatDirection 'CTDirect 'MDSnd @@ -138,6 +140,7 @@ data NewChatItem d = NewChatItem itemTs :: ChatItemTs, itemContent :: CIContent d, itemText :: Text, + itemStatus :: CIStatus d, createdAt :: UTCTime } deriving (Show) @@ -174,21 +177,91 @@ instance ToJSON (JSONAnyChatItem c d) where toJSON = J.genericToJSON J.defaultOptions toEncoding = J.genericToEncoding J.defaultOptions -data CIMeta = CIMeta +data CIMeta (d :: MsgDirection) = CIMeta { itemId :: ChatItemId, itemTs :: ChatItemTs, itemText :: Text, + itemStatus :: CIStatus d, localItemTs :: ZonedTime, createdAt :: UTCTime } - deriving (Show, Generic, FromJSON) + deriving (Show, Generic) -mkCIMeta :: ChatItemId -> Text -> TimeZone -> ChatItemTs -> UTCTime -> CIMeta -mkCIMeta itemId itemText tz itemTs createdAt = +mkCIMeta :: ChatItemId -> Text -> CIStatus d -> TimeZone -> ChatItemTs -> UTCTime -> CIMeta d +mkCIMeta itemId itemText itemStatus tz itemTs createdAt = let localItemTs = utcToZonedTime tz itemTs - in CIMeta {itemId, itemTs, itemText, localItemTs, createdAt} + in CIMeta {itemId, itemTs, itemText, itemStatus, localItemTs, createdAt} -instance ToJSON CIMeta where toEncoding = J.genericToEncoding J.defaultOptions +instance ToJSON (CIMeta d) where toEncoding = J.genericToEncoding J.defaultOptions + +data CIStatus (d :: MsgDirection) where + CISSndNew :: CIStatus 'MDSnd + CISSndSent :: CIStatus 'MDSnd + CISSndErrorAuth :: CIStatus 'MDSnd + CISSndError :: AgentErrorType -> CIStatus 'MDSnd + CISRcvNew :: CIStatus 'MDRcv + CISRcvRead :: CIStatus 'MDRcv + +deriving instance Show (CIStatus d) + +ciStatusNew :: forall d. MsgDirectionI d => CIStatus d +ciStatusNew = case msgDirection @d of + SMDSnd -> CISSndNew + SMDRcv -> CISRcvNew + +instance ToJSON (CIStatus d) where + toJSON = J.toJSON . jsonCIStatus + toEncoding = J.toEncoding . jsonCIStatus + +instance MsgDirectionI d => ToField (CIStatus d) where toField = toField . decodeLatin1 . strEncode + +instance FromField ACIStatus where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8 + +data ACIStatus = forall d. MsgDirectionI d => ACIStatus (SMsgDirection d) (CIStatus d) + +instance MsgDirectionI d => StrEncoding (CIStatus d) where + strEncode = \case + CISSndNew -> "snd_new" + CISSndSent -> "snd_sent" + CISSndErrorAuth -> "snd_error_auth" + CISSndError e -> "snd_error " <> strEncode e + CISRcvNew -> "rcv_new" + CISRcvRead -> "rcv_read" + strP = (\(ACIStatus _ st) -> checkDirection st) <$?> strP + +instance StrEncoding ACIStatus where + strEncode (ACIStatus _ s) = strEncode s + strP = + A.takeTill (== ' ') >>= \case + "snd_new" -> pure $ ACIStatus SMDSnd CISSndNew + "snd_sent" -> pure $ ACIStatus SMDSnd CISSndSent + "snd_error_auth" -> pure $ ACIStatus SMDSnd CISSndErrorAuth + "snd_error" -> ACIStatus SMDSnd <$> (A.space *> strP) + "rcv_new" -> pure $ ACIStatus SMDRcv CISRcvNew + "rcv_read" -> pure $ ACIStatus SMDRcv CISRcvRead + _ -> fail "bad status" + +data JSONCIStatus + = JCISSndNew + | JCISSndSent + | JCISSndErrorAuth + | JCISSndError {agentError :: AgentErrorType} + | JCISRcvNew + | JCISRcvRead + deriving (Show, Generic) + +instance ToJSON JSONCIStatus where + toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "JCIS" + toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "JCIS" + +jsonCIStatus :: CIStatus d -> JSONCIStatus +jsonCIStatus = \case + CISSndNew -> JCISSndNew + CISSndSent -> JCISSndSent + CISSndErrorAuth -> JCISSndErrorAuth + CISSndError e -> JCISSndError e + CISRcvNew -> JCISRcvNew + CISRcvRead -> JCISRcvRead type ChatItemId = Int64 @@ -420,3 +493,8 @@ msgDeliveryStatusT' s = case testEquality d (msgDirection @d) of Just Refl -> Just st _ -> Nothing + +checkDirection :: forall t d d'. (MsgDirectionI d, MsgDirectionI d') => t d' -> Either String (t d) +checkDirection x = case testEquality (msgDirection @d) (msgDirection @d') of + Just Refl -> Right x + Nothing -> Left "bad direction" diff --git a/src/Simplex/Chat/Migrations/M20220205_chat_item_status.hs b/src/Simplex/Chat/Migrations/M20220205_chat_item_status.hs new file mode 100644 index 000000000..6baca156f --- /dev/null +++ b/src/Simplex/Chat/Migrations/M20220205_chat_item_status.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Simplex.Chat.Migrations.M20220205_chat_item_status where + +import Database.SQLite.Simple (Query) +import Database.SQLite.Simple.QQ (sql) + +m20220205_chat_item_status :: Query +m20220205_chat_item_status = + [sql| +PRAGMA ignore_check_constraints=ON; + +ALTER TABLE chat_items ADD COLUMN item_status TEXT CHECK (item_status NOT NULL); + +UPDATE chat_items SET item_status = 'rcv_read' WHERE item_sent = 0; + +UPDATE chat_items SET item_status = 'snd_sent' WHERE item_sent = 1; + +PRAGMA ignore_check_constraints=OFF; +|] diff --git a/src/Simplex/Chat/Mobile.hs b/src/Simplex/Chat/Mobile.hs index 293211a6a..1904d5565 100644 --- a/src/Simplex/Chat/Mobile.hs +++ b/src/Simplex/Chat/Mobile.hs @@ -53,6 +53,13 @@ mobileChatOpts = logging = False } +defaultMobileConfig :: ChatConfig +defaultMobileConfig = + defaultChatConfig + { yesToMigrations = True, + agentConfig = agentConfig defaultChatConfig {yesToMigrations = True} + } + type CJSONString = CString getActiveUser_ :: SQLiteStore -> IO (Maybe User) @@ -61,9 +68,9 @@ getActiveUser_ st = find activeUser <$> getUsers st chatInit :: String -> IO ChatController chatInit dbFilePrefix = do let f = chatStoreFile dbFilePrefix - chatStore <- createStore f $ dbPoolSize defaultChatConfig + chatStore <- createStore f (dbPoolSize defaultMobileConfig) (yesToMigrations defaultMobileConfig) user_ <- getActiveUser_ chatStore - newChatController chatStore user_ defaultChatConfig mobileChatOpts {dbFilePrefix} . const $ pure () + newChatController chatStore user_ defaultMobileConfig mobileChatOpts {dbFilePrefix} . const $ pure () chatSendCmd :: ChatController -> String -> IO JSONString chatSendCmd cc s = LB.unpack . J.encode . APIResponse Nothing <$> runReaderT (execChatCommand $ B.pack s) cc diff --git a/src/Simplex/Chat/Store.hs b/src/Simplex/Chat/Store.hs index 08d05b1f3..b0ff6b72c 100644 --- a/src/Simplex/Chat/Store.hs +++ b/src/Simplex/Chat/Store.hs @@ -13,6 +13,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} module Simplex.Chat.Store @@ -113,6 +114,8 @@ module Simplex.Chat.Store getChatPreviews, getDirectChat, getGroupChat, + getChatItemIdByAgentMsgId, + updateDirectChatItem, ) where @@ -125,6 +128,7 @@ import Control.Monad.IO.Unlift import Crypto.Random (ChaChaDRG, randomBytesGenerate) import Data.Aeson (ToJSON) import qualified Data.Aeson as J +import Data.Bifunctor (first) import qualified Data.ByteString.Base64 as B64 import Data.ByteString.Char8 (ByteString) import Data.Either (rights) @@ -138,6 +142,7 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Time.Clock (UTCTime (..), getCurrentTime) import Data.Time.LocalTime (TimeZone, getCurrentTimeZone) +import Data.Type.Equality import Database.SQLite.Simple (NamedParam (..), Only (..), Query (..), SQLError, (:.) (..)) import qualified Database.SQLite.Simple as DB import Database.SQLite.Simple.QQ (sql) @@ -145,6 +150,7 @@ import GHC.Generics (Generic) import Simplex.Chat.Messages import Simplex.Chat.Migrations.M20220101_initial import Simplex.Chat.Migrations.M20220122_v1_1 +import Simplex.Chat.Migrations.M20220205_chat_item_status import Simplex.Chat.Protocol import Simplex.Chat.Types import Simplex.Chat.Util (eitherToMaybe) @@ -160,7 +166,8 @@ import UnliftIO.STM schemaMigrations :: [(String, Query)] schemaMigrations = [ ("20220101_initial", m20220101_initial), - ("20220122_v1_1", m20220122_v1_1) + ("20220122_v1_1", m20220122_v1_1), + ("20220205_chat_item_status", m20220205_chat_item_status) ] -- | The list of migrations in ascending order by date @@ -169,7 +176,7 @@ migrations = sortBy (compare `on` name) $ map migration schemaMigrations where migration (name, query) = Migration {name = name, up = fromQuery query} -createStore :: FilePath -> Int -> IO SQLiteStore +createStore :: FilePath -> Int -> Bool -> IO SQLiteStore createStore dbFilePath poolSize = createSQLiteStore dbFilePath poolSize migrations chatStoreFile :: FilePath -> FilePath @@ -181,7 +188,7 @@ checkConstraint err action = action `E.catch` (pure . Left . handleSQLError err) handleSQLError :: StoreError -> SQLError -> StoreError handleSQLError err e | DB.sqlError e == DB.ErrorConstraint = err - | otherwise = SEInternal $ show e + | otherwise = SEInternalError $ show e insertedRowId :: DB.Connection -> IO Int64 insertedRowId db = fromOnly . head <$> DB.query_ db "SELECT last_insert_rowid()" @@ -851,7 +858,7 @@ getConnectionEntity st User {userId, userContactId} agentConnId = Nothing -> if connType == ConnContact then pure $ RcvDirectMsgConnection c Nothing - else throwError $ SEInternal $ "connection " <> show connType <> " without entity" + else throwError $ SEInternalError $ "connection " <> show connType <> " without entity" Just entId -> case connType of ConnMember -> uncurry (RcvGroupMsgConnection c) <$> getGroupAndMember_ db entId c @@ -891,10 +898,10 @@ getConnectionEntity st User {userId, userContactId} agentConnId = toContact' contactId activeConn [(localDisplayName, displayName, fullName, viaGroup, createdAt)] = let profile = Profile {displayName, fullName} in Right $ Contact {contactId, localDisplayName, profile, activeConn, viaGroup, createdAt} - toContact' _ _ _ = Left $ SEInternal "referenced contact not found" + toContact' _ _ _ = Left $ SEInternalError "referenced contact not found" getGroupAndMember_ :: DB.Connection -> Int64 -> Connection -> ExceptT StoreError IO (GroupInfo, GroupMember) getGroupAndMember_ db groupMemberId c = ExceptT $ do - firstRow (toGroupAndMember c) (SEInternal "referenced group member not found") $ + firstRow (toGroupAndMember c) (SEInternalError "referenced group member not found") $ DB.query db [sql| @@ -1925,8 +1932,8 @@ createMsgDeliveryEvent_ db msgDeliveryId msgDeliveryStatus createdAt = do getMsgDeliveryId_ :: DB.Connection -> Int64 -> AgentMsgId -> IO (Either StoreError Int64) getMsgDeliveryId_ db connId agentMsgId = - toMsgDeliveryId - <$> DB.query + firstRow fromOnly (SENoMsgDelivery connId agentMsgId) $ + DB.query db [sql| SELECT msg_delivery_id @@ -1935,10 +1942,6 @@ getMsgDeliveryId_ db connId agentMsgId = LIMIT 1 |] (connId, agentMsgId) - where - toMsgDeliveryId :: [Only Int64] -> Either StoreError Int64 - toMsgDeliveryId [Only msgDeliveryId] = Right msgDeliveryId - toMsgDeliveryId _ = Left $ SENoMsgDelivery connId agentMsgId createPendingGroupMessage :: MonadUnliftIO m => SQLiteStore -> Int64 -> MessageId -> Maybe Int64 -> m () createPendingGroupMessage st groupMemberId messageId introId_ = @@ -1975,20 +1978,20 @@ 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 :: MonadUnliftIO m => SQLiteStore -> UserId -> ChatDirection c d -> NewChatItem d -> m ChatItemId -createNewChatItem st userId chatDirection NewChatItem {createdByMsgId, itemSent, itemTs, itemContent, itemText, createdAt} = +createNewChatItem :: (MonadUnliftIO m, MsgDirectionI d) => SQLiteStore -> UserId -> ChatDirection c d -> NewChatItem d -> m ChatItemId +createNewChatItem st userId chatDirection NewChatItem {createdByMsgId, itemSent, itemTs, itemContent, itemText, itemStatus, createdAt} = liftIO . withTransaction st $ \db -> do let (contactId_, groupId_, groupMemberId_) = ids DB.execute db [sql| INSERT INTO chat_items ( - user_id, contact_id, group_id, group_member_id, - created_by_msg_id, item_sent, item_ts, item_content, item_text, created_at, updated_at - ) VALUES (?,?,?,?,?,?,?,?,?,?,?) + user_id, contact_id, group_id, group_member_id, created_by_msg_id, + item_sent, item_ts, item_content, item_text, item_status, created_at, updated_at + ) VALUES (?,?,?,?,?,?,?,?,?,?,?,?) |] - ( (userId, contactId_, groupId_, groupMemberId_) - :. (createdByMsgId, itemSent, itemTs, itemContent, itemText, createdAt, createdAt) + ( (userId, contactId_, groupId_, groupMemberId_, createdByMsgId) + :. (itemSent, itemTs, itemContent, itemText, itemStatus, createdAt, createdAt) ) ciId <- insertedRowId db case createdByMsgId of @@ -2038,7 +2041,7 @@ getDirectChatPreviews_ db User {userId} = do c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.conn_status, c.conn_type, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, -- ChatItem - ci.chat_item_id, ci.item_ts, ci.item_content, ci.item_text, ci.created_at + ci.chat_item_id, ci.item_ts, ci.item_content, ci.item_text, ci.item_status, ci.created_at FROM contacts ct JOIN contact_profiles cp ON ct.contact_profile_id = cp.contact_profile_id JOIN connections c ON c.contact_id = ct.contact_id @@ -2083,7 +2086,7 @@ getGroupChatPreviews_ db User {userId, userContactId} = do mu.member_status, mu.invited_by, mu.local_display_name, mu.contact_id, pu.display_name, pu.full_name, -- ChatItem - ci.chat_item_id, ci.item_ts, ci.item_content, ci.item_text, ci.created_at, + ci.chat_item_id, ci.item_ts, ci.item_content, ci.item_text, ci.item_status, ci.created_at, -- Maybe GroupMember - sender m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, m.member_status, m.invited_by, m.local_display_name, m.contact_id, @@ -2145,20 +2148,22 @@ getDirectChat st user contactId pagination = getDirectChatLast_ :: DB.Connection -> User -> Int64 -> Int -> ExceptT StoreError IO (Chat 'CTDirect) getDirectChatLast_ db User {userId} contactId count = do contact <- ExceptT $ getContact_ db userId contactId - chatItems <- liftIO getDirectChatItemsLast_ + chatItems <- ExceptT getDirectChatItemsLast_ pure $ Chat (DirectChat contact) (reverse chatItems) where - getDirectChatItemsLast_ :: IO [CChatItem 'CTDirect] + getDirectChatItemsLast_ :: IO (Either StoreError [CChatItem 'CTDirect]) getDirectChatItemsLast_ = do tz <- getCurrentTimeZone - map (toDirectChatItem tz) + mapM (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 = ? - ORDER BY chat_item_id DESC + SELECT + -- ChatItem + ci.chat_item_id, ci.item_ts, ci.item_content, ci.item_text, ci.item_status, ci.created_at + FROM chat_items ci + WHERE ci.user_id = ? AND ci.contact_id = ? + ORDER BY ci.chat_item_id DESC LIMIT ? |] (userId, contactId, count) @@ -2166,20 +2171,22 @@ getDirectChatLast_ db User {userId} contactId count = do getDirectChatAfter_ :: DB.Connection -> User -> Int64 -> ChatItemId -> Int -> ExceptT StoreError IO (Chat 'CTDirect) getDirectChatAfter_ db User {userId} contactId afterChatItemId count = do contact <- ExceptT $ getContact_ db userId contactId - chatItems <- liftIO getDirectChatItemsAfter_ + chatItems <- ExceptT getDirectChatItemsAfter_ pure $ Chat (DirectChat contact) chatItems where - getDirectChatItemsAfter_ :: IO [CChatItem 'CTDirect] + getDirectChatItemsAfter_ :: IO (Either StoreError [CChatItem 'CTDirect]) getDirectChatItemsAfter_ = do tz <- getCurrentTimeZone - map (toDirectChatItem tz) + mapM (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 = ? AND chat_item_id > ? - ORDER BY chat_item_id ASC + SELECT + -- ChatItem + ci.chat_item_id, ci.item_ts, ci.item_content, ci.item_text, ci.item_status, ci.created_at + FROM chat_items ci + WHERE ci.user_id = ? AND ci.contact_id = ? AND ci.chat_item_id > ? + ORDER BY ci.chat_item_id ASC LIMIT ? |] (userId, contactId, afterChatItemId, count) @@ -2187,20 +2194,22 @@ getDirectChatAfter_ db User {userId} contactId afterChatItemId count = do getDirectChatBefore_ :: DB.Connection -> User -> Int64 -> ChatItemId -> Int -> ExceptT StoreError IO (Chat 'CTDirect) getDirectChatBefore_ db User {userId} contactId beforeChatItemId count = do contact <- ExceptT $ getContact_ db userId contactId - chatItems <- liftIO getDirectChatItemsBefore_ + chatItems <- ExceptT getDirectChatItemsBefore_ pure $ Chat (DirectChat contact) (reverse chatItems) where - getDirectChatItemsBefore_ :: IO [CChatItem 'CTDirect] + getDirectChatItemsBefore_ :: IO (Either StoreError [CChatItem 'CTDirect]) getDirectChatItemsBefore_ = do tz <- getCurrentTimeZone - map (toDirectChatItem tz) + mapM (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 = ? AND chat_item_id < ? - ORDER BY chat_item_id DESC + SELECT + -- ChatItem + ci.chat_item_id, ci.item_ts, ci.item_content, ci.item_text, ci.item_status, ci.created_at + FROM chat_items ci + WHERE ci.user_id = ? AND ci.contact_id = ? AND ci.chat_item_id < ? + ORDER BY ci.chat_item_id DESC LIMIT ? |] (userId, contactId, beforeChatItemId, count) @@ -2266,7 +2275,7 @@ getGroupChatLast_ db user@User {userId, userContactId} groupId count = do [sql| SELECT -- ChatItem - ci.chat_item_id, ci.item_ts, ci.item_content, ci.item_text, ci.created_at, + ci.chat_item_id, ci.item_ts, ci.item_content, ci.item_text, ci.item_status, ci.created_at, -- GroupMember m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, m.member_status, m.invited_by, m.local_display_name, m.contact_id, @@ -2295,7 +2304,7 @@ getGroupChatAfter_ db user@User {userId, userContactId} groupId afterChatItemId [sql| SELECT -- ChatItem - ci.chat_item_id, ci.item_ts, ci.item_content, ci.item_text, ci.created_at, + ci.chat_item_id, ci.item_ts, ci.item_content, ci.item_text, ci.item_status, ci.created_at, -- GroupMember m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, m.member_status, m.invited_by, m.local_display_name, m.contact_id, @@ -2324,7 +2333,7 @@ getGroupChatBefore_ db user@User {userId, userContactId} groupId beforeChatItemI [sql| SELECT -- ChatItem - ci.chat_item_id, ci.item_ts, ci.item_content, ci.item_text, ci.created_at, + ci.chat_item_id, ci.item_ts, ci.item_content, ci.item_text, ci.item_status, ci.created_at, -- GroupMember m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, m.member_status, m.invited_by, m.local_display_name, m.contact_id, @@ -2373,20 +2382,75 @@ getGroupIdByName_ db User {userId} gName = firstRow fromOnly (SEGroupNotFoundByName gName) $ DB.query db "SELECT group_id FROM groups WHERE user_id = ? AND local_display_name = ?" (userId, gName) -type ChatItemRow = (Int64, ChatItemTs, ACIContent, Text, UTCTime) +getChatItemIdByAgentMsgId :: StoreMonad m => SQLiteStore -> Int64 -> AgentMsgId -> m (Maybe ChatItemId) +getChatItemIdByAgentMsgId st connId msgId = + liftIO . withTransaction st $ \db -> + join . listToMaybe . map fromOnly + <$> DB.query + db + [sql| + SELECT chat_item_id + FROM chat_item_messages + WHERE message_id = ( + SELECT message_id + FROM msg_deliveries + WHERE connection_id = ? AND agent_msg_id = ? + LIMIT 1 + ) + |] + (connId, msgId) -type MaybeChatItemRow = (Maybe Int64, Maybe ChatItemTs, Maybe ACIContent, Maybe Text, Maybe UTCTime) +updateDirectChatItem :: (StoreMonad m, MsgDirectionI d) => SQLiteStore -> ChatItemId -> CIStatus d -> m (ChatItem 'CTDirect d) +updateDirectChatItem st itemId itemStatus = + liftIOEither . withTransaction st $ \db -> do + ci <- getDirectChatItem_ db itemId + DB.execute db "UPDATE chat_items SET item_status = ? WHERE chat_item_id = ?" (itemStatus, itemId) + pure ci -toDirectChatItem :: TimeZone -> ChatItemRow -> 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 +getDirectChatItem_ :: forall d. MsgDirectionI d => DB.Connection -> ChatItemId -> IO (Either StoreError (ChatItem 'CTDirect d)) +getDirectChatItem_ db itemId = do + tz <- getCurrentTimeZone + join + <$> firstRow + (correctDir <=< toDirectChatItem tz) + (SEChatItemNotFound itemId) + ( DB.query + db + [sql| + SELECT + -- ChatItem + ci.chat_item_id, ci.item_ts, ci.item_content, ci.item_text, ci.item_status, ci.created_at + FROM chat_items ci + WHERE ci.chat_item_id = ? + |] + (Only itemId) + ) + where + correctDir :: CChatItem c -> Either StoreError (ChatItem c d) + correctDir (CChatItem _ ci) = first SEInternalError $ checkDirection ci + +type ChatItemRow = (Int64, ChatItemTs, ACIContent, Text, ACIStatus, UTCTime) + +type MaybeChatItemRow = (Maybe Int64, Maybe ChatItemTs, Maybe ACIContent, Maybe Text, Maybe ACIStatus, Maybe UTCTime) + +toDirectChatItem :: TimeZone -> ChatItemRow -> Either StoreError (CChatItem 'CTDirect) +toDirectChatItem tz (itemId, itemTs, itemContent, itemText, itemStatus, createdAt) = + case (itemContent, itemStatus) of + (ACIContent d@SMDSnd ciContent, ACIStatus d'@SMDSnd ciStatus) -> case testEquality d d' of + Just Refl -> Right $ CChatItem d (ChatItem CIDirectSnd (ciMeta ciStatus) ciContent) + _ -> badItem + (ACIContent d@SMDRcv ciContent, ACIStatus d'@SMDRcv ciStatus) -> case testEquality d d' of + Just Refl -> Right $ CChatItem d (ChatItem CIDirectRcv (ciMeta ciStatus) ciContent) + _ -> badItem + _ -> badItem + where + badItem = Left $ SEBadChatItem itemId + ciMeta :: CIStatus d -> CIMeta d + ciMeta status = mkCIMeta itemId itemText status tz itemTs createdAt toDirectChatItemList :: TimeZone -> MaybeChatItemRow -> [CChatItem 'CTDirect] -toDirectChatItemList tz (Just itemId, Just itemTs, Just itemContent, Just itemText, Just createdAt) = - [toDirectChatItem tz (itemId, itemTs, itemContent, itemText, createdAt)] +toDirectChatItemList tz (Just itemId, Just itemTs, Just itemContent, Just itemText, Just itemStatus, Just createdAt) = + either (const []) (: []) $ toDirectChatItem tz (itemId, itemTs, itemContent, itemText, itemStatus, createdAt) toDirectChatItemList _ _ = [] type GroupChatItemRow = ChatItemRow :. MaybeGroupMemberRow @@ -2394,17 +2458,24 @@ type GroupChatItemRow = ChatItemRow :. MaybeGroupMemberRow type MaybeGroupChatItemRow = MaybeChatItemRow :. MaybeGroupMemberRow toGroupChatItem :: TimeZone -> Int64 -> GroupChatItemRow -> Either StoreError (CChatItem 'CTGroup) -toGroupChatItem tz userContactId ((itemId, itemTs, itemContent, itemText, createdAt) :. memberRow_) = - let ciMeta = mkCIMeta itemId itemText tz itemTs createdAt - member_ = toMaybeGroupMember userContactId memberRow_ - in case (itemContent, member_) of - (ACIContent d@SMDSnd ciContent, Nothing) -> Right $ CChatItem d (ChatItem CIGroupSnd ciMeta ciContent) - (ACIContent d@SMDRcv ciContent, Just member) -> Right $ CChatItem d (ChatItem (CIGroupRcv member) ciMeta ciContent) - _ -> Left $ SEBadChatItem itemId +toGroupChatItem tz userContactId ((itemId, itemTs, itemContent, itemText, itemStatus, createdAt) :. memberRow_) = do + let member_ = toMaybeGroupMember userContactId memberRow_ + case (itemContent, itemStatus, member_) of + (ACIContent d@SMDSnd ciContent, ACIStatus d'@SMDSnd ciStatus, Nothing) -> case testEquality d d' of + Just Refl -> Right $ CChatItem d (ChatItem CIGroupSnd (ciMeta ciStatus) ciContent) + _ -> badItem + (ACIContent d@SMDRcv ciContent, ACIStatus d'@SMDRcv ciStatus, Just member) -> case testEquality d d' of + Just Refl -> Right $ CChatItem d (ChatItem (CIGroupRcv member) (ciMeta ciStatus) ciContent) + _ -> badItem + _ -> badItem + where + badItem = Left $ SEBadChatItem itemId + ciMeta :: CIStatus d -> CIMeta d + ciMeta status = mkCIMeta itemId itemText status tz itemTs createdAt toGroupChatItemList :: TimeZone -> Int64 -> MaybeGroupChatItemRow -> [CChatItem 'CTGroup] -toGroupChatItemList tz userContactId ((Just itemId, Just itemTs, Just itemContent, Just itemText, Just createdAt) :. memberRow_) = - either (const []) (: []) $ toGroupChatItem tz userContactId ((itemId, itemTs, itemContent, itemText, createdAt) :. memberRow_) +toGroupChatItemList tz userContactId ((Just itemId, Just itemTs, Just itemContent, Just itemText, Just itemStatus, Just createdAt) :. memberRow_) = + either (const []) (: []) $ toGroupChatItem tz userContactId ((itemId, itemTs, itemContent, itemText, itemStatus, createdAt) :. memberRow_) toGroupChatItemList _ _ _ = [] -- | Saves unique local display name based on passed displayName, suffixed with _N if required. @@ -2459,7 +2530,7 @@ createWithRandomBytes size gVar create = tryCreate 3 Right x -> pure $ Right x Left e | DB.sqlError e == DB.ErrorConstraint -> tryCreate (n - 1) - | otherwise -> pure . Left . SEInternal $ show e + | otherwise -> pure . Left . SEInternalError $ show e randomBytes :: TVar ChaChaDRG -> Int -> IO ByteString randomBytes gVar n = B64.encode <$> (atomically . stateTVar gVar $ randomBytesGenerate n) @@ -2488,9 +2559,10 @@ data StoreError | SEConnectionNotFound {agentConnId :: AgentConnId} | SEIntroNotFound | SEUniqueID - | SEInternal {message :: String} + | SEInternalError {message :: String} | SENoMsgDelivery {connId :: Int64, agentMsgId :: AgentMsgId} - | SEBadChatItem {itemId :: Int64} + | SEBadChatItem {itemId :: ChatItemId} + | SEChatItemNotFound {itemId :: ChatItemId} deriving (Show, Exception, Generic) instance ToJSON StoreError where diff --git a/src/Simplex/Chat/Terminal.hs b/src/Simplex/Chat/Terminal.hs index dc08ff65b..d8e14b342 100644 --- a/src/Simplex/Chat/Terminal.hs +++ b/src/Simplex/Chat/Terminal.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} module Simplex.Chat.Terminal where @@ -18,7 +19,7 @@ import Simplex.Messaging.Util (raceAny_) import UnliftIO (async, waitEither_) simplexChat :: WithTerminal t => ChatConfig -> ChatOpts -> t -> IO () -simplexChat cfg opts t +simplexChat cfg@ChatConfig {dbPoolSize, yesToMigrations} opts t | logging opts = do setLogLevel LogInfo -- LogError withGlobalLogging logCfg initRun @@ -27,7 +28,7 @@ simplexChat cfg opts t initRun = do sendNotification' <- initializeNotifications let f = chatStoreFile $ dbFilePrefix opts - st <- createStore f $ dbPoolSize cfg + st <- createStore f dbPoolSize yesToMigrations u <- getCreateActiveUser st ct <- newChatTerminal t cc <- newChatController st (Just u) cfg opts sendNotification' diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 48b30625f..00141c345 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -39,6 +39,7 @@ responseToView cmd = \case CRApiChats chats -> r [sShow chats] CRApiChat chat -> r [sShow chat] CRNewChatItem (AChatItem _ _ chat item) -> viewChatItem chat item + CRChatItemUpdated _ -> [] CRMsgIntegrityError mErr -> viewMsgIntegrityError mErr CRCmdAccepted _ -> r [] CRChatHelp section -> case section of @@ -308,10 +309,10 @@ viewContactUpdated where fullNameUpdate = if T.null fullName' || fullName' == n' then " removed full name" else " updated full name: " <> plain fullName' -viewReceivedMessage :: StyledString -> CIMeta -> MsgContent -> [StyledString] +viewReceivedMessage :: StyledString -> CIMeta d -> MsgContent -> [StyledString] viewReceivedMessage from meta mc = receivedWithTime_ from meta (ttyMsgContent mc) -receivedWithTime_ :: StyledString -> CIMeta -> [StyledString] -> [StyledString] +receivedWithTime_ :: StyledString -> CIMeta d -> [StyledString] -> [StyledString] receivedWithTime_ from CIMeta {localItemTs, createdAt} styledMsg = do prependFirst (formattedTime <> " " <> from) styledMsg -- ++ showIntegrity mOk where @@ -326,13 +327,13 @@ receivedWithTime_ from CIMeta {localItemTs, createdAt} styledMsg = do else "%H:%M" in styleTime $ formatTime defaultTimeLocale format localTime -viewSentMessage :: StyledString -> MsgContent -> CIMeta -> [StyledString] +viewSentMessage :: StyledString -> MsgContent -> CIMeta d -> [StyledString] viewSentMessage to = sentWithTime_ . prependFirst to . ttyMsgContent -viewSentFileInvitation :: StyledString -> FileTransferId -> FilePath -> CIMeta -> [StyledString] +viewSentFileInvitation :: StyledString -> FileTransferId -> FilePath -> CIMeta d -> [StyledString] viewSentFileInvitation to fId fPath = sentWithTime_ $ ttySentFile to fId fPath -sentWithTime_ :: [StyledString] -> CIMeta -> [StyledString] +sentWithTime_ :: [StyledString] -> CIMeta d -> [StyledString] sentWithTime_ styledMsg CIMeta {localItemTs} = prependFirst (ttyMsgTime localItemTs <> " ") styledMsg @@ -371,7 +372,7 @@ sendingFile_ status ft@SndFileTransfer {recipientDisplayName = c} = sndFile :: SndFileTransfer -> StyledString sndFile SndFileTransfer {fileId, fileName} = fileTransferStr fileId fileName -viewReceivedFileInvitation :: StyledString -> CIMeta -> RcvFileTransfer -> [StyledString] +viewReceivedFileInvitation :: StyledString -> CIMeta d -> RcvFileTransfer -> [StyledString] viewReceivedFileInvitation from meta ft = receivedWithTime_ from meta (receivedFileInvitation_ ft) receivedFileInvitation_ :: RcvFileTransfer -> [StyledString] diff --git a/stack.yaml b/stack.yaml index 9c282b18e..40df8cd5b 100644 --- a/stack.yaml +++ b/stack.yaml @@ -48,7 +48,7 @@ extra-deps: # - simplexmq-1.0.0@sha256:34b2004728ae396e3ae449cd090ba7410781e2b3cefc59259915f4ca5daa9ea8,8561 # - ../simplexmq - github: simplex-chat/simplexmq - commit: 137ff7043d49feb3b350f56783c9b64a62bc636a + commit: c9994c3a2ca945b9b67e250163cf8d560d2ed554 # - terminal-0.2.0.0@sha256:de6770ecaae3197c66ac1f0db5a80cf5a5b1d3b64a66a05b50f442de5ad39570,2977 - github: simplex-chat/aeson commit: 3eb66f9a68f103b5f1489382aad89f5712a64db7 diff --git a/tests/ChatClient.hs b/tests/ChatClient.hs index 4099568c7..fa0556560 100644 --- a/tests/ChatClient.hs +++ b/tests/ChatClient.hs @@ -75,7 +75,7 @@ cfg = virtualSimplexChat :: FilePath -> Profile -> IO TestCC virtualSimplexChat dbFilePrefix profile = do - st <- createStore (dbFilePrefix <> "_chat.db") 1 + st <- createStore (dbFilePrefix <> "_chat.db") 1 False Right user <- runExceptT $ createUser st profile True t <- withVirtualTerminal termSettings pure ct <- newChatTerminal t diff --git a/tests/MobileTests.hs b/tests/MobileTests.hs index 96d5d8c40..f48cf7131 100644 --- a/tests/MobileTests.hs +++ b/tests/MobileTests.hs @@ -35,7 +35,7 @@ testChatApiNoUser = withTmpFiles $ do testChatApi :: IO () testChatApi = withTmpFiles $ do let f = chatStoreFile testDBPrefix - st <- createStore f 1 + st <- createStore f 1 True Right _ <- runExceptT $ createUser st aliceProfile True cc <- chatInit testDBPrefix chatSendCmd cc "/u" `shouldReturn` activeUser