agent: Transmission type

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
 

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

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)

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 ..."

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)