diff --git a/package.yaml b/package.yaml index be2286377..8cd924b4e 100644 --- a/package.yaml +++ b/package.yaml @@ -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 diff --git a/simplexmq.cabal b/simplexmq.cabal index e0fb278a1..c61e68624 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -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.* diff --git a/src/Simplex/FileTransfer/Client.hs b/src/Simplex/FileTransfer/Client.hs index e4a64c0c9..ff7742e67 100644 --- a/src/Simplex/FileTransfer/Client.hs +++ b/src/Simplex/FileTransfer/Client.hs @@ -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 :: diff --git a/src/Simplex/FileTransfer/Client/Main.hs b/src/Simplex/FileTransfer/Client/Main.hs index b3fa494ed..0acc6d3c9 100644 --- a/src/Simplex/FileTransfer/Client/Main.hs +++ b/src/Simplex/FileTransfer/Client/Main.hs @@ -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 diff --git a/src/Simplex/FileTransfer/Server.hs b/src/Simplex/FileTransfer/Server.hs index 41c652ea2..ea18b4fdc 100644 --- a/src/Simplex/FileTransfer/Server.hs +++ b/src/Simplex/FileTransfer/Server.hs @@ -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 diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index 1ca92b2e1..bb6e52bad 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -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 :" <> 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 :" <> 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) diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index 0d0af894f..37f659c9f 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -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 diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index 1fc984ac5..0b40edee9 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -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) diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs index 04dd826a6..6c2c5906d 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs @@ -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 diff --git a/src/Simplex/Messaging/Crypto/Ratchet.hs b/src/Simplex/Messaging/Crypto/Ratchet.hs index db13fddc1..14f567820 100644 --- a/src/Simplex/Messaging/Crypto/Ratchet.hs +++ b/src/Simplex/Messaging/Crypto/Ratchet.hs @@ -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 diff --git a/src/Simplex/Messaging/Transport/HTTP2/Client.hs b/src/Simplex/Messaging/Transport/HTTP2/Client.hs index d701d4114..71757ca6d 100644 --- a/src/Simplex/Messaging/Transport/HTTP2/Client.hs +++ b/src/Simplex/Messaging/Transport/HTTP2/Client.hs @@ -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), diff --git a/src/Simplex/Messaging/Transport/HTTP2/File.hs b/src/Simplex/Messaging/Transport/HTTP2/File.hs index 10238f161..aef98acaa 100644 --- a/src/Simplex/Messaging/Transport/HTTP2/File.hs +++ b/src/Simplex/Messaging/Transport/HTTP2/File.hs @@ -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 diff --git a/src/Simplex/Messaging/Transport/Server.hs b/src/Simplex/Messaging/Transport/Server.hs index 145b438e0..495ad76bb 100644 --- a/src/Simplex/Messaging/Transport/Server.hs +++ b/src/Simplex/Messaging/Transport/Server.hs @@ -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 diff --git a/tests/AgentTests.hs b/tests/AgentTests.hs index 7a3077532..186c91e13 100644 --- a/tests/AgentTests.hs +++ b/tests/AgentTests.hs @@ -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 diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index 6e5e09fc3..250e95474 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -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 () diff --git a/tests/AgentTests/NotificationTests.hs b/tests/AgentTests/NotificationTests.hs index 348694f7e..a7c3fb25a 100644 --- a/tests/AgentTests/NotificationTests.hs +++ b/tests/AgentTests/NotificationTests.hs @@ -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