dandri/simplexmq
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplexmq.git synced 2026-03-30 16:26:02 +00:00
Code Issues Packages Projects Releases Wiki Activity

agent: Transmission type

Browse Source
This commit is contained in:
Evgeny Poberezkin
2020-12-28 20:42:38 +00:00
parent c47f583574
commit cf38b4dddf
5 changed files with 135 additions and 35 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
src/Simplex/Messaging/Agent.hs
View File

@@ -36,7 +36,7 @@ runClient c = race_ (respond c) (process c)
receive :: MonadUnliftIO m => Handle -> AgentClient -> m ()
receive h AgentClient {rcvQ, sndQ} = forever $ do
aCmdGet SUser h >>= \case
aCmdGet SClient h >>= \case
Right cmd -> atomically $ writeTBQueue rcvQ cmd
Left e -> atomically $ writeTBQueue sndQ $ ERR e

2
src/Simplex/Messaging/Agent/Env/SQLite.hs
View File

@@ -31,7 +31,7 @@ data Env = Env
}
data AgentClient = AgentClient
{ rcvQ :: TBQueue (ACommand User),
{ rcvQ :: TBQueue (ACommand Client),
sndQ :: TBQueue (ACommand Agent),
respQ :: TBQueue (),
servers :: Map (HostName, ServiceName) ServerClient

6
src/Simplex/Messaging/Agent/Store.hs
View File

@@ -38,13 +38,13 @@ data SendQueue = SendQueue
data ConnType = CSend | CReceive | CDuplex
data Connection (d :: ConnType) where
ReceiveConnection :: ConnAlias -> ReceiveQueue -> Connection CSend
SendConnection :: ConnAlias -> SendQueue -> Connection CReceive
ReceiveConnection :: ConnAlias -> ReceiveQueue -> Connection CReceive
SendConnection :: ConnAlias -> SendQueue -> Connection CSend
DuplexConnection :: ConnAlias -> ReceiveQueue -> SendQueue -> Connection CDuplex
data SConnType :: ConnType -> Type where
SCSend :: SConnType CSend
SCReceive :: SConnType CReceive
SCSend :: SConnType CSend
SCDuplex :: SConnType CDuplex
deriving instance Show (SConnType d)

8
src/Simplex/Messaging/Agent/Store/SQLite.hs
View File

@@ -1 +1,9 @@
module Simplex.Messaging.Agent.Store.SQLite where
import qualified Database.SQLite.Simple as DB
-- instance MonadUnliftIO m => MonadQueueStore DB.Connection m where
-- createRcvConn :: DB.Connection -> Maybe ConnAlias -> ReceiveQueue -> m (Either StoreError (Connection CReceive))
-- createRcvConn conn connAlias q = do
-- id <- query conn "INSERT ..."
-- query conn "INSERT ..."

152
src/Simplex/Messaging/Agent/Transmission.hs
View File

@@ -1,5 +1,6 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
@@ -14,43 +15,55 @@ import qualified Data.ByteString.Char8 as B
import Data.Kind
import Data.Time.Clock (UTCTime)
import Network.Socket
import Simplex.Messaging.Server.Transmission (Encoded, MsgBody, PublicKey, QueueId)
-- import Numeric.Natural
import Simplex.Messaging.Server.Transmission (CorrId (..), Encoded, MsgBody, PublicKey, QueueId, errMessageBody)
import Simplex.Messaging.Transport
import System.IO
import Text.Read
data AParty = Agent | User
deriving (Show)
type ARawTransmission = (ByteString, ByteString, ByteString)
type ATransmission p = (CorrId, ConnAlias, ACommand p)
type ATransmissionOrError p = (CorrId, ConnAlias, Either ErrorType (ACommand p))
data AParty = Agent | Client
deriving (Eq, Show)
data SAParty :: AParty -> Type where
SAgent :: SAParty Agent
SUser :: SAParty User
SClient :: SAParty Client
deriving instance Show (SAParty a)
deriving instance Show (SAParty p)
deriving instance Eq (SAParty p)
data ACmd where
ACmd :: SAParty a -> ACommand a -> ACmd
ACmd :: SAParty p -> ACommand p -> ACmd
data ACommand (a :: AParty) where
NEW :: SMPServer -> Maybe ConnectionName -> AckMode -> ACommand User
INV :: ConnAlias -> SMPQueueInfo -> ACommand Agent
JOIN :: SMPQueueInfo -> Maybe SMPServer -> Maybe ConnectionName -> AckMode -> ACommand User
CON :: ConnAlias -> ACommand Agent
CONF :: ConnAlias -> OtherPartyId -> ACommand Agent
LET :: ConnAlias -> OtherPartyId -> ACommand User
SUB :: ConnAlias -> SubMode -> ACommand User
END :: ConnAlias -> ACommand Agent
QST :: ConnAlias -> QueueDirection -> ACommand User
STAT :: ConnAlias -> QueueDirection -> Maybe QueueStatus -> Maybe SubMode -> ACommand Agent
SEND :: ConnAlias -> MsgBody -> ACommand User
MSG :: ConnAlias -> AgentMsgId -> UTCTime -> UTCTime -> MsgStatus -> MsgBody -> ACommand Agent
ACK :: ConnAlias -> AgentMsgId -> ACommand User
RCVD :: ConnAlias -> AgentMsgId -> ACommand Agent
OFF :: ConnAlias -> ACommand User
DEL :: ConnAlias -> ACommand User
OK :: ConnAlias -> ACommand Agent
deriving instance Show ACmd
data ACommand (p :: AParty) where
NEW :: SMPServer -> AckMode -> ACommand Client
INV :: SMPQueueInfo -> ACommand Agent
JOIN :: SMPQueueInfo -> Maybe SMPServer -> AckMode -> ACommand Client
CON :: ACommand Agent
CONF :: OtherPartyId -> ACommand Agent
LET :: OtherPartyId -> ACommand Client
SUB :: SubMode -> ACommand Client
END :: ACommand Agent
QST :: QueueDirection -> ACommand Client
STAT :: QueueDirection -> Maybe QueueStatus -> Maybe SubMode -> ACommand Agent
SEND :: MsgBody -> ACommand Client
MSG :: AgentMsgId -> UTCTime -> UTCTime -> MsgStatus -> MsgBody -> ACommand Agent
ACK :: AgentMsgId -> ACommand Client
RCVD :: AgentMsgId -> ACommand Agent
OFF :: ACommand Client
DEL :: ACommand Client
OK :: ACommand Agent
ERR :: ErrorType -> ACommand Agent
deriving instance Show (ACommand a)
deriving instance Show (ACommand p)
data AMessage where
HELLO :: VerificationKey -> AckMode -> AMessage
@@ -65,8 +78,6 @@ type KeyFingerprint = Encoded
type ConnAlias = ByteString
type ConnectionName = ByteString
type OtherPartyId = Encoded
data Mode = On | Off deriving (Show)
@@ -95,7 +106,7 @@ data MsgStatus = MsgOk | MsgError MsgErrorType
data MsgErrorType = MsgSkipped AgentMsgId AgentMsgId | MsgBadId AgentMsgId | MsgBadHash
deriving (Show)
data ErrorType = UNKNOWN | PROHIBITED -- etc.
data ErrorType = UNKNOWN | PROHIBITED | SYNTAX Int | SIZE -- etc. TODO SYNTAX Natural
deriving (Show)
data AckStatus = AckOk | AckError AckErrorType
@@ -104,11 +115,92 @@ data AckStatus = AckOk | AckError AckErrorType
data AckErrorType = AckUnknown | AckProhibited | AckSyntax Int -- etc.
deriving (Show)
parseCommand :: SAParty p -> ByteString -> Either ErrorType (ACommand p)
parseCommand _ _ = Left UNKNOWN
parseCommand :: ByteString -> Either ErrorType ACmd
parseCommand _ = Left UNKNOWN
serializeCommand :: ACommand p -> ByteString
serializeCommand = B.pack . show
tPutRaw :: MonadIO m => Handle -> ARawTransmission -> m ()
tPutRaw h (corrId, connAlias, command) = do
putLn h corrId
putLn h connAlias
putLn h command
tGetRaw :: MonadIO m => Handle -> m ARawTransmission
tGetRaw h = do
corrId <- getLn h
connAlias <- getLn h
command <- getLn h
return (corrId, connAlias, command)
tPut :: MonadIO m => Handle -> ATransmission p -> m ()
tPut h (corrId, connAlias, command) = tPutRaw h (bs corrId, connAlias, serializeCommand command)
fromClient :: ACmd -> Either ErrorType ACmd
fromClient = \case
ACmd SAgent _ -> Left PROHIBITED
cmd -> Right cmd
fromAgent :: ACmd -> Either ErrorType ACmd
fromAgent = \case
ACmd SClient _ -> Left PROHIBITED
cmd -> Right cmd
-- | get client and agent transmissions
-- tGet :: forall m p. MonadIO m => SAParty p -> Handle -> m (ATransmissionOrError p)
-- tGet fromParty h = tGetRaw h >>= tParseLoadBody
-- where
-- tParseLoadBody :: ARawTransmission -> m (ATransmissionOrError p)
-- tParseLoadBody t@(corrId, connAlias, command) = do
-- let cmd = parseCommand command >>= fromParty -- >>= tCredentials t
-- fullCmd <- either (return . Left) cmdWithMsgBody cmd
-- return (CorrId corrId, connAlias, fullCmd)
-- fromParty :: ACmd -> Either ErrorType (ACommand p)
-- fromParty (ACmd p cmd)
-- | p == party = Right cmd
-- | otherwise = Left PROHIBITED
-- tCredentials :: RawTransmission -> Cmd -> Either ErrorType Cmd
-- tCredentials (signature, _, queueId, _) cmd = case cmd of
-- -- IDS response should not have queue ID
-- Cmd SBroker (IDS _ _) -> Right cmd
-- -- ERROR response does not always have queue ID
-- Cmd SBroker (ERR _) -> Right cmd
-- -- other responses must have queue ID
-- Cmd SBroker _
-- | B.null queueId -> Left $ SYNTAX errNoConnectionId
-- | otherwise -> Right cmd
-- -- CREATE must NOT have signature or queue ID
-- Cmd SRecipient (NEW _)
-- | B.null signature && B.null queueId -> Right cmd
-- | otherwise -> Left $ SYNTAX errHasCredentials
-- -- SEND must have queue ID, signature is not always required
-- Cmd SSender (SEND _)
-- | B.null queueId -> Left $ SYNTAX errNoConnectionId
-- | otherwise -> Right cmd
-- -- other client commands must have both signature and queue ID
-- Cmd SRecipient _
-- | B.null signature || B.null queueId -> Left $ SYNTAX errNoCredentials
-- | otherwise -> Right cmd
-- cmdWithMsgBody :: ACommand p -> m (Either ErrorType (ACommand p))
-- cmdWithMsgBody = \case
-- SEND body -> SEND <$$> getMsgBody body
-- MSG agentMsgId srvTS agentTS status body -> MSG agentMsgId srvTS agentTS status <$$> getMsgBody body
-- cmd -> return $ Right cmd
-- getMsgBody :: MsgBody -> m (Either ErrorType MsgBody)
-- getMsgBody msgBody =
-- case B.unpack msgBody of
-- ':' : body -> return . Right $ B.pack body
-- str -> case readMaybe str :: Maybe Int of
-- Just size -> do
-- body <- getBytes h size
-- s <- getLn h
-- return $ if B.null s then Right body else Left SIZE
-- Nothing -> return . Left $ SYNTAX errMessageBody
aCmdGet :: forall m p. MonadIO m => SAParty p -> Handle -> m (Either ErrorType (ACommand p))
aCmdGet _ h = getLn h >>= (\_ -> return $ Left UNKNOWN)