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

agent: add context to CMD error (#1167)

Browse Source 
* agent: add context to CMD error

* tests, more warnings

* fix tests

* log TBQueue sizes

* log locks

* more logs

* log sendMessagesB

* fix test

* log length

* refactor

* remove logging

* revert lock scope change

* cleanup

* add string error to A_PROHIBITED

* remove

* remove test limitations

* language
This commit is contained in:
Evgeny Poberezkin
2024-05-24 14:13:01 +01:00
committed by GitHub
parent e7a73a4c89
commit 2ff5f5a832
16 changed files with 131 additions and 113 deletions
Download Patch File Download Diff File Expand all files Collapse all files

22
package.yaml
View File

@@ -177,13 +177,31 @@ tests:
ghc-options:
# - -haddock
- -Wall
- -Weverything
- -Wno-missing-exported-signatures
- -Wno-missing-import-lists
- -Wno-missed-specialisations
- -Wno-all-missed-specialisations
- -Wno-unsafe
- -Wno-safe
- -Wno-missing-local-signatures
- -Wno-missing-kind-signatures
- -Wno-missing-deriving-strategies
- -Wno-monomorphism-restriction
- -Wno-prepositive-qualified-module
- -Wno-unused-packages
- -Wno-implicit-prelude
- -Wno-missing-safe-haskell-mode
- -Wno-missing-export-lists
- -Wno-partial-fields
- -Wcompat
- -Werror=incomplete-record-updates
- -Werror=incomplete-patterns
- -Werror=incomplete-uni-patterns
- -Werror=missing-methods
- -Werror=tabs
- -Wredundant-constraints
- -Wincomplete-record-updates
- -Wincomplete-uni-patterns
- -Wunused-type-patterns
- -O2

14
simplexmq.cabal
View File

@@ -175,7 +175,7 @@ library
src
default-extensions:
StrictData
ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Werror=missing-methods -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -O2
ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=incomplete-uni-patterns -Werror=missing-methods -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -O2
include-dirs:
cbits
c-sources:
@@ -256,7 +256,7 @@ executable ntf-server
apps/ntf-server
default-extensions:
StrictData
ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Werror=missing-methods -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -O2 -threaded -rtsopts
ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=incomplete-uni-patterns -Werror=missing-methods -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -O2 -threaded -rtsopts
build-depends:
aeson ==2.2.*
, ansi-terminal >=0.10 && <0.12
@@ -331,7 +331,7 @@ executable smp-agent
apps/smp-agent
default-extensions:
StrictData
ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Werror=missing-methods -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -O2 -threaded -rtsopts
ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=incomplete-uni-patterns -Werror=missing-methods -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -O2 -threaded -rtsopts
build-depends:
aeson ==2.2.*
, ansi-terminal >=0.10 && <0.12
@@ -406,7 +406,7 @@ executable smp-server
apps/smp-server
default-extensions:
StrictData
ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Werror=missing-methods -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -O2 -threaded -rtsopts
ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=incomplete-uni-patterns -Werror=missing-methods -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -O2 -threaded -rtsopts
build-depends:
aeson ==2.2.*
, ansi-terminal >=0.10 && <0.12
@@ -481,7 +481,7 @@ executable xftp
apps/xftp
default-extensions:
StrictData
ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Werror=missing-methods -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -O2 -threaded -rtsopts
ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=incomplete-uni-patterns -Werror=missing-methods -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -O2 -threaded -rtsopts
build-depends:
aeson ==2.2.*
, ansi-terminal >=0.10 && <0.12
@@ -556,7 +556,7 @@ executable xftp-server
apps/xftp-server
default-extensions:
StrictData
ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Werror=missing-methods -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -O2 -threaded -rtsopts
ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=incomplete-uni-patterns -Werror=missing-methods -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -O2 -threaded -rtsopts
build-depends:
aeson ==2.2.*
, ansi-terminal >=0.10 && <0.12
@@ -664,7 +664,7 @@ test-suite simplexmq-test
tests
default-extensions:
StrictData
ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Werror=missing-methods -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -O2 -threaded -rtsopts -with-rtsopts=-A64M -with-rtsopts=-N1
ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=incomplete-uni-patterns -Werror=missing-methods -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -O2 -threaded -rtsopts -with-rtsopts=-A64M -with-rtsopts=-N1
build-depends:
HUnit ==1.6.*
, QuickCheck ==2.14.*

2
src/Simplex/FileTransfer/Client.hs
View File

@@ -216,7 +216,7 @@ sendXFTPTransmission XFTPClient {config, thParams, http2Client} t chunkSpec_ = d
forM_ chunkSpec_ $ \XFTPChunkSpec {filePath, chunkOffset, chunkSize} ->
withFile filePath ReadMode $ \h -> do
hSeek h AbsoluteSeek $ fromIntegral chunkOffset
hSendFile h send $ fromIntegral chunkSize
hSendFile h send chunkSize
done
createXFTPChunk ::

6
src/Simplex/FileTransfer/Client/Main.hs
View File

@@ -332,7 +332,7 @@ cliSendFileOpts SendOptions {filePath, outputDir, numRecipients, xftpServers, re
(sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
rKeys <- atomically $ L.fromList <$> replicateM numRecipients (C.generateAuthKeyPair C.SEd25519 g)
digest <- liftIO $ getChunkDigest chunkSpec
let ch = FileInfo {sndKey, size = fromIntegral chunkSize, digest}
let ch = FileInfo {sndKey, size = chunkSize, digest}
c <- withRetry retryCount $ getXFTPServerClient a xftpServer
(sndId, rIds) <- withRetry retryCount $ createXFTPChunk c spKey ch (L.map fst rKeys) auth
withReconnect a xftpServer retryCount $ \c' -> uploadXFTPChunk c' spKey sndId chunkSpec
@@ -344,7 +344,7 @@ cliSendFileOpts SendOptions {filePath, outputDir, numRecipients, xftpServers, re
when verbose $ putStrLn ""
let recipients = L.toList $ L.map ChunkReplicaId rIds `L.zip` L.map snd rKeys
replicas = [SentFileChunkReplica {server = xftpServer, recipients}]
pure (chunkNo, SentFileChunk {chunkNo, sndId, sndPrivateKey = spKey, chunkSize = FileSize $ fromIntegral chunkSize, digest = FileDigest digest, replicas})
pure (chunkNo, SentFileChunk {chunkNo, sndId, sndPrivateKey = spKey, chunkSize = FileSize chunkSize, digest = FileDigest digest, replicas})
getXFTPServer :: TVar StdGen -> NonEmpty XFTPServerWithAuth -> IO XFTPServerWithAuth
getXFTPServer gen = \case
srv :| [] -> pure srv
@@ -563,7 +563,7 @@ prepareChunkSpecs filePath chunkSizes = reverse . snd $ foldl' addSpec (0, []) c
where
addSpec :: (Int64, [XFTPChunkSpec]) -> Word32 -> (Int64, [XFTPChunkSpec])
addSpec (chunkOffset, specs) sz =
let spec = XFTPChunkSpec {filePath, chunkOffset, chunkSize = fromIntegral sz}
let spec = XFTPChunkSpec {filePath, chunkOffset, chunkSize = sz}
in (chunkOffset + fromIntegral sz, spec : specs)
getEncPath :: MonadIO m => Maybe FilePath -> String -> m FilePath

2
src/Simplex/FileTransfer/Server.hs
View File

@@ -326,7 +326,7 @@ processRequest XFTPTransportRequest {thParams, reqBody = body@HTTP2Body {bodyHea
send $ byteString t
-- timeout sending file in the same way as receiving
forM_ serverFile_ $ \ServerFile {filePath, fileSize, sbState} -> do
withFile filePath ReadMode $ \h -> sendEncFile h send sbState (fromIntegral fileSize)
withFile filePath ReadMode $ \h -> sendEncFile h send sbState fileSize
done
data VerificationResult = VRVerified XFTPRequest | VRFailed

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

@@ -120,10 +120,11 @@ module Simplex.Messaging.Agent
)
where
import Control.Logger.Simple (logError, logInfo, showText)
import Control.Logger.Simple
import Control.Monad
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.Trans.Except
import Crypto.Random (ChaChaDRG)
import qualified Data.Aeson as J
import Data.Bifunctor (bimap, first, second)
@@ -571,7 +572,7 @@ withAgentEnv c a = ExceptT $ runExceptT a `runReaderT` agentEnv c
logConnection :: AgentClient -> Bool -> IO ()
logConnection c connected =
let event = if connected then "connected to" else "disconnected from"
in logInfo $ T.unwords ["client", showText (clientId c), event, "Agent"]
in logInfo $ T.unwords ["client", tshow (clientId c), event, "Agent"]
-- | Runs an SMP agent instance that receives commands and sends responses via 'TBQueue's.
runAgentClient :: AgentClient -> AM' ()
@@ -651,14 +652,14 @@ joinConnAsync c userId corrId enableNtfs cReqUri@CRInvitationUri {} cInfo pqSup
pure connId
Nothing -> throwError $ AGENT A_VERSION
joinConnAsync _c _userId _corrId _enableNtfs (CRContactUri _) _subMode _cInfo _pqEncryption =
throwError $ CMD PROHIBITED
throwE $ CMD PROHIBITED "joinConnAsync"
allowConnectionAsync' :: AgentClient -> ACorrId -> ConnId -> ConfirmationId -> ConnInfo -> AM ()
allowConnectionAsync' c corrId connId confId ownConnInfo =
withStore c (`getConn` connId) >>= \case
SomeConn _ (RcvConnection _ RcvQueue {server}) ->
enqueueCommand c corrId connId (Just server) $ AClientCommand $ APC SAEConn $ LET confId ownConnInfo
_ -> throwError $ CMD PROHIBITED
_ -> throwE $ CMD PROHIBITED "allowConnectionAsync"
acceptContactAsync' :: AgentClient -> ACorrId -> Bool -> InvitationId -> ConnInfo -> PQSupport -> SubscriptionMode -> AM ConnId
acceptContactAsync' c corrId enableNtfs invId ownConnInfo pqSupport subMode = do
@@ -669,7 +670,7 @@ acceptContactAsync' c corrId enableNtfs invId ownConnInfo pqSupport subMode = do
joinConnAsync c userId corrId enableNtfs connReq ownConnInfo pqSupport subMode `catchAgentError` \err -> do
withStore' c (`unacceptInvitation` invId)
throwError err
_ -> throwError $ CMD PROHIBITED
_ -> throwE $ CMD PROHIBITED "acceptContactAsync"
ackMessageAsync' :: AgentClient -> ACorrId -> ConnId -> AgentMsgId -> Maybe MsgReceiptInfo -> AM ()
ackMessageAsync' c corrId connId msgId rcptInfo_ = do
@@ -678,14 +679,14 @@ ackMessageAsync' c corrId connId msgId rcptInfo_ = do
SCDuplex -> enqueueAck
SCRcv -> enqueueAck
SCSnd -> throwError $ CONN SIMPLEX
SCContact -> throwError $ CMD PROHIBITED
SCNew -> throwError $ CMD PROHIBITED
SCContact -> throwE $ CMD PROHIBITED "ackMessageAsync: SCContact"
SCNew -> throwE $ CMD PROHIBITED "ackMessageAsync: SCNew"
where
enqueueAck :: AM ()
enqueueAck = do
let mId = InternalId msgId
RcvMsg {msgType} <- withStore c $ \db -> getRcvMsg db connId mId
when (isJust rcptInfo_ && msgType /= AM_A_MSG_) $ throwError $ CMD PROHIBITED
when (isJust rcptInfo_ && msgType /= AM_A_MSG_) $ throwE $ CMD PROHIBITED "ackMessageAsync: receipt not allowed"
(RcvQueue {server}, _) <- withStore c $ \db -> setMsgUserAck db connId mId
enqueueCommand c corrId connId (Just server) . AClientCommand $ APC SAEConn $ ACK msgId rcptInfo_
@@ -713,14 +714,14 @@ switchConnectionAsync' c corrId connId =
withConnLock c connId "switchConnectionAsync" $
withStore c (`getConn` connId) >>= \case
SomeConn _ (DuplexConnection cData rqs@(rq :| _rqs) sqs)
| isJust (switchingRQ rqs) -> throwError $ CMD PROHIBITED
| isJust (switchingRQ rqs) -> throwE $ CMD PROHIBITED "switchConnectionAsync: already switching"
| otherwise -> do
when (ratchetSyncSendProhibited cData) $ throwError $ CMD PROHIBITED
when (ratchetSyncSendProhibited cData) $ throwE $ CMD PROHIBITED "switchConnectionAsync: send prohibited"
rq1 <- withStore' c $ \db -> setRcvSwitchStatus db rq $ Just RSSwitchStarted
enqueueCommand c corrId connId Nothing $ AClientCommand $ APC SAEConn SWCH
let rqs' = updatedQs rq1 rqs
pure . connectionStats $ DuplexConnection cData rqs' sqs
_ -> throwError $ CMD PROHIBITED
_ -> throwE $ CMD PROHIBITED "switchConnectionAsync: not duplex"
newConn :: AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> AM (ConnId, ConnectionRequestUri c)
newConn c userId connId enableNtfs cMode clientData pqInitKeys subMode =
@@ -737,7 +738,7 @@ newConnSrv c userId connId hasNewConn enableNtfs cMode clientData pqInitKeys sub
newRcvConnSrv :: AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> SMPServerWithAuth -> AM (ConnId, ConnectionRequestUri c)
newRcvConnSrv c userId connId enableNtfs cMode clientData pqInitKeys subMode srv = do
case (cMode, pqInitKeys) of
(SCMContact, CR.IKUsePQ) -> throwError $ CMD PROHIBITED
(SCMContact, CR.IKUsePQ) -> throwE $ CMD PROHIBITED "newRcvConnSrv"
_ -> pure ()
AgentConfig {smpClientVRange, smpAgentVRange, e2eEncryptVRange} <- asks config
(rq, qUri, tSess, sessId) <- newRcvQueue c userId connId srv smpClientVRange subMode `catchAgentError` \e -> liftIO (print e) >> throwError e
@@ -863,7 +864,7 @@ joinConnSrvAsync c userId connId enableNtfs inv@CRInvitationUri {} cInfo pqSuppo
ExceptT $ updateNewConnSnd db connId q
confirmQueueAsync c cData q' srv cInfo (Just e2eSndParams) subMode
joinConnSrvAsync _c _userId _connId _enableNtfs (CRContactUri _) _cInfo _subMode _pqSupport _srv = do
throwError $ CMD PROHIBITED
throwE $ CMD PROHIBITED "joinConnSrvAsync"
createReplyQueue :: AgentClient -> ConnData -> SndQueue -> SubscriptionMode -> SMPServerWithAuth -> AM SMPQueueInfo
createReplyQueue c ConnData {userId, connId, enableNtfs} SndQueue {smpClientVersion} subMode srv = do
@@ -888,7 +889,7 @@ allowConnection' c connId confId ownConnInfo = withConnLock c connId "allowConne
liftIO $ setRcvQueueConfirmedE2E db rq dhSecret $ min v v'
pure senderKey
enqueueCommand c "" connId (Just server) . AInternalCommand $ ICAllowSecure rcvId senderKey
_ -> throwError $ CMD PROHIBITED
_ -> throwE $ CMD PROHIBITED "allowConnection"
-- | Accept contact (ACPT command) in Reader monad
acceptContact' :: AgentClient -> ConnId -> Bool -> InvitationId -> ConnInfo -> PQSupport -> SubscriptionMode -> AM ConnId
@@ -900,7 +901,7 @@ acceptContact' c connId enableNtfs invId ownConnInfo pqSupport subMode = withCon
joinConn c userId connId False enableNtfs connReq ownConnInfo pqSupport subMode `catchAgentError` \err -> do
withStore' c (`unacceptInvitation` invId)
throwError err
_ -> throwError $ CMD PROHIBITED
_ -> throwE $ CMD PROHIBITED "acceptContact"
-- | Reject contact (RJCT command) in Reader monad
rejectContact' :: AgentClient -> ConnId -> InvitationId -> AM ()
@@ -1000,14 +1001,14 @@ resubscribeConnections' c connIds = do
getConnectionMessage' :: AgentClient -> ConnId -> AM (Maybe SMPMsgMeta)
getConnectionMessage' c connId = do
whenM (atomically $ hasActiveSubscription c connId) . throwError $ CMD PROHIBITED
whenM (atomically $ hasActiveSubscription c connId) . throwE $ CMD PROHIBITED "getConnectionMessage: subscribed"
SomeConn _ conn <- withStore c (`getConn` connId)
case conn of
DuplexConnection _ (rq :| _) _ -> getQueueMessage c rq
RcvConnection _ rq -> getQueueMessage c rq
ContactConnection _ rq -> getQueueMessage c rq
SndConnection _ _ -> throwError $ CONN SIMPLEX
NewConnection _ -> throwError $ CMD PROHIBITED
NewConnection _ -> throwE $ CMD PROHIBITED "getConnectionMessage: NewConnection"
getNotificationMessage' :: AgentClient -> C.CbNonce -> ByteString -> AM (NotificationInfo, [SMPMsgMeta])
getNotificationMessage' c nonce encNtfInfo = do
@@ -1019,7 +1020,7 @@ getNotificationMessage' c nonce encNtfInfo = do
ntfMsgMeta <- (eitherToMaybe . smpDecode <$> agentCbDecrypt rcvNtfDhSecret nmsgNonce encNMsgMeta) `catchAgentError` \_ -> pure Nothing
maxMsgs <- asks $ ntfMaxMessages . config
(NotificationInfo {ntfConnId, ntfTs, ntfMsgMeta},) <$> getNtfMessages ntfConnId ntfMsgMeta maxMsgs
_ -> throwError $ CMD PROHIBITED
_ -> throwE $ CMD PROHIBITED "getNotificationMessage"
where
getNtfMessages ntfConnId nMeta = getMsg
where
@@ -1071,7 +1072,7 @@ sendMessagesB_ c reqs connIds = withConnLocks c connIds "sendMessages" $ do
where
prepareMsg :: ConnData -> NonEmpty SndQueue -> ([ConnId], Either AgentErrorType (ConnData, NonEmpty SndQueue, Maybe PQEncryption, MsgFlags, AMessage))
prepareMsg cData@ConnData {connId, pqSupport} sqs
| ratchetSyncSendProhibited cData = (acc, Left $ CMD PROHIBITED)
| ratchetSyncSendProhibited cData = (acc, Left $ CMD PROHIBITED "sendMessagesB: send prohibited")
-- connection is only updated if PQ encryption was disabled, and now it has to be enabled.
-- support for PQ encryption (small message envelopes) will not be disabled when message is sent.
| pqEnc == PQEncOn && pqSupport == PQSupportOff =
@@ -1133,7 +1134,7 @@ runCommandProcessing c@AgentClient {subQ} server_ Worker {doWork} = do
withStore c (`getConn` connId) >>= \case
SomeConn _ conn@(DuplexConnection _ (replaced :| _rqs) _) ->
switchDuplexConnection c conn replaced >>= notify . SWITCH QDRcv SPStarted
_ -> throwError $ CMD PROHIBITED
_ -> throwE $ CMD PROHIBITED "SWCH: not duplex"
DEL -> withServer' . tryCommand $ deleteConnection' c connId >> notify OK
_ -> notify $ ERR $ INTERNAL $ "unsupported async command " <> show (aCommandTag cmd)
AInternalCommand cmd -> case cmd of
@@ -1479,8 +1480,8 @@ ackMessage' c connId msgId rcptInfo_ = withConnLock c connId "ackMessage" $ do
DuplexConnection {} -> ack >> sendRcpt conn >> del
RcvConnection {} -> ack >> del
SndConnection {} -> throwError $ CONN SIMPLEX
ContactConnection {} -> throwError $ CMD PROHIBITED
NewConnection _ -> throwError $ CMD PROHIBITED
ContactConnection {} -> throwE $ CMD PROHIBITED "ackMessage: ContactConnection"
NewConnection _ -> throwE $ CMD PROHIBITED "ackMessage: NewConnection"
where
ack :: AM ()
ack = do
@@ -1494,7 +1495,7 @@ ackMessage' c connId msgId rcptInfo_ = withConnLock c connId "ackMessage" $ do
msg@RcvMsg {msgType, msgReceipt} <- withStore c $ \db -> getRcvMsg db connId $ InternalId msgId
case rcptInfo_ of
Just rcptInfo -> do
unless (msgType == AM_A_MSG_) $ throwError (CMD PROHIBITED)
unless (msgType == AM_A_MSG_) . throwE $ CMD PROHIBITED "ackMessage: receipt not allowed"
when (connAgentVersion >= deliveryRcptsSMPAgentVersion) $ do
let RcvMsg {msgMeta = MsgMeta {sndMsgId}, internalHash} = msg
rcpt = A_RCVD [AMessageReceipt {agentMsgId = sndMsgId, msgHash = internalHash, rcptInfo}]
@@ -1510,12 +1511,12 @@ switchConnection' c connId =
withConnLock c connId "switchConnection" $
withStore c (`getConn` connId) >>= \case
SomeConn _ conn@(DuplexConnection cData rqs@(rq :| _rqs) _)
| isJust (switchingRQ rqs) -> throwError $ CMD PROHIBITED
| isJust (switchingRQ rqs) -> throwE $ CMD PROHIBITED "switchConnection: already switching"
| otherwise -> do
when (ratchetSyncSendProhibited cData) $ throwError $ CMD PROHIBITED
when (ratchetSyncSendProhibited cData) $ throwE $ CMD PROHIBITED "switchConnection: send prohibited"
rq' <- withStore' c $ \db -> setRcvSwitchStatus db rq $ Just RSSwitchStarted
switchDuplexConnection c conn rq'
_ -> throwError $ CMD PROHIBITED
_ -> throwE $ CMD PROHIBITED "switchConnection: not duplex"
switchDuplexConnection :: AgentClient -> Connection 'CDuplex -> RcvQueue -> AM ConnectionStats
switchDuplexConnection c (DuplexConnection cData@ConnData {connId, userId} rqs sqs) rq@RcvQueue {server, dbQueueId = DBQueueId dbQueueId, sndId} = do
@@ -1540,7 +1541,7 @@ abortConnectionSwitch' c connId =
SomeConn _ (DuplexConnection cData rqs sqs) -> case switchingRQ rqs of
Just rq
| canAbortRcvSwitch rq -> do
when (ratchetSyncSendProhibited cData) $ throwError $ CMD PROHIBITED
when (ratchetSyncSendProhibited cData) $ throwE $ CMD PROHIBITED "abortConnectionSwitch: send prohibited"
-- multiple queues to which the connections switches were possible when repeating switch was allowed
let (delRqs, keepRqs) = L.partition ((Just (dbQId rq) ==) . dbReplaceQId) rqs
case L.nonEmpty keepRqs of
@@ -1553,9 +1554,9 @@ abortConnectionSwitch' c connId =
conn' = DuplexConnection cData rqs'' sqs
pure $ connectionStats conn'
_ -> throwError $ INTERNAL "won't delete all rcv queues in connection"
| otherwise -> throwError $ CMD PROHIBITED
_ -> throwError $ CMD PROHIBITED
_ -> throwError $ CMD PROHIBITED
| otherwise -> throwE $ CMD PROHIBITED "abortConnectionSwitch: no rcv queues left"
_ -> throwE $ CMD PROHIBITED "abortConnectionSwitch: not allowed"
_ -> throwE $ CMD PROHIBITED "abortConnectionSwitch: not duplex"
synchronizeRatchet' :: AgentClient -> ConnId -> PQSupport -> Bool -> AM ConnectionStats
synchronizeRatchet' c connId pqSupport' force = withConnLock c connId "synchronizeRatchet" $ do
@@ -1575,8 +1576,8 @@ synchronizeRatchet' c connId pqSupport' force = withConnLock c connId "synchroni
let cData'' = cData' {ratchetSyncState = RSStarted} :: ConnData
conn' = DuplexConnection cData'' rqs sqs
pure $ connectionStats conn'
| otherwise -> throwError $ CMD PROHIBITED
_ -> throwError $ CMD PROHIBITED
| otherwise -> throwE $ CMD PROHIBITED "synchronizeRatchet: not allowed"
_ -> throwE $ CMD PROHIBITED "synchronizeRatchet: not duplex"
ackQueueMessage :: AgentClient -> RcvQueue -> SMP.MsgId -> AM ()
ackQueueMessage c rq srvMsgId =
@@ -1593,7 +1594,7 @@ suspendConnection' c connId = withConnLock c connId "suspendConnection" $ do
RcvConnection _ rq -> suspendQueue c rq
ContactConnection _ rq -> suspendQueue c rq
SndConnection _ _ -> throwError $ CONN SIMPLEX
NewConnection _ -> throwError $ CMD PROHIBITED
NewConnection _ -> throwE $ CMD PROHIBITED "suspendConnection"
-- | Delete SMP agent connection (DEL command) in Reader monad
-- unlike deleteConnectionAsync, this function does not mark connection as deleted in case of deletion failure
@@ -1831,7 +1832,7 @@ registerNtfToken' c suppliedDeviceToken suppliedNtfMode =
withStore' c (`createNtfToken` tkn)
registerToken tkn
pure NTRegistered
_ -> throwError $ CMD PROHIBITED
_ -> throwE $ CMD PROHIBITED "createToken"
registerToken :: NtfToken -> AM ()
registerToken tkn@NtfToken {ntfPubKey, ntfDhKeys = (pubDhKey, privDhKey)} = do
(tknId, srvPubDhKey) <- agentNtfRegisterToken c tkn ntfPubKey pubDhKey
@@ -1844,7 +1845,7 @@ verifyNtfToken' :: AgentClient -> DeviceToken -> C.CbNonce -> ByteString -> AM (
verifyNtfToken' c deviceToken nonce code =
withStore' c getSavedNtfToken >>= \case
Just tkn@NtfToken {deviceToken = savedDeviceToken, ntfTokenId = Just tknId, ntfDhSecret = Just dhSecret, ntfMode} -> do
when (deviceToken /= savedDeviceToken) . throwError $ CMD PROHIBITED
when (deviceToken /= savedDeviceToken) . throwE $ CMD PROHIBITED "verifyNtfToken: different token"
code' <- liftEither . bimap cryptoError NtfRegCode $ C.cbDecrypt dhSecret nonce code
toStatus <-
withToken c tkn (Just (NTConfirmed, NTAVerify code')) (NTActive, Just NTACheck) $
@@ -1853,36 +1854,36 @@ verifyNtfToken' c deviceToken nonce code =
cron <- asks $ ntfCron . config
agentNtfEnableCron c tknId tkn cron
when (ntfMode == NMInstant) $ initializeNtfSubs c
_ -> throwError $ CMD PROHIBITED
_ -> throwE $ CMD PROHIBITED "verifyNtfToken: no token"
checkNtfToken' :: AgentClient -> DeviceToken -> AM NtfTknStatus
checkNtfToken' c deviceToken =
withStore' c getSavedNtfToken >>= \case
Just tkn@NtfToken {deviceToken = savedDeviceToken, ntfTokenId = Just tknId} -> do
when (deviceToken /= savedDeviceToken) . throwError $ CMD PROHIBITED
when (deviceToken /= savedDeviceToken) . throwE $ CMD PROHIBITED "checkNtfToken: different token"
agentNtfCheckToken c tknId tkn
_ -> throwError $ CMD PROHIBITED
_ -> throwE $ CMD PROHIBITED "checkNtfToken: no token"
deleteNtfToken' :: AgentClient -> DeviceToken -> AM ()
deleteNtfToken' c deviceToken =
withStore' c getSavedNtfToken >>= \case
Just tkn@NtfToken {deviceToken = savedDeviceToken} -> do
when (deviceToken /= savedDeviceToken) . throwError $ CMD PROHIBITED
when (deviceToken /= savedDeviceToken) . throwE $ CMD PROHIBITED "deleteNtfToken: different token"
deleteToken_ c tkn
deleteNtfSubs c NSCSmpDelete
_ -> throwError $ CMD PROHIBITED
_ -> throwE $ CMD PROHIBITED "deleteNtfToken: no token"
getNtfToken' :: AgentClient -> AM (DeviceToken, NtfTknStatus, NotificationsMode, NtfServer)
getNtfToken' c =
withStore' c getSavedNtfToken >>= \case
Just NtfToken {deviceToken, ntfTknStatus, ntfMode, ntfServer} -> pure (deviceToken, ntfTknStatus, ntfMode, ntfServer)
_ -> throwError $ CMD PROHIBITED
_ -> throwE $ CMD PROHIBITED "getNtfToken"
getNtfTokenData' :: AgentClient -> AM NtfToken
getNtfTokenData' c =
withStore' c getSavedNtfToken >>= \case
Just tkn -> pure tkn
_ -> throwError $ CMD PROHIBITED
_ -> throwE $ CMD PROHIBITED "getNtfTokenData"
-- | Set connection notifications, in Reader monad
toggleConnectionNtfs' :: AgentClient -> ConnId -> Bool -> AM ()
@@ -2172,7 +2173,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(_, srv, _), _v, sessId, ts)
smpConfirmation srvMsgId conn senderKey e2ePubKey e2eEncryption_ encConnInfo phVer agentVersion >> ack
(SMP.PHEmpty, AgentInvitation {connReq, connInfo}) ->
smpInvitation srvMsgId conn connReq connInfo >> ack
_ -> prohibited >> ack
_ -> prohibited "handshake: incorrect state" >> ack
(Just e2eDh, Nothing) -> do
decryptClientMessage e2eDh clientMsg >>= \case
(SMP.PHEmpty, AgentRatchetKey {agentVersion, e2eEncryption}) -> do
@@ -2196,7 +2197,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(_, srv, _), _v, sessId, ts)
let encryptedMsgHash = C.sha256Hash encAgentMessage
g <- asks random
atomically updateTotalMsgCount
tryError (agentClientMsg g encryptedMsgHash) >>= \case
tryAgentError (agentClientMsg g encryptedMsgHash) >>= \case
Right (Just (msgId, msgMeta, aMessage, rcPrev)) -> do
conn'' <- resetRatchetSync
case aMessage of
@@ -2227,13 +2228,13 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(_, srv, _), _v, sessId, ts)
withStore' c $ \db -> setConnRatchetSync db connId RSOk
pure conn''
| otherwise = pure conn'
Right _ -> prohibited >> ack
Right Nothing -> prohibited "msg: bad agent msg" >> ack
Left e@(AGENT A_DUPLICATE) -> do
atomically updateDupMsgCount
withStore' c (\db -> getLastMsg db connId srvMsgId) >>= \case
Just RcvMsg {internalId, msgMeta, msgBody = agentMsgBody, userAck}
| userAck -> ackDel internalId
| otherwise -> do
| otherwise ->
liftEither (parse smpP (AGENT A_MESSAGE) agentMsgBody) >>= \case
AgentMessage _ (A_MSG body) -> do
logServer "<--" c srv rId $ "MSG <MSG>:" <> logSecret srvMsgId
@@ -2292,8 +2293,8 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(_, srv, _), _v, sessId, ts)
liftIO $ createRcvMsg db connId rq rcvMsg
pure $ Just (internalId, msgMeta, aMessage, rc)
_ -> pure Nothing
_ -> prohibited >> ack
_ -> prohibited >> ack
_ -> prohibited "msg: bad client msg" >> ack
_ -> prohibited "msg: no keys" >> ack
updateConnVersion :: Connection c -> ConnData -> VersionSMPA -> AM (Connection c)
updateConnVersion conn' cData' msgAgentVersion = do
aVRange <- asks $ smpAgentVRange . config
@@ -2330,8 +2331,8 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(_, srv, _), _v, sessId, ts)
notify :: forall e m. (AEntityI e, MonadIO m) => ACommand 'Agent e -> m ()
notify = notify' connId
prohibited :: AM ()
prohibited = notify . ERR $ AGENT A_PROHIBITED
prohibited :: String -> AM ()
prohibited = notify . ERR . AGENT . A_PROHIBITED
enqueueCmd :: InternalCommand -> AM ()
enqueueCmd = enqueueCommand c "" connId (Just srv) . AInternalCommand
@@ -2383,7 +2384,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(_, srv, _), _v, sessId, ts)
parseMessage agentMsgBody >>= \case
AgentConnInfoReply smpQueues connInfo ->
processConf connInfo SMPConfirmation {senderKey, e2ePubKey, connInfo, smpReplyQueues = L.toList smpQueues, smpClientVersion}
_ -> prohibited -- including AgentConnInfo, that is prohibited here in v2
_ -> prohibited "conf: not AgentConnInfoReply" -- including AgentConnInfo, that is prohibited here in v2
where
processConf connInfo senderConf = do
let newConfirmation = NewConfirmation {connId, senderConf, ratchetState = rc'}
@@ -2393,7 +2394,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(_, srv, _), _v, sessId, ts)
createConfirmation db g newConfirmation
let srvs = map qServer $ smpReplyQueues senderConf
notify $ CONF confId pqSupport' srvs connInfo
_ -> prohibited
_ -> prohibited "conf: decrypt error or skipped"
-- party accepting connection
(DuplexConnection _ (RcvQueue {smpClientVersion = v'} :| _) _, Nothing) -> do
g <- asks random
@@ -2403,15 +2404,15 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(_, srv, _), _v, sessId, ts)
let dhSecret = C.dh' e2ePubKey e2ePrivKey
withStore' c $ \db -> setRcvQueueConfirmedE2E db rq dhSecret $ min v' smpClientVersion
enqueueCmd $ ICDuplexSecure rId senderKey
_ -> prohibited
_ -> prohibited
_ -> prohibited
_ -> prohibited "conf: not AgentConnInfo"
_ -> prohibited "conf: incorrect state"
_ -> prohibited "conf: status /= new"
helloMsg :: SMP.MsgId -> MsgMeta -> Connection c -> AM ()
helloMsg srvMsgId MsgMeta {pqEncryption} conn' = do
logServer "<--" c srv rId $ "MSG <HELLO>:" <> logSecret srvMsgId
case status of
Active -> prohibited
Active -> prohibited "hello: active"
_ ->
case conn' of
DuplexConnection _ _ (sq@SndQueue {status = sndStatus} :| _)
@@ -2453,7 +2454,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(_, srv, _), _v, sessId, ts)
let sndMsgId = InternalSndId agentMsgId
SndMsg {internalId = InternalId msgId, msgType, internalHash, msgReceipt} <- withStore c $ \db -> getSndMsgViaRcpt db connId sndMsgId
if msgType /= AM_A_MSG_
then notify (ERR $ AGENT A_PROHIBITED) $> Nothing -- unexpected message type for receipt
then prohibited "receipt: not a msg" $> Nothing
else case msgReceipt of
Just MsgReceipt {msgRcptStatus = MROk} -> pure Nothing -- already notified with MROk status
_ -> do
@@ -2561,7 +2562,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(_, srv, _), _v, sessId, ts)
invId <- withStore c $ \db -> createInvitation db g newInv
let srvs = L.map qServer $ crSmpQueues crData
notify $ REQ invId pqSupport srvs cInfo
_ -> prohibited
_ -> prohibited "inv: sent to message conn"
where
pqSupported (_, Compatible (CR.E2ERatchetParams v _ _ _), Compatible agentVersion) =
PQSupportOn `CR.pqSupportAnd` versionPQSupport_ agentVersion (Just v)

8
src/Simplex/Messaging/Agent/Client.hs
View File

@@ -1327,7 +1327,7 @@ subscribeQueues c qs = do
where
checkQueue rq = do
prohibited <- atomically $ hasGetLock c rq
pure $ if prohibited then Left (rq, Left $ CMD PROHIBITED) else Right rq
pure $ if prohibited then Left (rq, Left $ CMD PROHIBITED "subscribeQueues") else Right rq
subscribeQueues_ :: Env -> TVar (Maybe SessionId) -> SMPClient -> NonEmpty RcvQueue -> IO (BatchResponses SMPClientError ())
subscribeQueues_ env session smp qs' = do
rs <- sendBatch subscribeSMPQueues smp qs'
@@ -1595,7 +1595,7 @@ agentXFTPNewChunk :: AgentClient -> SndFileChunk -> Int -> XFTPServerWithAuth ->
agentXFTPNewChunk c SndFileChunk {userId, chunkSpec = XFTPChunkSpec {chunkSize}, digest = FileDigest chunkDigest} n (ProtoServerWithAuth srv auth) = do
rKeys <- xftpRcvKeys n
(sndKey, replicaKey) <- atomically . C.generateAuthKeyPair C.SEd25519 =<< asks random
let fileInfo = FileInfo {sndKey, size = fromIntegral chunkSize, digest = chunkDigest}
let fileInfo = FileInfo {sndKey, size = chunkSize, digest = chunkDigest}
logServer "-->" c srv "" "FNEW"
tSess <- liftIO $ mkTransportSession c userId srv chunkDigest
(sndId, rIds) <- withClient c tSess "FNEW" $ \xftp -> X.createXFTPChunk xftp replicaKey fileInfo (L.map fst rKeys) auth
@@ -1658,7 +1658,7 @@ agentCbDecrypt dhSecret nonce msg =
cryptoError :: C.CryptoError -> AgentErrorType
cryptoError = \case
C.CryptoLargeMsgError -> CMD LARGE
C.CryptoLargeMsgError -> CMD LARGE "CryptoLargeMsgError"
C.CryptoHeaderError _ -> AGENT A_MESSAGE -- parsing error
C.CERatchetDuplicateMessage -> AGENT A_DUPLICATE
C.AESDecryptError -> c DECRYPT_AES
@@ -1801,7 +1801,7 @@ storeError = \case
SEConnDuplicate -> CONN DUPLICATE
SEBadConnType CRcv -> CONN SIMPLEX
SEBadConnType CSnd -> CONN SIMPLEX
SEInvitationNotFound -> CMD PROHIBITED
SEInvitationNotFound -> CMD PROHIBITED "SEInvitationNotFound"
-- this error is never reported as store error,
-- it is used to wrap agent operations when "transaction-like" store access is needed
-- NOTE: network IO should NOT be used inside AgentStoreMonad

32
src/Simplex/Messaging/Agent/Protocol.hs
View File

@@ -157,8 +157,8 @@ where
import Control.Applicative (optional, (<|>))
import Control.Monad (unless)
import Control.Monad.Except (runExceptT, throwError)
import Control.Monad.IO.Class
import Control.Monad.Trans.Except
import Data.Aeson (FromJSON (..), ToJSON (..))
import qualified Data.Aeson.TH as J
import Data.Attoparsec.ByteString.Char8 (Parser)
@@ -1471,7 +1471,7 @@ instance StrEncoding MsgErrorType where
-- | Error type used in errors sent to agent clients.
data AgentErrorType
= -- | command or response error
CMD {cmdErr :: CommandErrorType}
CMD {cmdErr :: CommandErrorType, errContext :: String}
| -- | connection errors
CONN {connErr :: ConnectionErrorType}
| -- | SMP protocol errors forwarded to agent clients
@@ -1529,7 +1529,7 @@ data SMPAgentError
= -- | client or agent message that failed to parse
A_MESSAGE
| -- | prohibited SMP/agent message
A_PROHIBITED
A_PROHIBITED {prohibitedErr :: String}
| -- | incompatible version of SMP client, agent or encryption protocols
A_VERSION
| -- | cannot decrypt message
@@ -1578,7 +1578,7 @@ instance StrEncoding AgentErrorType where
strP =
A.takeTill (== ' ')
>>= \case
"CMD" -> CMD <$> (A.space *> parseRead1)
"CMD" -> CMD <$> (A.space *> parseRead1) <*> (A.space *> textP)
"CONN" -> CONN <$> (A.space *> parseRead1)
"SMP" -> SMP <$> (A.space *> srvP) <*> _strP
"NTF" -> NTF <$> (A.space *> srvP) <*> _strP
@@ -1593,9 +1593,8 @@ instance StrEncoding AgentErrorType where
_ -> fail "bad AgentErrorType"
where
srvP = T.unpack . safeDecodeUtf8 <$> A.takeTill (== ' ')
textP = T.unpack . safeDecodeUtf8 <$> A.takeByteString
strEncode = \case
CMD e -> "CMD " <> bshow e
CMD e cxt -> "CMD " <> bshow e <> " " <> text cxt
CONN e -> "CONN " <> bshow e
SMP srv e -> "SMP " <> text srv <> " " <> strEncode e
NTF srv e -> "NTF " <> text srv <> " " <> strEncode e
@@ -1615,20 +1614,23 @@ instance StrEncoding SMPAgentError where
A.takeTill (== ' ')
>>= \case
"MESSAGE" -> pure A_MESSAGE
"PROHIBITED" -> pure A_PROHIBITED
"PROHIBITED" -> A_PROHIBITED <$> (A.space *> textP)
"VERSION" -> pure A_VERSION
"CRYPTO" -> A_CRYPTO <$> _strP
"DUPLICATE" -> pure A_DUPLICATE
"QUEUE" -> A_QUEUE . T.unpack . safeDecodeUtf8 <$> (A.space *> A.takeByteString)
"QUEUE" -> A_QUEUE <$> (A.space *> textP)
_ -> fail "bad SMPAgentError"
strEncode = \case
A_MESSAGE -> "MESSAGE"
A_PROHIBITED -> "PROHIBITED"
A_PROHIBITED e -> "PROHIBITED " <> encodeUtf8 (T.pack e)
A_VERSION -> "VERSION"
A_CRYPTO e -> "CRYPTO " <> strEncode e
A_DUPLICATE -> "DUPLICATE"
A_QUEUE e -> "QUEUE " <> encodeUtf8 (T.pack e)
textP :: Parser String
textP = T.unpack . safeDecodeUtf8 <$> A.takeByteString
cryptoErrToSyncState :: AgentCryptoError -> RatchetSyncState
cryptoErrToSyncState = \case
DECRYPT_AES -> RSAllowed
@@ -1841,7 +1843,7 @@ commandP binaryP =
sd : rds -> SFDONE <$> strDecode (encodeUtf8 sd) <*> mapM (strDecode . encodeUtf8) rds
parseCommand :: ByteString -> Either AgentErrorType ACmd
parseCommand = parse (commandP A.takeByteString) $ CMD SYNTAX
parseCommand = parse (commandP A.takeByteString) $ CMD SYNTAX "parseCommand"
-- | Serialize SMP agent command.
serializeCommand :: ACommand p e -> ByteString
@@ -1931,7 +1933,7 @@ tGet party h = liftIO (tGetRaw h) >>= tParseLoadBody
fromParty :: ACmd -> Either AgentErrorType (APartyCmd p)
fromParty (ACmd (p :: p1) e cmd) = case testEquality party p of
Just Refl -> Right $ APC e cmd
_ -> Left $ CMD PROHIBITED
_ -> Left $ CMD PROHIBITED "fromParty"
tConnId :: ARawTransmission -> APartyCmd p -> Either AgentErrorType (APartyCmd p)
tConnId (_, entId, _) (APC e cmd) =
@@ -1949,7 +1951,7 @@ tGet party h = liftIO (tGetRaw h) >>= tParseLoadBody
SUSPENDED {} -> Right cmd
-- other responses must have connection ID
_
| B.null entId -> Left $ CMD NO_CONN
| B.null entId -> Left $ CMD NO_CONN "tConnId"
| otherwise -> Right cmd
cmdWithMsgBody :: APartyCmd p -> IO (Either AgentErrorType (APartyCmd p))
@@ -1972,11 +1974,11 @@ tGet party h = liftIO (tGetRaw h) >>= tParseLoadBody
str -> case readMaybe str :: Maybe Int of
Just size -> runExceptT $ do
body <- liftIO $ cGet h size
unless (B.length body == size) $ throwError $ CMD SIZE
unless (B.length body == size) $ throwE $ CMD SIZE "getBody"
s <- liftIO $ getLn h
unless (B.null s) $ throwError $ CMD SIZE
unless (B.null s) $ throwE $ CMD SIZE "getBody"
pure body
Nothing -> return . Left $ CMD SYNTAX
Nothing -> pure . Left $ CMD SYNTAX "getBody"
$(J.deriveJSON defaultJSON ''RcvQueueInfo)

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

@@ -2284,7 +2284,7 @@ createRcvFile db gVar userId fd@FileDescription {chunks} prefixPath tmpPath file
forM_ (zip [1 ..] replicas) $ \(rno, replica) -> insertRcvFileChunkReplica db rno replica chunkId
pure rcvFileEntityId
createRcvFileRedirect :: DB.Connection -> TVar ChaChaDRG -> UserId -> FileDescription FRecipient -> FilePath -> FilePath -> CryptoFile -> FilePath -> CryptoFile -> Bool -> IO (Either StoreError RcvFileId)
createRcvFileRedirect :: DB.Connection -> TVar ChaChaDRG -> UserId -> FileDescription 'FRecipient -> FilePath -> FilePath -> CryptoFile -> FilePath -> CryptoFile -> Bool -> IO (Either StoreError RcvFileId)
createRcvFileRedirect _ _ _ FileDescription {redirect = Nothing} _ _ _ _ _ _ = pure $ Left $ SEInternal "createRcvFileRedirect called without redirect"
createRcvFileRedirect db gVar userId redirectFd@FileDescription {chunks = redirectChunks, redirect = Just RedirectFileInfo {size, digest}} prefixPath redirectPath redirectFile dstPath dstFile approvedRelays = runExceptT $ do
(dstEntityId, dstId) <- ExceptT $ insertRcvFile db gVar userId dummyDst prefixPath dstPath dstFile Nothing Nothing approvedRelays

4
src/Simplex/Messaging/Crypto/Ratchet.hs
View File

@@ -166,9 +166,9 @@ instance TestEquality SRatchetKEMState where
class RatchetKEMStateI (s :: RatchetKEMState) where sRatchetKEMState :: SRatchetKEMState s
instance RatchetKEMStateI RKSProposed where sRatchetKEMState = SRKSProposed
instance RatchetKEMStateI 'RKSProposed where sRatchetKEMState = SRKSProposed
instance RatchetKEMStateI RKSAccepted where sRatchetKEMState = SRKSAccepted
instance RatchetKEMStateI 'RKSAccepted where sRatchetKEMState = SRKSAccepted
checkRatchetKEMState :: forall t s s' a. (RatchetKEMStateI s, RatchetKEMStateI s') => t s' a -> Either String (t s a)
checkRatchetKEMState x = case testEquality (sRatchetKEMState @s) (sRatchetKEMState @s') of

2
src/Simplex/Messaging/Transport/HTTP2/Client.hs
View File

@@ -14,6 +14,7 @@ import Control.Monad
import Data.ByteString.Char8 (ByteString)
import Data.Functor (($>))
import Data.Time (UTCTime, getCurrentTime)
import qualified Data.X509 as X
import qualified Data.X509.CertificateStore as XS
import Network.HPACK (BufferSize)
import Network.HTTP2.Client (ClientConfig (..), Request, Response)
@@ -29,7 +30,6 @@ import Simplex.Messaging.Transport.HTTP2
import Simplex.Messaging.Util (eitherToMaybe)
import UnliftIO.STM
import UnliftIO.Timeout
import qualified Data.X509 as X
data HTTP2Client = HTTP2Client
{ action :: Maybe (Async HTTP2Response),

2
src/Simplex/Messaging/Transport/HTTP2/File.hs
View File

@@ -23,7 +23,7 @@ hReceiveFile getBody h size = get $ fromIntegral size
if
| chSize > sz -> pure (chSize - sz)
| chSize > 0 -> B.hPut h ch >> get (sz - chSize)
| otherwise -> pure (-fromIntegral sz)
| otherwise -> pure (-sz)
hSendFile :: Handle -> (Builder -> IO ()) -> Word32 -> IO ()
hSendFile h send = go

2
src/Simplex/Messaging/Transport/Server.hs
View File

@@ -118,7 +118,7 @@ runTCPServerSocket (accepted, gracefullyClosed, clients) started getSocket serve
let closeConn _ = do
atomically $ modifyTVar' clients $ IM.delete cId
gracefulClose conn 5000 `catchAll_` pure () -- catchAll_ is needed here in case the connection was closed earlier
atomically $ modifyTVar' gracefullyClosed (+1)
atomically $ modifyTVar' gracefullyClosed (+ 1)
tId <- mkWeakThreadId =<< server conn `forkFinally` closeConn
atomically $ modifyTVar' clients $ IM.insert cId tId

13
tests/AgentTests.hs
View File

@@ -7,7 +7,6 @@
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
module AgentTests (agentTests) where
@@ -358,7 +357,7 @@ testRejectContactRequest _ alice bob = do
-- RJCT must use correct contact connection
alice #: ("2a", "bob", "RJCT " <> aInvId) #> ("2a", "bob", ERR $ CONN NOT_FOUND)
alice #: ("2b", "a_contact", "RJCT " <> aInvId) #> ("2b", "a_contact", OK)
alice #: ("3", "bob", "ACPT " <> aInvId <> " 12\nalice's info") #> ("3", "bob", ERR $ A.CMD PROHIBITED)
alice #: ("3", "bob", "ACPT " <> aInvId <> " 12\nalice's info") =#> \case ("3", "bob", ERR (A.CMD PROHIBITED _)) -> True; _ -> False
bob #:# "nothing should be delivered to bob"
testSubscription :: Transport c => TProxy c -> c -> c -> c -> IO ()
@@ -430,8 +429,8 @@ testServerConnectionAfterError t _ = do
withAgent1 $ \bob -> do
withAgent2 $ \alice -> do
bob #:! ("1", "alice", "SUB") =#> \("1", "alice", ERR (BROKER _ e)) -> e == NETWORK || e == TIMEOUT
alice #:! ("1", "bob", "SUB") =#> \("1", "bob", ERR (BROKER _ e)) -> e == NETWORK || e == TIMEOUT
bob #:! ("1", "alice", "SUB") =#> \case ("1", "alice", ERR (BROKER _ e)) -> e == NETWORK || e == TIMEOUT; _ -> False
alice #:! ("1", "bob", "SUB") =#> \case ("1", "bob", ERR (BROKER _ e)) -> e == NETWORK || e == TIMEOUT; _ -> False
withServer $ do
alice <#=? \case ("", "bob", APC SAEConn (SENT 4)) -> True; ("", "", APC _ (UP s ["bob"])) -> s == server; _ -> False
alice <#=? \case ("", "bob", APC SAEConn (SENT 4)) -> True; ("", "", APC _ (UP s ["bob"])) -> s == server; _ -> False
@@ -613,12 +612,12 @@ sampleDhKey = "MCowBQYDK2VuAyEAjiswwI3O_NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o="
syntaxTests :: forall c. Transport c => TProxy c -> Spec
syntaxTests t = do
it "unknown command" $ ("1", "5678", "HELLO") >#> ("1", "5678", "ERR CMD SYNTAX")
it "unknown command" $ ("1", "5678", "HELLO") >#> ("1", "5678", "ERR CMD SYNTAX parseCommand")
describe "NEW" $ do
describe "valid" $ do
it "with correct parameter" $ ("211", "", "NEW T INV subscribe") >#>= \case ("211", _, "INV" : _) -> True; _ -> False
describe "invalid" $ do
it "with incorrect parameter" $ ("222", "", "NEW T hi subscribe") >#> ("222", "", "ERR CMD SYNTAX")
it "with incorrect parameter" $ ("222", "", "NEW T hi subscribe") >#> ("222", "", "ERR CMD SYNTAX parseCommand")
describe "JOIN" $ do
describe "valid" $ do
@@ -636,7 +635,7 @@ syntaxTests t = do
)
>#> ("311", "a", "ERR SMP smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:5001 AUTH")
describe "invalid" $ do
it "no parameters" $ ("321", "", "JOIN") >#> ("321", "", "ERR CMD SYNTAX")
it "no parameters" $ ("321", "", "JOIN") >#> ("321", "", "ERR CMD SYNTAX parseCommand")
where
-- simple test for one command with the expected response
(>#>) :: ARawTransmission -> ARawTransmission -> Expectation

11
tests/AgentTests/FunctionalAPITests.hs
View File

@@ -14,7 +14,6 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-orphans #-}
{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
module AgentTests.FunctionalAPITests
( functionalAPITests,
@@ -575,13 +574,13 @@ testEnablePQEncryption =
-- switched to smaller envelopes (before reporting PQ encryption enabled)
sml <- largeMsg g PQSupportOn
-- fail because of message size
Left (A.CMD LARGE) <- tryError $ A.sendMessage ca bId PQEncOn SMP.noMsgFlags lrg
Left (A.CMD LARGE _) <- tryError $ A.sendMessage ca bId PQEncOn SMP.noMsgFlags lrg
(9, PQEncOff) <- A.sendMessage ca bId PQEncOn SMP.noMsgFlags sml
get ca =##> \case ("", connId, SENT 9) -> connId == bId; _ -> False
get cb =##> \case ("", connId, MsgErr' 8 MsgSkipped {} PQEncOff msg') -> connId == aId && msg' == sml; _ -> False
ackMessage cb aId 8 Nothing
-- -- fail in reply to sync IDss
Left (A.CMD LARGE) <- tryError $ A.sendMessage cb aId PQEncOn SMP.noMsgFlags lrg
Left (A.CMD LARGE _) <- tryError $ A.sendMessage cb aId PQEncOn SMP.noMsgFlags lrg
(10, PQEncOff) <- A.sendMessage cb aId PQEncOn SMP.noMsgFlags sml
get cb =##> \case ("", connId, SENT 10) -> connId == aId; _ -> False
get ca =##> \case ("", connId, MsgErr' 10 MsgSkipped {} PQEncOff msg') -> connId == bId && msg' == sml; _ -> False
@@ -608,8 +607,8 @@ testEnablePQEncryption =
(b, 26, sml) \#>\ a
(a, 27, sml) \#>\ b
-- PQ encryption is now disabled, but support remained enabled, so we still cannot send larger messages
Left (A.CMD LARGE) <- tryError $ A.sendMessage ca bId PQEncOff SMP.noMsgFlags (sml <> "123456")
Left (A.CMD LARGE) <- tryError $ A.sendMessage cb aId PQEncOff SMP.noMsgFlags (sml <> "123456")
Left (A.CMD LARGE _) <- tryError $ A.sendMessage ca bId PQEncOff SMP.noMsgFlags (sml <> "123456")
Left (A.CMD LARGE _) <- tryError $ A.sendMessage cb aId PQEncOff SMP.noMsgFlags (sml <> "123456")
pure ()
where
(\#>\) = PQEncOff `sndRcv` PQEncOff
@@ -2480,7 +2479,7 @@ testDeliveryReceipts =
get a =##> \case ("", c, Msg "hello too") -> c == bId; _ -> False
ackMessage a bId 6 $ Just ""
get b =##> \case ("", c, Rcvd 6) -> c == aId; _ -> False
ackMessage b aId 7 (Just "") `catchError` \e -> liftIO $ e `shouldBe` A.CMD PROHIBITED
ackMessage b aId 7 (Just "") `catchError` \case (A.CMD PROHIBITED _) -> pure (); e -> liftIO $ expectationFailure ("unexpected error " <> show e)
ackMessage b aId 7 Nothing
testDeliveryReceiptsVersion :: HasCallStack => ATransport -> IO ()

5
tests/AgentTests/NotificationTests.hs
View File

@@ -7,7 +7,6 @@
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
module AgentTests.NotificationTests where
@@ -182,7 +181,7 @@ testNotificationToken APNSMockServer {apnsQ} = do
NTActive <- checkNtfToken a tkn
deleteNtfToken a tkn
-- agent deleted this token
Left (CMD PROHIBITED) <- tryE $ checkNtfToken a tkn
Left (CMD PROHIBITED _) <- tryE $ checkNtfToken a tkn
pure ()
(.->) :: J.Value -> J.Key -> ExceptT AgentErrorType IO ByteString
@@ -375,7 +374,7 @@ testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} alice@Agen
pure (bobId, aliceId, nonce, message)
-- alice client already has subscription for the connection
Left (CMD PROHIBITED) <- runExceptT $ getNotificationMessage alice nonce message
Left (CMD PROHIBITED _) <- runExceptT $ getNotificationMessage alice nonce message
-- aliceNtf client doesn't have subscription and is allowed to get notification message
withAgent 3 aliceCfg initAgentServers testDB $ \aliceNtf -> runRight_ $ do