diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index e7121172f..ab9ca8c3e 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -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 diff --git a/src/Simplex/Messaging/Agent/Env/SQLite.hs b/src/Simplex/Messaging/Agent/Env/SQLite.hs index 3a0b3a3dd..88a72030d 100644 --- a/src/Simplex/Messaging/Agent/Env/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Env/SQLite.hs @@ -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 diff --git a/src/Simplex/Messaging/Agent/Store.hs b/src/Simplex/Messaging/Agent/Store.hs index dee6ec638..580a41c4f 100644 --- a/src/Simplex/Messaging/Agent/Store.hs +++ b/src/Simplex/Messaging/Agent/Store.hs @@ -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) diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs index 6983b855f..89650f2e4 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs @@ -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 ..." diff --git a/src/Simplex/Messaging/Agent/Transmission.hs b/src/Simplex/Messaging/Agent/Transmission.hs index 7e6640302..c50c125b3 100644 --- a/src/Simplex/Messaging/Agent/Transmission.hs +++ b/src/Simplex/Messaging/Agent/Transmission.hs @@ -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)