chat item status, CRChatItemUpdated api response (#269)
This commit is contained in:
Efim Poberezkin
GitHub
parent
eeea33c7cb
commit
f5507436f3
@ -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
|
||||
|
||||
@ -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";
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
}
|
||||
|
||||
|
||||
@ -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}
|
||||
|
||||
@ -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"
|
||||
|
||||
20
src/Simplex/Chat/Migrations/M20220205_chat_item_status.hs
Normal file
20
src/Simplex/Chat/Migrations/M20220205_chat_item_status.hs
Normal file
@ -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;
|
||||
|]
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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'
|
||||
|
||||
@ -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]
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user