mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-05-18 03:16:42 +00:00
store messages (#166)
Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
This commit is contained in:
Efim Poberezkin
@@ -103,6 +103,30 @@ data ChatMessage = ChatMessage
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
toChatEventType :: ChatMsgEvent -> Text
|
||||
toChatEventType = \case
|
||||
XMsgNew _ -> "x.msg.new"
|
||||
XFile _ -> "x.file"
|
||||
XFileAcpt _ -> "x.file.acpt"
|
||||
XInfo _ -> "x.info"
|
||||
XContact _ _ -> "x.con"
|
||||
XGrpInv _ -> "x.grp.inv"
|
||||
XGrpAcpt _ -> "x.grp.acpt"
|
||||
XGrpMemNew _ -> "x.grp.mem.new"
|
||||
XGrpMemIntro _ -> "x.grp.mem.intro"
|
||||
XGrpMemInv _ _ -> "x.grp.mem.inv"
|
||||
XGrpMemFwd _ _ -> "x.grp.mem.fwd"
|
||||
XGrpMemInfo _ _ -> "x.grp.mem.info"
|
||||
XGrpMemCon _ -> "x.grp.mem.con"
|
||||
XGrpMemConAll _ -> "x.grp.mem.con.all"
|
||||
XGrpMemDel _ -> "x.grp.mem.del"
|
||||
XGrpLeave -> "x.grp.leave"
|
||||
XGrpDel -> "x.grp.del"
|
||||
XInfoProbe _ -> "x.info.probe"
|
||||
XInfoProbeCheck _ -> "x.info.probe.check"
|
||||
XInfoProbeOk _ -> "x.info.probe.ok"
|
||||
XOk -> "x.ok"
|
||||
|
||||
toChatMessage :: RawChatMessage -> Either String ChatMessage
|
||||
toChatMessage RawChatMessage {chatMsgId, chatMsgEvent, chatMsgParams, chatMsgBody} = do
|
||||
(chatDAG, body) <- getDAG <$> mapM toMsgBodyContent chatMsgBody
|
||||
@@ -161,9 +185,9 @@ toChatMessage RawChatMessage {chatMsgId, chatMsgEvent, chatMsgParams, chatMsgBod
|
||||
("x.info.probe", [probe]) -> do
|
||||
chatMsg . XInfoProbe =<< B64.decode probe
|
||||
("x.info.probe.check", [probeHash]) -> do
|
||||
chatMsg =<< (XInfoProbeCheck <$> B64.decode probeHash)
|
||||
chatMsg . XInfoProbeCheck =<< B64.decode probeHash
|
||||
("x.info.probe.ok", [probe]) -> do
|
||||
chatMsg =<< (XInfoProbeOk <$> B64.decode probe)
|
||||
chatMsg . XInfoProbeOk =<< B64.decode probe
|
||||
("x.ok", []) ->
|
||||
chatMsg XOk
|
||||
_ -> Left $ "bad syntax or unsupported event " <> B.unpack chatMsgEvent
|
||||
@@ -216,17 +240,17 @@ rawChatMessage :: ChatMessage -> RawChatMessage
|
||||
rawChatMessage ChatMessage {chatMsgId, chatMsgEvent, chatDAG} =
|
||||
case chatMsgEvent of
|
||||
XMsgNew MsgContent {messageType = t, files, content} ->
|
||||
rawMsg "x.msg.new" (rawMsgType t : toRawFiles files) content
|
||||
rawMsg (rawMsgType t : toRawFiles files) content
|
||||
XFile FileInvitation {fileName, fileSize, fileConnReq} ->
|
||||
rawMsg "x.file" [encodeUtf8 $ T.pack fileName, bshow fileSize, serializeConnReq' fileConnReq] []
|
||||
rawMsg [encodeUtf8 $ T.pack fileName, bshow fileSize, serializeConnReq' fileConnReq] []
|
||||
XFileAcpt fileName ->
|
||||
rawMsg "x.file.acpt" [encodeUtf8 $ T.pack fileName] []
|
||||
rawMsg [encodeUtf8 $ T.pack fileName] []
|
||||
XInfo profile ->
|
||||
rawMsg "x.info" [] [jsonBody profile]
|
||||
rawMsg [] [jsonBody profile]
|
||||
XContact profile Nothing ->
|
||||
rawMsg "x.con" [] [jsonBody profile]
|
||||
rawMsg [] [jsonBody profile]
|
||||
XContact profile (Just MsgContent {messageType = t, files, content}) ->
|
||||
rawMsg "x.con" (rawMsgType t : toRawFiles files) (jsonBody profile : content)
|
||||
rawMsg (rawMsgType t : toRawFiles files) (jsonBody profile : content)
|
||||
XGrpInv (GroupInvitation (fromMemId, fromRole) (memId, role) cReq groupProfile) ->
|
||||
let params =
|
||||
[ B64.encode fromMemId,
|
||||
@@ -235,17 +259,17 @@ rawChatMessage ChatMessage {chatMsgId, chatMsgEvent, chatDAG} =
|
||||
serializeMemberRole role,
|
||||
serializeConnReq' cReq
|
||||
]
|
||||
in rawMsg "x.grp.inv" params [jsonBody groupProfile]
|
||||
in rawMsg params [jsonBody groupProfile]
|
||||
XGrpAcpt memId ->
|
||||
rawMsg "x.grp.acpt" [B64.encode memId] []
|
||||
rawMsg [B64.encode memId] []
|
||||
XGrpMemNew (MemberInfo memId role profile) ->
|
||||
let params = [B64.encode memId, serializeMemberRole role]
|
||||
in rawMsg "x.grp.mem.new" params [jsonBody profile]
|
||||
in rawMsg params [jsonBody profile]
|
||||
XGrpMemIntro (MemberInfo memId role profile) ->
|
||||
rawMsg "x.grp.mem.intro" [B64.encode memId, serializeMemberRole role] [jsonBody profile]
|
||||
rawMsg [B64.encode memId, serializeMemberRole role] [jsonBody profile]
|
||||
XGrpMemInv memId IntroInvitation {groupConnReq, directConnReq} ->
|
||||
let params = [B64.encode memId, serializeConnReq' groupConnReq, serializeConnReq' directConnReq]
|
||||
in rawMsg "x.grp.mem.inv" params []
|
||||
in rawMsg params []
|
||||
XGrpMemFwd (MemberInfo memId role profile) IntroInvitation {groupConnReq, directConnReq} ->
|
||||
let params =
|
||||
[ B64.encode memId,
|
||||
@@ -253,30 +277,31 @@ rawChatMessage ChatMessage {chatMsgId, chatMsgEvent, chatDAG} =
|
||||
serializeConnReq' groupConnReq,
|
||||
serializeConnReq' directConnReq
|
||||
]
|
||||
in rawMsg "x.grp.mem.fwd" params [jsonBody profile]
|
||||
in rawMsg params [jsonBody profile]
|
||||
XGrpMemInfo memId profile ->
|
||||
rawMsg "x.grp.mem.info" [B64.encode memId] [jsonBody profile]
|
||||
rawMsg [B64.encode memId] [jsonBody profile]
|
||||
XGrpMemCon memId ->
|
||||
rawMsg "x.grp.mem.con" [B64.encode memId] []
|
||||
rawMsg [B64.encode memId] []
|
||||
XGrpMemConAll memId ->
|
||||
rawMsg "x.grp.mem.con.all" [B64.encode memId] []
|
||||
rawMsg [B64.encode memId] []
|
||||
XGrpMemDel memId ->
|
||||
rawMsg "x.grp.mem.del" [B64.encode memId] []
|
||||
rawMsg [B64.encode memId] []
|
||||
XGrpLeave ->
|
||||
rawMsg "x.grp.leave" [] []
|
||||
rawMsg [] []
|
||||
XGrpDel ->
|
||||
rawMsg "x.grp.del" [] []
|
||||
rawMsg [] []
|
||||
XInfoProbe probe ->
|
||||
rawMsg "x.info.probe" [B64.encode probe] []
|
||||
rawMsg [B64.encode probe] []
|
||||
XInfoProbeCheck probeHash ->
|
||||
rawMsg "x.info.probe.check" [B64.encode probeHash] []
|
||||
rawMsg [B64.encode probeHash] []
|
||||
XInfoProbeOk probe ->
|
||||
rawMsg "x.info.probe.ok" [B64.encode probe] []
|
||||
rawMsg [B64.encode probe] []
|
||||
XOk ->
|
||||
rawMsg "x.ok" [] []
|
||||
rawMsg [] []
|
||||
where
|
||||
rawMsg :: ByteString -> [ByteString] -> [MsgContentBody] -> RawChatMessage
|
||||
rawMsg event chatMsgParams body =
|
||||
rawMsg :: [ByteString] -> [MsgContentBody] -> RawChatMessage
|
||||
rawMsg chatMsgParams body = do
|
||||
let event = encodeUtf8 $ toChatEventType chatMsgEvent
|
||||
RawChatMessage {chatMsgId, chatMsgEvent = event, chatMsgParams, chatMsgBody = rawWithDAG body}
|
||||
rawContentInfo :: (ContentType, Int) -> (RawContentType, Int)
|
||||
rawContentInfo (t, size) = (rawContentType t, size)
|
||||
|
||||
+102
-2
@@ -90,6 +90,11 @@ module Simplex.Chat.Store
|
||||
getFileTransfer,
|
||||
getFileTransferProgress,
|
||||
getOnboarding,
|
||||
createNewMessage,
|
||||
createSndMsgDelivery,
|
||||
createNewMessageAndRcvMsgDelivery,
|
||||
createSndMsgDeliveryEvent,
|
||||
createRcvMsgDeliveryEvent,
|
||||
)
|
||||
where
|
||||
|
||||
@@ -118,7 +123,7 @@ import qualified Database.SQLite.Simple as DB
|
||||
import Database.SQLite.Simple.QQ (sql)
|
||||
import Simplex.Chat.Protocol
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Messaging.Agent.Protocol (AParty (..), AgentMsgId, ConnId, InvitationId)
|
||||
import Simplex.Messaging.Agent.Protocol (AParty (..), AgentMsgId, ConnId, InvitationId, MsgMeta (..))
|
||||
import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore (..), createSQLiteStore, withTransaction)
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..))
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
@@ -742,7 +747,6 @@ mergeContactRecords st userId Contact {contactId = toContactId} Contact {contact
|
||||
DB.execute db "UPDATE connections SET contact_id = ? WHERE contact_id = ? AND user_id = ?" (toContactId, fromContactId, userId)
|
||||
DB.execute db "UPDATE connections SET via_contact = ? WHERE via_contact = ? AND user_id = ?" (toContactId, fromContactId, userId)
|
||||
DB.execute db "UPDATE group_members SET invited_by = ? WHERE invited_by = ? AND user_id = ?" (toContactId, fromContactId, userId)
|
||||
DB.execute db "UPDATE messages SET contact_id = ? WHERE contact_id = ?" (toContactId, fromContactId)
|
||||
DB.executeNamed
|
||||
db
|
||||
[sql|
|
||||
@@ -1613,6 +1617,101 @@ getOnboarding st userId =
|
||||
headOrZero [] = 0
|
||||
headOrZero (n : _) = fromOnly n
|
||||
|
||||
createNewMessage :: MonadUnliftIO m => SQLiteStore -> NewMessage -> m MessageId
|
||||
createNewMessage st newMsg =
|
||||
liftIO . withTransaction st $ \db ->
|
||||
createNewMessage_ db newMsg
|
||||
|
||||
createSndMsgDelivery :: MonadUnliftIO m => SQLiteStore -> SndMsgDelivery -> MessageId -> m ()
|
||||
createSndMsgDelivery st sndMsgDelivery messageId =
|
||||
liftIO . withTransaction st $ \db -> do
|
||||
msgDeliveryId <- createSndMsgDelivery_ db sndMsgDelivery messageId
|
||||
createMsgDeliveryEvent_ db msgDeliveryId MDSSndAgent
|
||||
|
||||
createNewMessageAndRcvMsgDelivery :: MonadUnliftIO m => SQLiteStore -> NewMessage -> RcvMsgDelivery -> m ()
|
||||
createNewMessageAndRcvMsgDelivery st newMsg rcvMsgDelivery =
|
||||
liftIO . withTransaction st $ \db -> do
|
||||
messageId <- createNewMessage_ db newMsg
|
||||
msgDeliveryId <- createRcvMsgDelivery_ db rcvMsgDelivery messageId
|
||||
createMsgDeliveryEvent_ db msgDeliveryId MDSRcvAgent
|
||||
|
||||
createSndMsgDeliveryEvent :: StoreMonad m => SQLiteStore -> Int64 -> AgentMsgId -> MsgDeliveryStatus 'MDSnd -> m ()
|
||||
createSndMsgDeliveryEvent st connId agentMsgId sndMsgDeliveryStatus =
|
||||
liftIOEither . withTransaction st $ \db -> runExceptT $ do
|
||||
msgDeliveryId <- ExceptT $ getMsgDeliveryId_ db connId agentMsgId
|
||||
liftIO $ createMsgDeliveryEvent_ db msgDeliveryId sndMsgDeliveryStatus
|
||||
|
||||
createRcvMsgDeliveryEvent :: StoreMonad m => SQLiteStore -> Int64 -> AgentMsgId -> MsgDeliveryStatus 'MDRcv -> m ()
|
||||
createRcvMsgDeliveryEvent st connId agentMsgId rcvMsgDeliveryStatus =
|
||||
liftIOEither . withTransaction st $ \db -> runExceptT $ do
|
||||
msgDeliveryId <- ExceptT $ getMsgDeliveryId_ db connId agentMsgId
|
||||
liftIO $ createMsgDeliveryEvent_ db msgDeliveryId rcvMsgDeliveryStatus
|
||||
|
||||
createNewMessage_ :: DB.Connection -> NewMessage -> IO MessageId
|
||||
createNewMessage_ db NewMessage {direction, chatMsgEventType, msgBody} = do
|
||||
createdAt <- getCurrentTime
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
INSERT INTO messages
|
||||
(msg_sent, chat_msg_event, msg_body, created_at) VALUES (?,?,?,?);
|
||||
|]
|
||||
(direction, chatMsgEventType, msgBody, createdAt)
|
||||
insertedRowId db
|
||||
|
||||
createSndMsgDelivery_ :: DB.Connection -> SndMsgDelivery -> MessageId -> IO Int64
|
||||
createSndMsgDelivery_ db SndMsgDelivery {connId, agentMsgId} messageId = do
|
||||
chatTs <- getCurrentTime
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
INSERT INTO msg_deliveries
|
||||
(message_id, connection_id, agent_msg_id, agent_msg_meta, chat_ts)
|
||||
VALUES (?,?,?,NULL,?);
|
||||
|]
|
||||
(messageId, connId, agentMsgId, chatTs)
|
||||
insertedRowId db
|
||||
|
||||
createRcvMsgDelivery_ :: DB.Connection -> RcvMsgDelivery -> MessageId -> IO Int64
|
||||
createRcvMsgDelivery_ db RcvMsgDelivery {connId, agentMsgId, agentMsgMeta} messageId = do
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
INSERT INTO msg_deliveries
|
||||
(message_id, connection_id, agent_msg_id, agent_msg_meta, chat_ts)
|
||||
VALUES (?,?,?,?,?);
|
||||
|]
|
||||
(messageId, connId, agentMsgId, msgMetaJson agentMsgMeta, snd $ broker agentMsgMeta)
|
||||
insertedRowId db
|
||||
|
||||
createMsgDeliveryEvent_ :: DB.Connection -> Int64 -> MsgDeliveryStatus d -> IO ()
|
||||
createMsgDeliveryEvent_ db msgDeliveryId msgDeliveryStatus = do
|
||||
createdAt <- getCurrentTime
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
INSERT INTO msg_delivery_events
|
||||
(msg_delivery_id, delivery_status, created_at) VALUES (?,?,?);
|
||||
|]
|
||||
(msgDeliveryId, msgDeliveryStatus, createdAt)
|
||||
|
||||
getMsgDeliveryId_ :: DB.Connection -> Int64 -> AgentMsgId -> IO (Either StoreError Int64)
|
||||
getMsgDeliveryId_ db connId agentMsgId =
|
||||
toMsgDeliveryId
|
||||
<$> DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT msg_delivery_id
|
||||
FROM msg_deliveries m
|
||||
WHERE m.connection_id = ? AND m.agent_msg_id == ?
|
||||
LIMIT 1;
|
||||
|]
|
||||
(connId, agentMsgId)
|
||||
where
|
||||
toMsgDeliveryId :: [Only Int64] -> Either StoreError Int64
|
||||
toMsgDeliveryId [Only msgDeliveryId] = Right msgDeliveryId
|
||||
toMsgDeliveryId _ = Left $ SENoMsgDelivery connId agentMsgId
|
||||
|
||||
-- | Saves unique local display name based on passed displayName, suffixed with _N if required.
|
||||
-- This function should be called inside transaction.
|
||||
withLocalDisplayName :: forall a. DB.Connection -> UserId -> Text -> (Text -> IO a) -> IO (Either StoreError a)
|
||||
@@ -1689,4 +1788,5 @@ data StoreError
|
||||
| SEIntroNotFound
|
||||
| SEUniqueID
|
||||
| SEInternal ByteString
|
||||
| SENoMsgDelivery Int64 AgentMsgId
|
||||
deriving (Show, Exception)
|
||||
|
||||
+138
-1
@@ -1,19 +1,27 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
module Simplex.Chat.Types where
|
||||
|
||||
import Data.Aeson (FromJSON, ToJSON)
|
||||
import qualified Data.Aeson as J
|
||||
import qualified Data.ByteString.Base64 as B64
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import qualified Data.ByteString.Lazy.Char8 as LB
|
||||
import Data.Int (Int64)
|
||||
import Data.Text (Text)
|
||||
import Data.Text.Encoding (decodeLatin1)
|
||||
import Data.Time.Clock (UTCTime)
|
||||
import Data.Type.Equality
|
||||
import Data.Typeable (Typeable)
|
||||
import Database.SQLite.Simple (ResultError (..), SQLData (..))
|
||||
import Database.SQLite.Simple.FromField (FieldParser, FromField (..), returnError)
|
||||
@@ -21,8 +29,9 @@ import Database.SQLite.Simple.Internal (Field (..))
|
||||
import Database.SQLite.Simple.Ok (Ok (Ok))
|
||||
import Database.SQLite.Simple.ToField (ToField (..))
|
||||
import GHC.Generics
|
||||
import Simplex.Messaging.Agent.Protocol (ConnId, ConnectionMode (..), ConnectionRequest, InvitationId)
|
||||
import Simplex.Messaging.Agent.Protocol (AgentMsgId, ConnId, ConnectionMode (..), ConnectionRequest, InvitationId, MsgMeta (..), serializeMsgIntegrity)
|
||||
import Simplex.Messaging.Agent.Store.SQLite (fromTextField_)
|
||||
import Simplex.Messaging.Protocol (MsgBody)
|
||||
|
||||
class IsContact a where
|
||||
contactId' :: a -> Int64
|
||||
@@ -58,6 +67,9 @@ data Contact = Contact
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
contactConn :: Contact -> Connection
|
||||
contactConn = activeConn
|
||||
|
||||
contactConnId :: Contact -> ConnId
|
||||
contactConnId Contact {activeConn = Connection {agentConnId}} = agentConnId
|
||||
|
||||
@@ -153,6 +165,9 @@ data GroupMember = GroupMember
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
memberConn :: GroupMember -> Maybe Connection
|
||||
memberConn = activeConn
|
||||
|
||||
memberConnId :: GroupMember -> Maybe ConnId
|
||||
memberConnId GroupMember {activeConn} = case activeConn of
|
||||
Just Connection {agentConnId} -> Just agentConnId
|
||||
@@ -526,3 +541,125 @@ data Onboarding = Onboarding
|
||||
filesSentCount :: Int,
|
||||
addressCount :: Int
|
||||
}
|
||||
|
||||
data NewMessage = NewMessage
|
||||
{ direction :: MsgDirection,
|
||||
chatMsgEventType :: Text,
|
||||
msgBody :: MsgBody
|
||||
}
|
||||
|
||||
type MessageId = Int64
|
||||
|
||||
data MsgDirection = MDRcv | MDSnd
|
||||
|
||||
data SMsgDirection (d :: MsgDirection) where
|
||||
SMDRcv :: SMsgDirection 'MDRcv
|
||||
SMDSnd :: SMsgDirection 'MDSnd
|
||||
|
||||
instance TestEquality SMsgDirection where
|
||||
testEquality SMDRcv SMDRcv = Just Refl
|
||||
testEquality SMDSnd SMDSnd = Just Refl
|
||||
testEquality _ _ = Nothing
|
||||
|
||||
class MsgDirectionI (d :: MsgDirection) where
|
||||
msgDirection :: SMsgDirection d
|
||||
|
||||
instance MsgDirectionI 'MDRcv where msgDirection = SMDRcv
|
||||
|
||||
instance MsgDirectionI 'MDSnd where msgDirection = SMDSnd
|
||||
|
||||
instance ToField MsgDirection where toField = toField . msgDirectionInt
|
||||
|
||||
msgDirectionInt :: MsgDirection -> Int
|
||||
msgDirectionInt = \case
|
||||
MDRcv -> 0
|
||||
MDSnd -> 1
|
||||
|
||||
msgDirectionIntP :: Int -> Maybe MsgDirection
|
||||
msgDirectionIntP = \case
|
||||
0 -> Just MDRcv
|
||||
1 -> Just MDSnd
|
||||
_ -> Nothing
|
||||
|
||||
data SndMsgDelivery = SndMsgDelivery
|
||||
{ connId :: Int64,
|
||||
agentMsgId :: AgentMsgId
|
||||
}
|
||||
|
||||
data RcvMsgDelivery = RcvMsgDelivery
|
||||
{ connId :: Int64,
|
||||
agentMsgId :: AgentMsgId,
|
||||
agentMsgMeta :: MsgMeta
|
||||
}
|
||||
|
||||
data MsgMetaJ = MsgMetaJ
|
||||
{ integrity :: Text,
|
||||
rcvId :: Int64,
|
||||
rcvTs :: UTCTime,
|
||||
serverId :: Text,
|
||||
serverTs :: UTCTime,
|
||||
sndId :: Int64
|
||||
}
|
||||
deriving (Generic, Eq, Show)
|
||||
|
||||
instance ToJSON MsgMetaJ where toEncoding = J.genericToEncoding J.defaultOptions
|
||||
|
||||
instance FromJSON MsgMetaJ
|
||||
|
||||
msgMetaToJson :: MsgMeta -> MsgMetaJ
|
||||
msgMetaToJson MsgMeta {integrity, recipient = (rcvId, rcvTs), broker = (serverId, serverTs), sender = (sndId, _)} =
|
||||
MsgMetaJ
|
||||
{ integrity = (decodeLatin1 . serializeMsgIntegrity) integrity,
|
||||
rcvId,
|
||||
rcvTs,
|
||||
serverId = (decodeLatin1 . B64.encode) serverId,
|
||||
serverTs,
|
||||
sndId
|
||||
}
|
||||
|
||||
msgMetaJson :: MsgMeta -> Text
|
||||
msgMetaJson = decodeLatin1 . LB.toStrict . J.encode . msgMetaToJson
|
||||
|
||||
data MsgDeliveryStatus (d :: MsgDirection) where
|
||||
MDSRcvAgent :: MsgDeliveryStatus 'MDRcv
|
||||
MDSRcvAcknowledged :: MsgDeliveryStatus 'MDRcv
|
||||
MDSSndPending :: MsgDeliveryStatus 'MDSnd
|
||||
MDSSndAgent :: MsgDeliveryStatus 'MDSnd
|
||||
MDSSndSent :: MsgDeliveryStatus 'MDSnd
|
||||
MDSSndReceived :: MsgDeliveryStatus 'MDSnd
|
||||
MDSSndRead :: MsgDeliveryStatus 'MDSnd
|
||||
|
||||
data AMsgDeliveryStatus = forall d. AMDS (SMsgDirection d) (MsgDeliveryStatus d)
|
||||
|
||||
instance (Typeable d, MsgDirectionI d) => FromField (MsgDeliveryStatus d) where
|
||||
fromField = fromTextField_ msgDeliveryStatusT'
|
||||
|
||||
instance ToField (MsgDeliveryStatus d) where toField = toField . serializeMsgDeliveryStatus
|
||||
|
||||
serializeMsgDeliveryStatus :: MsgDeliveryStatus d -> Text
|
||||
serializeMsgDeliveryStatus = \case
|
||||
MDSRcvAgent -> "rcv_agent"
|
||||
MDSRcvAcknowledged -> "rcv_acknowledged"
|
||||
MDSSndPending -> "snd_pending"
|
||||
MDSSndAgent -> "snd_agent"
|
||||
MDSSndSent -> "snd_sent"
|
||||
MDSSndReceived -> "snd_received"
|
||||
MDSSndRead -> "snd_read"
|
||||
|
||||
msgDeliveryStatusT :: Text -> Maybe AMsgDeliveryStatus
|
||||
msgDeliveryStatusT = \case
|
||||
"rcv_agent" -> Just $ AMDS SMDRcv MDSRcvAgent
|
||||
"rcv_acknowledged" -> Just $ AMDS SMDRcv MDSRcvAcknowledged
|
||||
"snd_pending" -> Just $ AMDS SMDSnd MDSSndPending
|
||||
"snd_agent" -> Just $ AMDS SMDSnd MDSSndAgent
|
||||
"snd_sent" -> Just $ AMDS SMDSnd MDSSndSent
|
||||
"snd_received" -> Just $ AMDS SMDSnd MDSSndReceived
|
||||
"snd_read" -> Just $ AMDS SMDSnd MDSSndRead
|
||||
_ -> Nothing
|
||||
|
||||
msgDeliveryStatusT' :: forall d. MsgDirectionI d => Text -> Maybe (MsgDeliveryStatus d)
|
||||
msgDeliveryStatusT' s =
|
||||
msgDeliveryStatusT s >>= \(AMDS d st) ->
|
||||
case testEquality d (msgDirection @d) of
|
||||
Just Refl -> Just st
|
||||
_ -> Nothing
|
||||
|
||||
Reference in New Issue
Block a user