smp server: batch commands (#1559)

* protocol: refactor types and encoding * clean * smp server: batch commands (#1560) * smp server: batch commands verification into one DB transaction * ghc 8.10.7 * flatten transmission tuples * diff * only use batch logic if there is more than one transmission * func * reset NTF service when adding notifier * version * Revert "smp server: use separate database pool for reading queues and creating service records (#1561)" This reverts commit 3df2425162. * version * Revert "version" This reverts commit d80a6b74c5.
2026-08-29 09:58:41 +00:00 · 2025-06-12 23:05:04 +01:00
parent 1658048c2c
commit da37384335
24 changed files with 556 additions and 377 deletions
@@ -204,7 +204,7 @@ sendXFTPTransmission XFTPClient {config, thParams, http2Client} t chunkSpec_ = d
  HTTP2Response {respBody = body@HTTP2Body {bodyHead}} <- withExceptT xftpClientError . ExceptT $ sendRequest http2Client req (Just reqTimeout)
  when (B.length bodyHead /= xftpBlockSize) $ throwE $ PCEResponseError BLOCK
  -- TODO validate that the file ID is the same as in the request?
-  (_, _, (_, _fId, respOrErr)) <- liftEither . first PCEResponseError $ xftpDecodeTransmission thParams bodyHead
+  (_, _fId, respOrErr) <-liftEither $ first PCEResponseError $ xftpDecodeTClient thParams bodyHead
  case respOrErr of
    Right r -> case protocolError r of
      Just e -> throwE $ PCEProtocolError e
@@ -44,8 +44,9 @@ import Simplex.Messaging.Protocol
    EntityId (..),
    RecipientId,
    SenderId,
+    RawTransmission,
    SentRawTransmission,
-    SignedTransmission,
+    SignedTransmissionOrError,
    SndPublicAuthKey,
    Transmission,
    TransmissionForAuth (..),
@@ -53,7 +54,8 @@ import Simplex.Messaging.Protocol
    encodeTransmission,
    encodeTransmissionForAuth,
    messageTagP,
-    tDecodeParseValidate,
+    tDecodeServer,
+    tDecodeClient,
    tEncodeBatch1,
    tParse,
  )
@@ -197,7 +199,7 @@ instance FilePartyI p => ProtocolEncoding XFTPVersion XFTPErrorType (FileCommand
  fromProtocolError = fromProtocolError @XFTPVersion @XFTPErrorType @FileResponse
  {-# INLINE fromProtocolError #-}

-  checkCredentials (auth, _, EntityId fileId, _) cmd = case cmd of
+  checkCredentials auth (EntityId fileId) cmd = case cmd of
    -- FNEW must not have signature and chunk ID
    FNEW {}
      | isNothing auth -> Left $ CMD NO_AUTH
@@ -231,7 +233,7 @@ instance ProtocolEncoding XFTPVersion XFTPErrorType FileCmd where
  fromProtocolError = fromProtocolError @XFTPVersion @XFTPErrorType @FileResponse
  {-# INLINE fromProtocolError #-}

-  checkCredentials t (FileCmd p c) = FileCmd p <$> checkCredentials t c
+  checkCredentials tAuth entId (FileCmd p c) = FileCmd p <$> checkCredentials tAuth entId c
  {-# INLINE checkCredentials #-}

 instance Encoding FileInfo where
@@ -310,7 +312,7 @@ instance ProtocolEncoding XFTPVersion XFTPErrorType FileResponse where
    PEBlock -> BLOCK
  {-# INLINE fromProtocolError #-}

-  checkCredentials (_, _, EntityId entId, _) cmd = case cmd of
+  checkCredentials _ (EntityId entId) cmd = case cmd of
    FRSndIds {} -> noEntity
    -- ERR response does not always have entity ID
    FRErr _ -> Right cmd
@@ -335,25 +337,35 @@ checkParty' c = case testEquality (sFileParty @p) (sFileParty @p') of
  Just Refl -> Just c
  _ -> Nothing

-xftpEncodeAuthTransmission :: ProtocolEncoding XFTPVersion e c => THandleParams XFTPVersion 'TClient -> C.APrivateAuthKey -> Transmission c -> Either TransportError ByteString
-xftpEncodeAuthTransmission thParams@THandleParams {thAuth} pKey (corrId, fId, msg) = do
-  let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth thParams (corrId, fId, msg)
+xftpEncodeAuthTransmission :: ProtocolEncoding XFTPVersion XFTPErrorType c => THandleParams XFTPVersion 'TClient -> C.APrivateAuthKey -> Transmission c -> Either TransportError ByteString
+xftpEncodeAuthTransmission thParams@THandleParams {thAuth} pKey t@(corrId, _, _) = do
+  let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth thParams t
  xftpEncodeBatch1 . (,tToSend) =<< authTransmission thAuth False (Just pKey) (C.cbNonce $ bs corrId) tForAuth

-xftpEncodeTransmission :: ProtocolEncoding XFTPVersion e c => THandleParams XFTPVersion p -> Transmission c -> Either TransportError ByteString
-xftpEncodeTransmission thParams (corrId, fId, msg) = do
-  let t = encodeTransmission thParams (corrId, fId, msg)
-  xftpEncodeBatch1 (Nothing, t)
+xftpEncodeTransmission :: ProtocolEncoding XFTPVersion XFTPErrorType c => THandleParams XFTPVersion p -> Transmission c -> Either TransportError ByteString
+xftpEncodeTransmission thParams t = xftpEncodeBatch1 (Nothing, encodeTransmission thParams t)

 -- this function uses batch syntax but puts only one transmission in the batch
 xftpEncodeBatch1 :: SentRawTransmission -> Either TransportError ByteString
 xftpEncodeBatch1 t = first (const TELargeMsg) $ C.pad (tEncodeBatch1 False t) xftpBlockSize

-xftpDecodeTransmission :: ProtocolEncoding XFTPVersion e c => THandleParams XFTPVersion p -> ByteString -> Either XFTPErrorType (SignedTransmission e c)
-xftpDecodeTransmission thParams t = do
+xftpDecodeTServer :: THandleParams XFTPVersion 'TServer -> ByteString -> Either XFTPErrorType (SignedTransmissionOrError XFTPErrorType FileCmd)
+xftpDecodeTServer = xftpDecodeTransmission tDecodeServer
+{-# INLINE xftpDecodeTServer #-}
+
+xftpDecodeTClient :: THandleParams XFTPVersion 'TClient -> ByteString -> Either XFTPErrorType (Transmission (Either XFTPErrorType FileResponse))
+xftpDecodeTClient = xftpDecodeTransmission tDecodeClient
+{-# INLINE xftpDecodeTClient #-}
+
+xftpDecodeTransmission ::
+  (THandleParams XFTPVersion p -> Either TransportError RawTransmission -> r) ->
+  THandleParams XFTPVersion p ->
+  ByteString ->
+  Either XFTPErrorType r
+xftpDecodeTransmission tDecode thParams t = do
  t' <- first (const BLOCK) $ C.unPad t
  case tParse thParams t' of
-    t'' :| [] -> Right $ tDecodeParseValidate thParams t''
+    t'' :| [] -> Right $ tDecode thParams t''
    _ -> Left BLOCK

 $(J.deriveJSON (enumJSON $ dropPrefix "F") ''FileParty)
@@ -53,7 +53,7 @@ import qualified Simplex.Messaging.Crypto as C
 import qualified Simplex.Messaging.Crypto.Lazy as LC
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Protocol (CorrId (..), BlockingInfo, EntityId (..), RcvPublicAuthKey, RcvPublicDhKey, RecipientId, TAuthorizations, pattern NoEntity)
+import Simplex.Messaging.Protocol (BlockingInfo, EntityId (..), RcvPublicAuthKey, RcvPublicDhKey, RecipientId, SignedTransmission, pattern NoEntity)
 import Simplex.Messaging.Server (dummyVerifyCmd, verifyCmdAuthorization)
 import Simplex.Messaging.Server.Control (CPClientRole (..))
 import Simplex.Messaging.Server.Expiration
@@ -317,22 +317,20 @@ data ServerFile = ServerFile
 processRequest :: XFTPTransportRequest -> M ()
 processRequest XFTPTransportRequest {thParams, reqBody = body@HTTP2Body {bodyHead}, sendResponse}
  | B.length bodyHead /= xftpBlockSize = sendXFTPResponse ("", NoEntity, FRErr BLOCK) Nothing
-  | otherwise = do
-      case xftpDecodeTransmission thParams bodyHead of
-        Right (sig_, signed, (corrId, fId, cmdOrErr)) ->
-          case cmdOrErr of
-            Right cmd -> do
-              let THandleParams {thAuth} = thParams
-              verifyXFTPTransmission ((,C.cbNonce (bs corrId)) <$> thAuth) sig_ signed fId cmd >>= \case
-                VRVerified req -> uncurry send =<< processXFTPRequest body req
-                VRFailed e -> send (FRErr e) Nothing
-            Left e -> send (FRErr e) Nothing
+  | otherwise =
+      case xftpDecodeTServer thParams bodyHead of
+        Right (Right t@(_, _, (corrId, fId, _))) -> do
+          let THandleParams {thAuth} = thParams
+          verifyXFTPTransmission thAuth t >>= \case
+            VRVerified req -> uncurry send =<< processXFTPRequest body req
+            VRFailed e -> send (FRErr e) Nothing
          where
            send resp = sendXFTPResponse (corrId, fId, resp)
+        Right (Left (corrId, fId, e)) -> sendXFTPResponse (corrId, fId, FRErr e) Nothing
        Left e -> sendXFTPResponse ("", NoEntity, FRErr e) Nothing
  where
-    sendXFTPResponse (corrId, fId, resp) serverFile_ = do
-      let t_ = xftpEncodeTransmission thParams (corrId, fId, resp)
+    sendXFTPResponse t' serverFile_ = do
+      let t_ = xftpEncodeTransmission thParams t'
 #ifdef slow_servers
      randomDelay
 #endif
@@ -361,8 +359,8 @@ randomDelay = do

 data VerificationResult = VRVerified XFTPRequest | VRFailed XFTPErrorType

-verifyXFTPTransmission :: Maybe (THandleAuth 'TServer, C.CbNonce) -> Maybe TAuthorizations -> ByteString -> XFTPFileId -> FileCmd -> M VerificationResult
-verifyXFTPTransmission auth_ tAuth authorized fId cmd =
+verifyXFTPTransmission :: Maybe (THandleAuth 'TServer) -> SignedTransmission FileCmd -> M VerificationResult
+verifyXFTPTransmission thAuth (tAuth, authorized, (corrId, fId, cmd)) =
  case cmd of
    FileCmd SFSender (FNEW file rcps auth') -> pure $ XFTPReqNew file rcps auth' `verifyWith` sndKey file
    FileCmd SFRecipient PING -> pure $ VRVerified XFTPReqPing
@@ -381,9 +379,9 @@ verifyXFTPTransmission auth_ tAuth authorized fId cmd =
                EntityBlocked info -> VRFailed $ BLOCKED info
                EntityOff -> noFileAuth
          Left _ -> pure noFileAuth
-        noFileAuth = maybe False (dummyVerifyCmd Nothing authorized) tAuth `seq` VRFailed AUTH
+        noFileAuth = dummyVerifyCmd thAuth tAuth authorized corrId `seq` VRFailed AUTH
    -- TODO verify with DH authorization
-    req `verifyWith` k = if verifyCmdAuthorization auth_ tAuth authorized k then VRVerified req else VRFailed AUTH
+    req `verifyWith` k = if verifyCmdAuthorization thAuth tAuth authorized corrId k then VRVerified req else VRFailed AUTH

 processXFTPRequest :: HTTP2Body -> XFTPRequest -> M (FileResponse, Maybe ServerFile)
 processXFTPRequest HTTP2Body {bodyPart} = \case