wip

src/Simplex/Chat/Controller.hs

@@ -413,6 +413,7 @@ data ChatCommand
   | APIRejectContact {contactReqId :: Int64, notify :: Bool}
   | APISendServiceRequest {userId :: UserId, sendTarget :: ConnectTarget 'CMContact, requestTimeout :: Maybe NominalDiffTime, signKey :: Maybe (C.StoredPrivateKey 'C.Ed25519), request :: J.Object}
   | APISendServiceResponse {userId :: UserId, requestId :: AgentInvId, responseData :: J.Object}
+  | APIRejectServiceRequest {userId :: UserId, requestId :: AgentInvId, rejectionReason :: Maybe Text}
   | APISendCallInvitation ContactId CallType
   | SendCallInvitation ContactName CallType
   | APIRejectCall ContactId

src/Simplex/Chat/Library/Commands.hs

@@ -1451,8 +1451,9 @@ processChatCommand cxt nm = \case
         pure $ CRContactRequestRejected user cReq ct_
   APISendServiceRequest userId sendTarget requestTimeout signKey request -> withUserId userId $ \user -> do
     cReq <- resolveServiceTarget user sendTarget
-    respData <- withAgent $ \a -> sendServiceRequestAsync a (aUserId user) cReq requestTimeout (C.unStored <$> signKey) (LB.toStrict $ J.encode request)
-    resp <- either (const $ throwCmdError "invalid service response") pure $ J.eitherDecodeStrict' respData
+    reqData <- either throwCmdError pure $ compressServiceBody $ LB.toStrict $ J.encode request
+    respData <- withAgent $ \a -> sendServiceRequestAsync a (aUserId user) cReq requestTimeout (C.unStored <$> signKey) reqData
+    resp <- either (const $ throwCmdError "invalid service response") pure $ J.eitherDecodeStrict' =<< decompressServiceBody respData
     pure $ CRServiceResponse user resp
     where
       resolveServiceTarget user = \case
@@ -1471,8 +1472,15 @@ processChatCommand cxt nm = \case
           resolveShortLink sLnk = (\(_, _, cReq) -> cReq) <$> getShortLinkConnReq nm user sLnk
   APISendServiceResponse userId requestId responseData -> withUserId userId $ \user -> do
     let AgentInvId invId = requestId
-    connId <- withAgent $ \a -> sendServiceReplyAsync a "" (aUserId user) invId (LB.toStrict $ J.encode responseData)
+    respData <- either throwCmdError pure $ compressServiceBody $ LB.toStrict $ J.encode responseData
+    connId <- withAgent $ \a -> sendServiceReplyAsync a "" (aUserId user) invId respData
     pure $ CRServiceReplyAccepted user (AgentConnId connId)
+  APIRejectServiceRequest userId requestId reason -> withUserId userId $ \user -> do
+    let AgentInvId invId = requestId
+    -- a reason is required for the requester to fail fast; without it the request is
+    -- dropped silently and the caller waits out its timeout
+    withAgent $ \a -> rejectServiceRequest a NRMInteractive (aUserId user) invId (encodeUtf8 <$> reason)
+    ok user
   APISendCallInvitation contactId callType -> withUser $ \user -> do
     -- party initiating call
     ct <- withFastStore $ \db -> getContact db cxt user contactId
@@ -5522,6 +5530,7 @@ chatCommandP =
       "/_reject " *> (APIRejectContact <$> A.decimal <*> (" notify=" *> onOffP <|> pure False)),
       "/_service_request " *> (APISendServiceRequest <$> A.decimal <* A.space <*> strP <*> optional (" timeout=" *> (realToFrac <$> A.double)) <*> optional (" sign_key=" *> strP) <* A.space <*> jsonP),
       "/_service_response " *> (APISendServiceResponse <$> A.decimal <* A.space <*> strP <* A.space <*> jsonP),
+      "/_reject_service_request " *> (APIRejectServiceRequest <$> A.decimal <* A.space <*> strP <*> optional (A.space *> (safeDecodeUtf8 <$> A.takeByteString))),
       "/_call invite @" *> (APISendCallInvitation <$> A.decimal <* A.space <*> jsonP),
       "/call " *> char_ '@' *> (SendCallInvitation <$> displayNameP <*> pure defaultCallType),
       "/_call reject @" *> (APIRejectCall <$> A.decimal),

src/Simplex/Chat/Library/Subscriber.hs

@@ -1366,7 +1366,7 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
           _ -> pure ()
       SREQ invId sigKey_ payload ->
         chatReadVar processServiceRequests >>= \case
-          True -> case J.eitherDecodeStrict' payload of
+          True -> case J.eitherDecodeStrict' =<< decompressServiceBody payload of
             Right request -> toView $ CEvtServiceRequest user (AgentInvId invId) sigKey_ request
             Left _ -> dropSReq
           False -> dropSReq

src/Simplex/Chat/Protocol.hs

@@ -1009,6 +1009,30 @@ markCompressedBatch :: ByteString -> ByteString
 markCompressedBatch = B.cons 'X'
 {-# INLINE markCompressedBatch #-}
 
+-- Service payloads are padded to e2eEncConnInfoLength, the same budget as connection info,
+-- so they use the compression, marker and size bound of encodeConnInfoPQ. A JSON payload
+-- never starts with 'X', so the marker is unambiguous.
+compressServiceBody :: ByteString -> Either String ByteString
+compressServiceBody body
+  | B.length body <= maxCompressedInfoLength = Right body
+  | B.length body' > maxCompressedInfoLength = Left "service payload is too large"
+  | otherwise = Right body'
+  where
+    body' = compressedBatchMsgBody_ body
+
+decompressServiceBody :: ByteString -> Either String ByteString
+decompressServiceBody body = case B.uncons body of
+  Nothing -> Left "empty service payload"
+  Just ('X', body') -> case smpDecode body' :: Either String (L.NonEmpty Compressed) of
+    Left e -> Left e
+    Right (c L.:| []) -> case decompressedSize c of
+      -- the bound is required: without it a small payload can expand to an unbounded one
+      Just size | size > maxDecompressedMsgLength -> Left "decompressed size exceeds limit"
+      Just _ -> decompress1 c
+      Nothing -> Left "compressed size not specified"
+    Right _ -> Left "unexpected compressed batch"
+  _ -> Right body
+
 justTrue :: Bool -> Maybe Bool
 justTrue True = Just True
 justTrue False = Nothing