dandri/simplexmq
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplexmq.git synced 2026-07-18 20:27:31 +00:00
Code Issues Packages Projects Releases Wiki Activity

add fourmolu (#868)

Browse Source 
* add fourmolu

* linebreak

* simplify

* comment
This commit is contained in:
Evgeny Poberezkin
2023-10-22 09:20:14 +01:00
committed by GitHub
parent deb3fc7359
commit 9d12d76078
61 changed files with 462 additions and 452 deletions
Download Patch File Download Diff File Expand all files Collapse all files
fourmolu.yaml
+30
View File
@@ -0,0 +1,30 @@
indentation: 2
column-limit: none
function-arrows: trailing
comma-style: trailing
import-export-style: trailing
indent-wheres: true
record-brace-space: true
newlines-between-decls: 1
haddock-style: single-line
haddock-style-module: null
let-style: inline
in-style: right-align
single-constraint-parens: never
unicode: never
respectful: true
fixities:
- infixr 9 .
- infixr 8 .:, .:., .=
- infixr 6 <>
- infixr 5 ++
- infixl 4 <$>, <$, $>, <$$>, <$?>
- infixl 4 <*>, <*, *>, <**>
- infix 4 ==, /=
- infixr 3 &&
- infixl 3 <|>
- infixr 2 ||
- infixl 1 >>, >>=
- infixr 1 =<<, >=>, <=<
- infixr 0 $, $!
reexports: []
src/Simplex/FileTransfer/Agent.hs
+8 -9
View File
@@ -10,7 +10,6 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
module Simplex.FileTransfer.Agent
@@ -322,8 +321,8 @@ runXFTPSndPrepareWorker c doWork = do
if status /= SFSEncrypted -- status is SFSNew or SFSEncrypting
then do
fsEncPath <- toFSFilePath $ sndFileEncPath ppath
when (status == SFSEncrypting) $
whenM (doesFileExist fsEncPath) $ removeFile fsEncPath
when (status == SFSEncrypting) . whenM (doesFileExist fsEncPath) $
removeFile fsEncPath
withStore' c $ \db -> updateSndFileStatus db sndFileId SFSEncrypting
(digest, chunkSpecsDigests) <- encryptFileForUpload sndFile fsEncPath
withStore c $ \db -> do
@@ -441,11 +440,11 @@ runXFTPSndWorker c srv doWork = do
| length rcvIdsKeys > numRecipients = throwError $ INTERNAL "too many recipients"
| length rcvIdsKeys == numRecipients = pure cr
| otherwise = do
maxRecipients <- asks $ xftpMaxRecipientsPerRequest . config
let numRecipients' = min (numRecipients - length rcvIdsKeys) maxRecipients
rcvIdsKeys' <- agentXFTPAddRecipients c userId chunkDigest cr numRecipients'
cr' <- withStore' c $ \db -> addSndChunkReplicaRecipients db cr $ L.toList rcvIdsKeys'
addRecipients ch cr'
maxRecipients <- asks $ xftpMaxRecipientsPerRequest . config
let numRecipients' = min (numRecipients - length rcvIdsKeys) maxRecipients
rcvIdsKeys' <- agentXFTPAddRecipients c userId chunkDigest cr numRecipients'
cr' <- withStore' c $ \db -> addSndChunkReplicaRecipients db cr $ L.toList rcvIdsKeys'
addRecipients ch cr'
sndFileToDescrs :: SndFile -> m (ValidFileDescription 'FSender, [ValidFileDescription 'FRecipient])
sndFileToDescrs SndFile {digest = Nothing} = throwError $ INTERNAL "snd file has no digest"
sndFileToDescrs SndFile {chunks = []} = throwError $ INTERNAL "snd file has no chunks"
@@ -573,7 +572,7 @@ runXFTPDelWorker c srv doWork = do
withStore' c $ \db -> updateDeletedSndChunkReplicaDelay db deletedSndChunkReplicaId replicaDelay
atomically $ assertAgentForeground c
loop
retryDone e = delWorkerInternalError c deletedSndChunkReplicaId e
retryDone = delWorkerInternalError c deletedSndChunkReplicaId
deleteChunkReplica :: DeletedSndChunkReplica -> m ()
deleteChunkReplica replica@DeletedSndChunkReplica {userId, deletedSndChunkReplicaId} = do
agentXFTPDeleteChunk c userId replica
src/Simplex/FileTransfer/Client/Main.hs
+6 -7
View File
@@ -9,7 +9,6 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
module Simplex.FileTransfer.Client.Main
@@ -527,8 +526,8 @@ prepareChunkSizes size' = prepareSizes size'
(smallSize, bigSize)
| size' > size34 chunkSize3 = (chunkSize2, chunkSize3)
| otherwise = (chunkSize1, chunkSize2)
-- | size' > size34 chunkSize2 = (chunkSize1, chunkSize2)
-- | otherwise = (chunkSize0, chunkSize1)
-- | size' > size34 chunkSize2 = (chunkSize1, chunkSize2)
-- | otherwise = (chunkSize0, chunkSize1)
size34 sz = (fromIntegral sz * 3) `div` 4
prepareSizes 0 = []
prepareSizes size
@@ -571,11 +570,11 @@ withRetry retryCount = withRetry' retryCount . withExceptT (CLIError . show)
removeFD :: Bool -> FilePath -> IO ()
removeFD yes fd
| yes = do
removeFile fd
putStrLn $ "\nFile description " <> fd <> " is deleted."
removeFile fd
putStrLn $ "\nFile description " <> fd <> " is deleted."
| otherwise = do
y <- liftIO . getConfirmation $ "\nFile description " <> fd <> " can't be used again. Delete it"
when y $ removeFile fd
y <- liftIO . getConfirmation $ "\nFile description " <> fd <> " can't be used again. Delete it"
when y $ removeFile fd
getConfirmation :: String -> IO Bool
getConfirmation prompt = do
src/Simplex/FileTransfer/Crypto.hs
+6 -6
View File
@@ -46,12 +46,12 @@ encryptFile srcFile fileHdr key nonce fileSize' encSize encFile = do
encryptChunks_ get w (!sb, !len)
| len == 0 = pure sb
| otherwise = do
let chSize = min len 65536
ch <- liftIO $ get chSize
when (B.length ch /= fromIntegral chSize) $ throwError $ FTCEFileIOError "encrypting file: unexpected EOF"
let (ch', sb') = LC.sbEncryptChunk sb ch
liftIO $ B.hPut w ch'
encryptChunks_ get w (sb', len - chSize)
let chSize = min len 65536
ch <- liftIO $ get chSize
when (B.length ch /= fromIntegral chSize) $ throwError $ FTCEFileIOError "encrypting file: unexpected EOF"
let (ch', sb') = LC.sbEncryptChunk sb ch
liftIO $ B.hPut w ch'
encryptChunks_ get w (sb', len - chSize)
decryptChunks :: Int64 -> [FilePath] -> C.SbKey -> C.CbNonce -> (String -> ExceptT String IO CryptoFile) -> ExceptT FTCryptoError IO CryptoFile
decryptChunks _ [] _ _ _ = throwError $ FTCEInvalidHeader "empty"
src/Simplex/FileTransfer/Description.hs
+2 -3
View File
@@ -9,7 +9,6 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
module Simplex.FileTransfer.Description
@@ -242,9 +241,9 @@ instance (Integral a, Show a) => StrEncoding (FileSize a) where
instance (Integral a, Show a) => IsString (FileSize a) where
fromString = either error id . strDecode . B.pack
instance (FromField a) => FromField (FileSize a) where fromField f = FileSize <$> fromField f
instance FromField a => FromField (FileSize a) where fromField f = FileSize <$> fromField f
instance (ToField a) => ToField (FileSize a) where toField (FileSize s) = toField s
instance ToField a => ToField (FileSize a) where toField (FileSize s) = toField s
groupReplicasByServer :: FileSize Word32 -> [FileChunk] -> [[FileServerReplica]]
groupReplicasByServer defChunkSize =
src/Simplex/FileTransfer/Server.hs
+11 -11
View File
@@ -169,17 +169,17 @@ processRequest :: HTTP2Request -> M ()
processRequest HTTP2Request {sessionId, reqBody = body@HTTP2Body {bodyHead}, sendResponse}
| B.length bodyHead /= xftpBlockSize = sendXFTPResponse ("", "", FRErr BLOCK) Nothing
| otherwise = do
case xftpDecodeTransmission sessionId bodyHead of
Right (sig_, signed, (corrId, fId, cmdOrErr)) -> do
case cmdOrErr of
Right cmd -> do
verifyXFTPTransmission sig_ signed fId cmd >>= \case
VRVerified req -> uncurry send =<< processXFTPRequest body req
VRFailed -> send (FRErr AUTH) Nothing
Left e -> send (FRErr e) Nothing
where
send resp = sendXFTPResponse (corrId, fId, resp)
Left e -> sendXFTPResponse ("", "", FRErr e) Nothing
case xftpDecodeTransmission sessionId bodyHead of
Right (sig_, signed, (corrId, fId, cmdOrErr)) -> do
case cmdOrErr of
Right cmd -> do
verifyXFTPTransmission sig_ signed fId cmd >>= \case
VRVerified req -> uncurry send =<< processXFTPRequest body req
VRFailed -> send (FRErr AUTH) Nothing
Left e -> send (FRErr e) Nothing
where
send resp = sendXFTPResponse (corrId, fId, resp)
Left e -> sendXFTPResponse ("", "", FRErr e) Nothing
where
sendXFTPResponse :: (CorrId, XFTPFileId, FileResponse) -> Maybe ServerFile -> M ()
sendXFTPResponse (corrId, fId, resp) serverFile_ = do
src/Simplex/FileTransfer/Server/Env.hs
+1 -1
View File
@@ -26,7 +26,7 @@ import Simplex.FileTransfer.Server.StoreLog
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Protocol (BasicAuth, RcvPublicVerifyKey)
import Simplex.Messaging.Server.Expiration
import Simplex.Messaging.Transport.Server (loadFingerprint, loadTLSServerParams, TransportServerConfig)
import Simplex.Messaging.Transport.Server (TransportServerConfig, loadFingerprint, loadTLSServerParams)
import Simplex.Messaging.Util (tshow)
import System.IO (IOMode (..))
import UnliftIO.STM
src/Simplex/FileTransfer/Server/Main.hs
+5 -4
View File
@@ -19,7 +19,7 @@ import Options.Applicative
import Simplex.FileTransfer.Chunks
import Simplex.FileTransfer.Description (FileSize (..))
import Simplex.FileTransfer.Server (runXFTPServer)
import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..), defaultFileExpiration, defFileExpirationHours)
import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..), defFileExpirationHours, defaultFileExpiration)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), pattern XFTPServer)
@@ -143,9 +143,10 @@ xftpServerCLI cfgPath logPath = do
allowNewFiles = fromMaybe True $ iniOnOff "AUTH" "new_files" ini,
newFileBasicAuth = either error id <$> strDecodeIni "AUTH" "create_password" ini,
fileExpiration =
Just defaultFileExpiration
{ ttl = 3600 * readIniDefault defFileExpirationHours "STORE_LOG" "expire_files_hours" ini
},
Just
defaultFileExpiration
{ ttl = 3600 * readIniDefault defFileExpirationHours "STORE_LOG" "expire_files_hours" ini
},
caCertificateFile = c caCrtFile,
privateKeyFile = c serverKeyFile,
certificateFile = c serverCrtFile,
src/Simplex/FileTransfer/Transport.hs
+4 -5
View File
@@ -1,7 +1,6 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Simplex.FileTransfer.Transport
@@ -26,8 +25,8 @@ import Data.Word (Word32)
import Simplex.FileTransfer.Protocol (XFTPErrorType (..))
import qualified Simplex.Messaging.Crypto as C
import qualified Simplex.Messaging.Crypto.Lazy as LC
import Simplex.Messaging.Version
import Simplex.Messaging.Transport.HTTP2.File
import Simplex.Messaging.Version
import System.IO (Handle, IOMode (..), withFile)
data XFTPRcvChunkSpec = XFTPRcvChunkSpec
@@ -64,8 +63,8 @@ receiveEncFile getBody = receiveFile_ . receive
ch <- getBody fileBlockSize
let chSize = fromIntegral $ B.length ch
if
| chSize > sz + authSz -> pure $ Left SIZE
| chSize > 0 -> do
| chSize > sz + authSz -> pure $ Left SIZE
| chSize > 0 -> do
let (ch', rest) = B.splitAt (fromIntegral sz) ch
(decCh, sbState') = LC.sbDecryptChunk sbState ch'
sz' = sz - fromIntegral (B.length ch')
@@ -78,7 +77,7 @@ receiveEncFile getBody = receiveFile_ . receive
tag = LC.sbAuth sbState'
tag'' <- if tagSz == C.authTagSize then pure tag' else (tag' <>) <$> getBody (C.authTagSize - tagSz)
pure $ if BA.constEq tag'' tag then Right () else Left CRYPTO
| otherwise -> pure $ Left SIZE
| otherwise -> pure $ Left SIZE
authSz = fromIntegral C.authTagSize
receiveFile_ :: (Handle -> Word32 -> IO (Either XFTPErrorType ())) -> XFTPRcvChunkSpec -> ExceptT XFTPErrorType IO ()
src/Simplex/Messaging/Agent.hs
+100 -101
View File
@@ -14,7 +14,6 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
-- |
@@ -151,7 +150,7 @@ import Simplex.Messaging.Notifications.Protocol (DeviceToken, NtfRegCode (NtfReg
import Simplex.Messaging.Notifications.Server.Push.APNS (PNMessageData (..))
import Simplex.Messaging.Notifications.Types
import Simplex.Messaging.Parsers (parse)
import Simplex.Messaging.Protocol (BrokerMsg, EntityId, ErrorType (AUTH), MsgBody, MsgFlags (..), NtfServer, ProtoServerWithAuth, ProtocolTypeI (..), SubscriptionMode (..), SMPMsgMeta, SProtocolType (..), SndPublicVerifyKey, UserProtocol, XFTPServerWithAuth)
import Simplex.Messaging.Protocol (BrokerMsg, EntityId, ErrorType (AUTH), MsgBody, MsgFlags (..), NtfServer, ProtoServerWithAuth, ProtocolTypeI (..), SMPMsgMeta, SProtocolType (..), SndPublicVerifyKey, SubscriptionMode (..), UserProtocol, XFTPServerWithAuth)
import qualified Simplex.Messaging.Protocol as SMP
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Util
@@ -462,8 +461,8 @@ deleteUser' c userId delSMPQueues = do
atomically $ TM.delete userId $ smpServers c
where
delUser =
whenM (withStore' c (`deleteUserWithoutConns` userId)) $
atomically $ writeTBQueue (subQ c) ("", "", APC SAENone $ DEL_USER userId)
whenM (withStore' c (`deleteUserWithoutConns` userId)) . atomically $
writeTBQueue (subQ c) ("", "", APC SAENone $ DEL_USER userId)
newConnAsync :: forall m c. (AgentMonad m, ConnectionModeI c) => AgentClient -> UserId -> ACorrId -> Bool -> SConnectionMode c -> SubscriptionMode -> m ConnId
newConnAsync c userId corrId enableNtfs cMode subMode = do
@@ -554,11 +553,11 @@ switchConnectionAsync' c corrId connId =
SomeConn _ (DuplexConnection cData rqs@(rq :| _rqs) sqs)
| isJust (switchingRQ rqs) -> throwError $ CMD PROHIBITED
| otherwise -> do
when (ratchetSyncSendProhibited cData) $ throwError $ CMD 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
when (ratchetSyncSendProhibited cData) $ throwError $ CMD 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
newConn :: AgentMonad m => AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> Maybe CRClientData -> SubscriptionMode -> m (ConnId, ConnectionRequestUri c)
@@ -813,15 +812,15 @@ getNotificationMessage' c nonce encNtfInfo = do
where
getNtfMessages ntfConnId maxMs nMeta ms
| length ms < maxMs =
getConnectionMessage' c ntfConnId >>= \case
Just m@SMP.SMPMsgMeta {msgId, msgTs, msgFlags} -> case nMeta of
Just SMP.NMsgMeta {msgId = msgId', msgTs = msgTs'}
| msgId == msgId' || msgTs > msgTs' -> pure $ reverse (m : ms)
| otherwise -> getMsg (m : ms)
_
| SMP.notification msgFlags -> pure $ reverse (m : ms)
| otherwise -> getMsg (m : ms)
_ -> pure $ reverse ms
getConnectionMessage' c ntfConnId >>= \case
Just m@SMP.SMPMsgMeta {msgId, msgTs, msgFlags} -> case nMeta of
Just SMP.NMsgMeta {msgId = msgId', msgTs = msgTs'}
| msgId == msgId' || msgTs > msgTs' -> pure $ reverse (m : ms)
| otherwise -> getMsg (m : ms)
_
| SMP.notification msgFlags -> pure $ reverse (m : ms)
| otherwise -> getMsg (m : ms)
_ -> pure $ reverse ms
| otherwise = pure $ reverse ms
where
getMsg = getNtfMessages ntfConnId maxMs nMeta
@@ -962,12 +961,12 @@ runCommandProcessing c@AgentClient {subQ} server_ = do
Just (rq'@RcvQueue {primary}, rq'' : rqs')
| primary -> internalErr "ICQDelete: cannot delete primary rcv queue"
| otherwise -> do
checkRQSwchStatus rq' RSReceivedMessage
tryError (deleteQueue c rq') >>= \case
Right () -> finalizeSwitch
Left e
| temporaryOrHostError e -> throwError e
| otherwise -> finalizeSwitch >> throwError e
checkRQSwchStatus rq' RSReceivedMessage
tryError (deleteQueue c rq') >>= \case
Right () -> finalizeSwitch
Left e
| temporaryOrHostError e -> throwError e
| otherwise -> finalizeSwitch >> throwError e
where
finalizeSwitch = do
withStore' c $ \db -> deleteConnRcvQueue db rq'
@@ -1123,7 +1122,7 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} cData@ConnData {userId, connId, dupl
-- because the queue must be secured by the time the confirmation or the first HELLO is received
| duplexHandshake == Just True -> connErr
| otherwise ->
ifM (msgExpired helloTimeout) connErr (retrySndMsg RIFast)
ifM (msgExpired helloTimeout) connErr (retrySndMsg RIFast)
where
connErr = case rq_ of
-- party initiating connection
@@ -1143,8 +1142,8 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} cData@ConnData {userId, connId, dupl
-- for other operations BROKER HOST is treated as a permanent error (e.g., when connecting to the server),
-- the message sending would be retried
| temporaryOrHostError e -> do
let timeoutSel = if msgType == AM_HELLO_ then helloTimeout else messageTimeout
ifM (msgExpired timeoutSel) (notifyDel msgId err) (retrySndMsg RIFast)
let timeoutSel = if msgType == AM_HELLO_ then helloTimeout else messageTimeout
ifM (msgExpired timeoutSel) (notifyDel msgId err) (retrySndMsg RIFast)
| otherwise -> notifyDel msgId err
where
msgExpired timeoutSel = do
@@ -1286,9 +1285,9 @@ switchConnection' c connId =
SomeConn _ conn@(DuplexConnection cData rqs@(rq :| _rqs) _)
| isJust (switchingRQ rqs) -> throwError $ CMD PROHIBITED
| otherwise -> do
when (ratchetSyncSendProhibited cData) $ throwError $ CMD PROHIBITED
rq' <- withStore' c $ \db -> setRcvSwitchStatus db rq $ Just RSSwitchStarted
switchDuplexConnection c conn rq'
when (ratchetSyncSendProhibited cData) $ throwError $ CMD PROHIBITED
rq' <- withStore' c $ \db -> setRcvSwitchStatus db rq $ Just RSSwitchStarted
switchDuplexConnection c conn rq'
_ -> throwError $ CMD PROHIBITED
switchDuplexConnection :: AgentMonad m => AgentClient -> Connection 'CDuplex -> RcvQueue -> m ConnectionStats
@@ -1314,19 +1313,19 @@ abortConnectionSwitch' c connId =
SomeConn _ (DuplexConnection cData rqs sqs) -> case switchingRQ rqs of
Just rq
| canAbortRcvSwitch rq -> do
when (ratchetSyncSendProhibited cData) $ throwError $ CMD PROHIBITED
-- multiple queues to which the connections switches were possible when repeating switch was allowed
let (delRqs, keepRqs) = L.partition (\q -> Just rq.dbQueueId == q.dbReplaceQueueId) rqs
case L.nonEmpty keepRqs of
Just rqs' -> do
rq' <- withStore' c $ \db -> do
mapM_ (setRcvQueueDeleted db) delRqs
setRcvSwitchStatus db rq Nothing
forM_ delRqs $ \RcvQueue {server, rcvId} -> enqueueCommand c "" connId (Just server) $ AInternalCommand $ ICDeleteRcvQueue rcvId
let rqs'' = updatedQs rq' rqs'
conn' = DuplexConnection cData rqs'' sqs
pure $ connectionStats conn'
_ -> throwError $ INTERNAL "won't delete all rcv queues in connection"
when (ratchetSyncSendProhibited cData) $ throwError $ CMD PROHIBITED
-- multiple queues to which the connections switches were possible when repeating switch was allowed
let (delRqs, keepRqs) = L.partition (\q -> Just rq.dbQueueId == q.dbReplaceQueueId) rqs
case L.nonEmpty keepRqs of
Just rqs' -> do
rq' <- withStore' c $ \db -> do
mapM_ (setRcvQueueDeleted db) delRqs
setRcvSwitchStatus db rq Nothing
forM_ delRqs $ \RcvQueue {server, rcvId} -> enqueueCommand c "" connId (Just server) $ AInternalCommand $ ICDeleteRcvQueue rcvId
let rqs'' = updatedQs rq' rqs'
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
@@ -1336,16 +1335,16 @@ synchronizeRatchet' c connId force = withConnLock c connId "synchronizeRatchet"
withStore c (`getConn` connId) >>= \case
SomeConn _ (DuplexConnection cData rqs sqs)
| ratchetSyncAllowed cData || force -> do
-- check queues are not switching?
AgentConfig {e2eEncryptVRange} <- asks config
(pk1, pk2, e2eParams@(CR.E2ERatchetParams _ k1 k2)) <- liftIO . CR.generateE2EParams $ maxVersion e2eEncryptVRange
void $ enqueueRatchetKeyMsgs c cData sqs e2eParams
withStore' c $ \db -> do
setConnRatchetSync db connId RSStarted
setRatchetX3dhKeys db connId pk1 pk2 k1 k2
let cData' = cData {ratchetSyncState = RSStarted} :: ConnData
conn' = DuplexConnection cData' rqs sqs
pure $ connectionStats conn'
-- check queues are not switching?
AgentConfig {e2eEncryptVRange} <- asks config
(pk1, pk2, e2eParams@(CR.E2ERatchetParams _ k1 k2)) <- liftIO . CR.generateE2EParams $ maxVersion e2eEncryptVRange
void $ enqueueRatchetKeyMsgs c cData sqs e2eParams
withStore' c $ \db -> do
setConnRatchetSync db connId RSStarted
setRatchetX3dhKeys db connId pk1 pk2 k1 k2
let cData' = cData {ratchetSyncState = RSStarted} :: ConnData
conn' = DuplexConnection cData' rqs sqs
pure $ connectionStats conn'
| otherwise -> throwError $ CMD PROHIBITED
_ -> throwError $ CMD PROHIBITED
@@ -1521,23 +1520,23 @@ registerNtfToken' c suppliedDeviceToken suppliedNtfMode =
-- possible improvement: add minimal time before repeat registration
(Just tknId, Nothing)
| savedDeviceToken == suppliedDeviceToken ->
when (ntfTknStatus == NTRegistered) (registerToken tkn) $> NTRegistered
when (ntfTknStatus == NTRegistered) (registerToken tkn) $> NTRegistered
| otherwise -> replaceToken tknId
(Just tknId, Just (NTAVerify code))
| savedDeviceToken == suppliedDeviceToken ->
t tkn (NTActive, Just NTACheck) $ agentNtfVerifyToken c tknId tkn code
t tkn (NTActive, Just NTACheck) $ agentNtfVerifyToken c tknId tkn code
| otherwise -> replaceToken tknId
(Just tknId, Just NTACheck)
| savedDeviceToken == suppliedDeviceToken -> do
ns <- asks ntfSupervisor
atomically $ nsUpdateToken ns tkn {ntfMode = suppliedNtfMode}
when (ntfTknStatus == NTActive) $ do
cron <- asks $ ntfCron . config
agentNtfEnableCron c tknId tkn cron
when (suppliedNtfMode == NMInstant) $ initializeNtfSubs c
when (suppliedNtfMode == NMPeriodic && savedNtfMode == NMInstant) $ deleteNtfSubs c NSCDelete
-- possible improvement: get updated token status from the server, or maybe TCRON could return the current status
pure ntfTknStatus
ns <- asks ntfSupervisor
atomically $ nsUpdateToken ns tkn {ntfMode = suppliedNtfMode}
when (ntfTknStatus == NTActive) $ do
cron <- asks $ ntfCron . config
agentNtfEnableCron c tknId tkn cron
when (suppliedNtfMode == NMInstant) $ initializeNtfSubs c
when (suppliedNtfMode == NMPeriodic && savedNtfMode == NMInstant) $ deleteNtfSubs c NSCDelete
-- possible improvement: get updated token status from the server, or maybe TCRON could return the current status
pure ntfTknStatus
| otherwise -> replaceToken tknId
(Just tknId, Just NTADelete) -> do
agentNtfDeleteToken c tknId tkn
@@ -1647,10 +1646,10 @@ toggleConnectionNtfs' c connId enable = do
toggle cData
| enableNtfs cData == enable = pure ()
| otherwise = do
withStore' c $ \db -> setConnectionNtfs db connId enable
ns <- asks ntfSupervisor
let cmd = if enable then NSCCreate else NSCDelete
atomically $ sendNtfSubCommand ns (connId, cmd)
withStore' c $ \db -> setConnectionNtfs db connId enable
ns <- asks ntfSupervisor
let cmd = if enable then NSCCreate else NSCDelete
atomically $ sendNtfSubCommand ns (connId, cmd)
deleteToken_ :: AgentMonad m => AgentClient -> NtfToken -> m ()
deleteToken_ c tkn@NtfToken {ntfTokenId, ntfTknStatus} = do
@@ -1912,11 +1911,11 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
resetRatchetSync :: m (Connection c)
resetRatchetSync
| rss `notElem` ([RSOk, RSStarted] :: [RatchetSyncState]) = do
let cData'' = (toConnData conn') {ratchetSyncState = RSOk} :: ConnData
conn'' = updateConnection cData'' conn'
notify . RSYNC RSOk Nothing $ connectionStats conn''
withStore' c $ \db -> setConnRatchetSync db connId RSOk
pure conn''
let cData'' = (toConnData conn') {ratchetSyncState = RSOk} :: ConnData
conn'' = updateConnection cData'' conn'
notify . RSYNC RSOk Nothing $ connectionStats conn''
withStore' c $ \db -> setConnRatchetSync db connId RSOk
pure conn''
| otherwise = pure conn'
Right _ -> prohibited >> ack
Left e@(AGENT A_DUPLICATE) -> do
@@ -1924,11 +1923,11 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
Just RcvMsg {internalId, msgMeta, msgBody = agentMsgBody, userAck}
| userAck -> ackDel internalId
| otherwise -> do
liftEither (parse smpP (AGENT A_MESSAGE) agentMsgBody) >>= \case
AgentMessage _ (A_MSG body) -> do
logServer "<--" c srv rId "MSG <MSG>"
notify $ MSG msgMeta msgFlags body
_ -> pure ()
liftEither (parse smpP (AGENT A_MESSAGE) agentMsgBody) >>= \case
AgentMessage _ (A_MSG body) -> do
logServer "<--" c srv rId "MSG <MSG>"
notify $ MSG msgMeta msgFlags body
_ -> pure ()
_ -> checkDuplicateHash e encryptedMsgHash >> ack
Left (AGENT (A_CRYPTO e)) -> do
exists <- withStore' c $ \db -> checkRcvMsgHashExists db connId encryptedMsgHash
@@ -1976,9 +1975,9 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
case msgAVRange `compatibleVersion` aVRange of
Just (Compatible av)
| av > connAgentVersion -> do
withStore' c $ \db -> setConnAgentVersion db connId av
let cData'' = cData' {connAgentVersion = av} :: ConnData
pure $ updateConnection cData'' conn'
withStore' c $ \db -> setConnAgentVersion db connId av
let cData'' = cData' {connAgentVersion = av} :: ConnData
pure $ updateConnection cData'' conn'
| otherwise -> pure conn'
Nothing -> pure conn'
ack :: m ()
@@ -1994,9 +1993,9 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
processEND = \case
Just (Right clnt)
| sessId == sessionId clnt -> do
removeSubscription c connId
notify' END
pure "END"
removeSubscription c connId
notify' END
pure "END"
| otherwise -> ignored
_ -> ignored
ignored = pure "END from disconnected client - ignored"
@@ -2186,12 +2185,12 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
case findRQ (smpServer, senderId) rqs of
Just rq'@RcvQueue {rcvId, e2ePrivKey = dhPrivKey, smpClientVersion = cVer, status = status'}
| status' == New || status' == Confirmed -> do
checkRQSwchStatus rq RSSendingQADD
logServer "<--" c srv rId $ "MSG <QKEY> " <> logSecret senderId
let dhSecret = C.dh' dhPublicKey dhPrivKey
withStore' c $ \db -> setRcvQueueConfirmedE2E db rq' dhSecret $ min cVer cVer'
enqueueCommand c "" connId (Just smpServer) $ AInternalCommand $ ICQSecure rcvId senderKey
notify . SWITCH QDRcv SPConfirmed $ connectionStats conn'
checkRQSwchStatus rq RSSendingQADD
logServer "<--" c srv rId $ "MSG <QKEY> " <> logSecret senderId
let dhSecret = C.dh' dhPublicKey dhPrivKey
withStore' c $ \db -> setRcvQueueConfirmedE2E db rq' dhSecret $ min cVer cVer'
enqueueCommand c "" connId (Just smpServer) $ AInternalCommand $ ICQSecure rcvId senderKey
notify . SWITCH QDRcv SPConfirmed $ connectionStats conn'
| otherwise -> qError "QKEY: queue already secured"
_ -> qError "QKEY: queue address not found in connection"
where
@@ -2227,8 +2226,8 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
ereadyMsg rcPrev (DuplexConnection cData'@ConnData {lastExternalSndId} _ sqs) = do
let CR.Ratchet {rcSnd} = rcPrev
-- if ratchet was initialized as receiving, it means EREADY wasn't sent on key negotiation
when (isNothing rcSnd) $
void . enqueueMessages' c cData' sqs SMP.MsgFlags {notification = True} $ EREADY lastExternalSndId
when (isNothing rcSnd) . void $
enqueueMessages' c cData' sqs SMP.MsgFlags {notification = True} (EREADY lastExternalSndId)
smpInvitation :: Connection c -> ConnectionRequestUri 'CMInvitation -> ConnInfo -> m ()
smpInvitation conn' connReq@(CRInvitationUri crData _) cInfo = do
@@ -2267,9 +2266,9 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
getSendRatchetKeys
| rss == RSStarted = withStore c (`getRatchetX3dhKeys'` connId)
| otherwise = do
(pk1, pk2, e2eParams@(CR.E2ERatchetParams _ k1 k2)) <- liftIO . CR.generateE2EParams $ version e2eOtherPartyParams
void $ enqueueRatchetKeyMsgs c cData' sqs e2eParams
pure (pk1, pk2, k1, k2)
(pk1, pk2, e2eParams@(CR.E2ERatchetParams _ k1 k2)) <- liftIO . CR.generateE2EParams $ version e2eOtherPartyParams
void $ enqueueRatchetKeyMsgs c cData' sqs e2eParams
pure (pk1, pk2, k1, k2)
notifyAgreed :: m ()
notifyAgreed = do
let cData'' = cData' {ratchetSyncState = RSAgreed} :: ConnData
@@ -2285,11 +2284,11 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s
initRatchet :: VersionRange -> (C.PrivateKeyX448, C.PrivateKeyX448, C.PublicKeyX448, C.PublicKeyX448) -> m ()
initRatchet e2eEncryptVRange (pk1, pk2, k1, k2)
| rkHash k1 k2 <= rkHashRcv = do
recreateRatchet $ CR.initRcvRatchet e2eEncryptVRange pk2 $ CR.x3dhRcv pk1 pk2 e2eOtherPartyParams
recreateRatchet $ CR.initRcvRatchet e2eEncryptVRange pk2 $ CR.x3dhRcv pk1 pk2 e2eOtherPartyParams
| otherwise = do
(_, rcDHRs) <- liftIO C.generateKeyPair'
recreateRatchet $ CR.initSndRatchet e2eEncryptVRange k2Rcv rcDHRs $ CR.x3dhSnd pk1 pk2 e2eOtherPartyParams
void . enqueueMessages' c cData' sqs SMP.MsgFlags {notification = True} $ EREADY lastExternalSndId
(_, rcDHRs) <- liftIO C.generateKeyPair'
recreateRatchet $ CR.initSndRatchet e2eEncryptVRange k2Rcv rcDHRs $ CR.x3dhSnd pk1 pk2 e2eOtherPartyParams
void . enqueueMessages' c cData' sqs SMP.MsgFlags {notification = True} $ EREADY lastExternalSndId
checkMsgIntegrity :: PrevExternalSndId -> ExternalSndId -> PrevRcvMsgHash -> ByteString -> MsgIntegrity
checkMsgIntegrity prevExtSndId extSndId internalPrevMsgHash receivedPrevMsgHash
@@ -2347,8 +2346,8 @@ mkAgentConfirmation :: AgentMonad m => Compatible Version -> AgentClient -> Conn
mkAgentConfirmation (Compatible agentVersion) c cData sq srv connInfo subMode
| agentVersion == 1 = pure $ AgentConnInfo connInfo
| otherwise = do
qInfo <- createReplyQueue c cData sq subMode srv
pure $ AgentConnInfoReply (qInfo :| []) connInfo
qInfo <- createReplyQueue c cData sq subMode srv
pure $ AgentConnInfoReply (qInfo :| []) connInfo
enqueueConfirmation :: AgentMonad m => AgentClient -> ConnData -> SndQueue -> ConnInfo -> Maybe (CR.E2ERatchetParams 'C.X448) -> m ()
enqueueConfirmation c cData sq connInfo e2eEncryption_ = do
src/Simplex/Messaging/Agent/Client.hs
+7 -7
View File
@@ -741,7 +741,7 @@ data ProtocolTestFailure = ProtocolTestFailure
deriving (Eq, Show, Generic, FromJSON)
instance ToJSON ProtocolTestFailure where toEncoding = J.genericToEncoding J.defaultOptions
runSMPServerTest :: AgentMonad m => AgentClient -> UserId -> SMPServerWithAuth -> m (Maybe ProtocolTestFailure)
runSMPServerTest c userId (ProtoServerWithAuth srv auth) = do
cfg <- getClientConfig c smpCfg
@@ -901,8 +901,8 @@ subscribeQueues c qs = do
subscribeQueues_ u smp qs' = do
rs <- sendBatch subscribeSMPQueues smp qs'
mapM_ (uncurry $ processSubResult c) rs
when (any temporaryClientError . lefts . map snd $ L.toList rs) $
unliftIO u $ reconnectServer c $ transportSession' smp
when (any temporaryClientError . lefts . map snd $ L.toList rs) . unliftIO u $
reconnectServer c (transportSession' smp)
pure rs
type BatchResponses e r = (NonEmpty (RcvQueue, Either e r))
@@ -989,7 +989,7 @@ sendInvitation c userId (Compatible (SMPQueueInfo v SMPQueueAddress {smpServer,
mkInvitation = do
let agentEnvelope = AgentInvitation {agentVersion, connReq, connInfo}
agentCbEncryptOnce v dhPublicKey . smpEncode $
SMP.ClientMessage SMP.PHEmpty $ smpEncode agentEnvelope
SMP.ClientMessage SMP.PHEmpty (smpEncode agentEnvelope)
getQueueMessage :: AgentMonad m => AgentClient -> RcvQueue -> m (Maybe SMPMsgMeta)
getQueueMessage c rq@RcvQueue {server, rcvId, rcvPrivateKey} = do
@@ -1324,7 +1324,7 @@ userServers c = case protocolTypeI @p of
SPSMP -> smpServers c
SPXFTP -> xftpServers c
pickServer :: forall p m. (AgentMonad' m) => NonEmpty (ProtoServerWithAuth p) -> m (ProtoServerWithAuth p)
pickServer :: forall p m. AgentMonad' m => NonEmpty (ProtoServerWithAuth p) -> m (ProtoServerWithAuth p)
pickServer = \case
srv :| [] -> pure srv
servers -> do
@@ -1343,7 +1343,7 @@ withUserServers c userId action =
Just srvs -> action srvs
_ -> throwError $ INTERNAL "unknown userId - no user servers"
withNextSrv :: forall p m a. (ProtocolTypeI p, UserProtocol p, AgentMonad m) => AgentClient -> UserId -> TVar [ProtocolServer p] -> [ProtocolServer p] -> ((ProtoServerWithAuth p) -> m a) -> m a
withNextSrv :: forall p m a. (ProtocolTypeI p, UserProtocol p, AgentMonad m) => AgentClient -> UserId -> TVar [ProtocolServer p] -> [ProtocolServer p] -> (ProtoServerWithAuth p -> m a) -> m a
withNextSrv c userId usedSrvs initUsed action = do
used <- readTVarIO usedSrvs
srvAuth@(ProtoServerWithAuth srv _) <- getNextServer c userId used
@@ -1382,6 +1382,6 @@ getAgentSubscriptions c = do
getSubs sel = map (`subInfo` Nothing) . M.keys <$> readTVarIO (getRcvQueues $ sel c)
getRemovedSubs = map (uncurry subInfo . second Just) . M.assocs <$> readTVarIO (removedSubs c)
subInfo :: (UserId, SMPServer, SMP.RecipientId) -> Maybe SMPClientError -> SubInfo
subInfo (uId, srv, rId) err = SubInfo {userId = uId, server = enc srv, rcvId = enc rId, subError = show <$> err}
subInfo (uId, srv, rId) err = SubInfo {userId = uId, server = enc srv, rcvId = enc rId, subError = show <$> err}
enc :: StrEncoding a => a -> Text
enc = decodeLatin1 . strEncode
src/Simplex/Messaging/Agent/Lock.hs
-2
View File
@@ -1,5 +1,3 @@
{-# LANGUAGE NamedFieldPuns #-}
module Simplex.Messaging.Agent.Lock where
import Control.Monad (void)
src/Simplex/Messaging/Agent/NtfSubSupervisor.hs
+12 -13
View File
@@ -5,7 +5,6 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
module Simplex.Messaging.Agent.NtfSubSupervisor
@@ -100,14 +99,14 @@ processNtfSub c (connId, cmd) = do
Just (action, _)
-- subscription was marked for deletion / is being deleted
| isDeleteNtfSubAction action -> do
if ntfSubStatus == NASNew || ntfSubStatus == NASOff || ntfSubStatus == NASDeleted
then resetSubscription
else withNtfServer c $ \ntfServer -> do
withStore' c $ \db -> supervisorUpdateNtfSub db sub {ntfServer} (NtfSubNTFAction NSACreate)
addNtfNTFWorker ntfServer
if ntfSubStatus == NASNew || ntfSubStatus == NASOff || ntfSubStatus == NASDeleted
then resetSubscription
else withNtfServer c $ \ntfServer -> do
withStore' c $ \db -> supervisorUpdateNtfSub db sub {ntfServer} (NtfSubNTFAction NSACreate)
addNtfNTFWorker ntfServer
| otherwise -> case action of
NtfSubNTFAction _ -> addNtfNTFWorker subNtfServer
NtfSubSMPAction _ -> addNtfSMPWorker smpServer
NtfSubNTFAction _ -> addNtfNTFWorker subNtfServer
NtfSubSMPAction _ -> addNtfSMPWorker smpServer
rotate :: m ()
rotate = do
withStore' c $ \db -> supervisorUpdateNtfSub db sub (NtfSubNTFAction NSARotate)
@@ -291,11 +290,11 @@ rescheduleAction :: AgentMonad' m => TMVar () -> UTCTime -> UTCTime -> m Bool
rescheduleAction doWork ts actionTs
| actionTs <= ts = pure False
| otherwise = do
void . atomically $ tryTakeTMVar doWork
void . forkIO $ do
liftIO $ threadDelay' $ diffToMicroseconds $ diffUTCTime actionTs ts
void . atomically $ tryPutTMVar doWork ()
pure True
void . atomically $ tryTakeTMVar doWork
void . forkIO $ do
liftIO $ threadDelay' $ diffToMicroseconds $ diffUTCTime actionTs ts
void . atomically $ tryPutTMVar doWork ()
pure True
retryOnError :: AgentMonad' m => AgentClient -> Text -> m () -> (AgentErrorType -> m ()) -> AgentErrorType -> m ()
retryOnError c name loop done e = do
src/Simplex/Messaging/Agent/Protocol.hs
+3 -3
View File
@@ -622,7 +622,7 @@ instance FromJSON RcvQueueInfo where parseJSON = J.genericParseJSON J.defaultOpt
instance StrEncoding RcvQueueInfo where
strEncode RcvQueueInfo {rcvServer, rcvSwitchStatus, canAbortSwitch} =
"srv=" <> strEncode rcvServer
("srv=" <> strEncode rcvServer)
<> maybe "" (\switch -> ";switch=" <> strEncode switch) rcvSwitchStatus
<> (";can_abort_switch=" <> strEncode canAbortSwitch)
strP = do
@@ -662,7 +662,7 @@ instance ToJSON ConnectionStats where toEncoding = J.genericToEncoding J.default
instance StrEncoding ConnectionStats where
strEncode ConnectionStats {connAgentVersion, rcvQueuesInfo, sndQueuesInfo, ratchetSyncState, ratchetSyncSupported} =
"agent_version=" <> strEncode connAgentVersion
("agent_version=" <> strEncode connAgentVersion)
<> (" rcv=" <> strEncodeList rcvQueuesInfo)
<> (" snd=" <> strEncodeList sndQueuesInfo)
<> (" sync=" <> strEncode ratchetSyncState)
@@ -1048,7 +1048,7 @@ instance StrEncoding MsgReceiptStatus where
MROk -> "ok"
MRBadMsgHash -> "badMsgHash"
strP =
A.takeWhile1 (/= ' ') >>= \ case
A.takeWhile1 (/= ' ') >>= \case
"ok" -> pure MROk
"badMsgHash" -> pure MRBadMsgHash
_ -> fail "bad MsgReceiptStatus"
src/Simplex/Messaging/Agent/RetryInterval.hs
-1
View File
@@ -1,6 +1,5 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Simplex.Messaging.Agent.RetryInterval
src/Simplex/Messaging/Agent/Server.hs
+1 -1
View File
@@ -23,7 +23,7 @@ import Simplex.Messaging.Agent.Env.SQLite
import Simplex.Messaging.Agent.Protocol
import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore)
import Simplex.Messaging.Transport (ATransport (..), TProxy, Transport (..), simplexMQVersion)
import Simplex.Messaging.Transport.Server (loadTLSServerParams, runTransportServer, defaultTransportServerConfig)
import Simplex.Messaging.Transport.Server (defaultTransportServerConfig, loadTLSServerParams, runTransportServer)
import Simplex.Messaging.Util (bshow)
import UnliftIO.Async (race_)
import qualified UnliftIO.Exception as E
src/Simplex/Messaging/Agent/Store/SQLite.hs
+30 -31
View File
@@ -20,9 +20,8 @@
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Simplex.Messaging.Agent.Store.SQLite
( SQLiteStore (..),
@@ -277,7 +276,7 @@ import System.Directory (copyFile, createDirectoryIfMissing, doesFileExist)
import System.Exit (exitFailure)
import System.FilePath (takeDirectory)
import System.IO (hFlush, stdout)
import UnliftIO.Exception (onException, bracketOnError)
import UnliftIO.Exception (bracketOnError, onException)
import qualified UnliftIO.Exception as E
import UnliftIO.STM
@@ -347,10 +346,10 @@ migrateSchema st migrations confirmMigrations = do
Right ms@(MTRUp ums)
| dbNew st -> Migrations.run st ms $> Right ()
| otherwise -> case confirmMigrations of
MCYesUp -> run ms
MCYesUpDown -> run ms
MCConsole -> confirm err >> run ms
MCError -> pure $ Left err
MCYesUp -> run ms
MCYesUpDown -> run ms
MCConsole -> confirm err >> run ms
MCError -> pure $ Left err
where
err = MEUpgrade $ map upMigration ums -- "The app has a newer version than the database.\nConfirm to back up and upgrade using these migrations: " <> intercalate ", " (map name ums)
Right ms@(MTRDown dms) -> case confirmMigrations of
@@ -1079,12 +1078,12 @@ countPendingSndDeliveries_ db connId msgId = do
deleteRcvMsgHashesExpired :: DB.Connection -> NominalDiffTime -> IO ()
deleteRcvMsgHashesExpired db ttl = do
cutoffTs <- addUTCTime (- ttl) <$> getCurrentTime
cutoffTs <- addUTCTime (-ttl) <$> getCurrentTime
DB.execute db "DELETE FROM encrypted_rcv_message_hashes WHERE created_at < ?" (Only cutoffTs)
deleteSndMsgsExpired :: DB.Connection -> NominalDiffTime -> IO ()
deleteSndMsgsExpired db ttl = do
cutoffTs <- addUTCTime (- ttl) <$> getCurrentTime
cutoffTs <- addUTCTime (-ttl) <$> getCurrentTime
DB.execute
db
"DELETE FROM messages WHERE internal_ts < ? AND internal_snd_id IS NOT NULL"
@@ -1163,7 +1162,7 @@ getSkippedMsgKeys :: DB.Connection -> ConnId -> IO SkippedMsgKeys
getSkippedMsgKeys db connId =
skipped <$> DB.query db "SELECT header_key, msg_n, msg_key FROM skipped_messages WHERE conn_id = ?" (Only connId)
where
skipped ms = foldl' addSkippedKey M.empty ms
skipped = foldl' addSkippedKey M.empty
addSkippedKey smks (hk, msgN, mk) = M.alter (Just . addMsgKey) hk smks
where
addMsgKey = maybe (M.singleton msgN mk) (M.insert msgN mk)
@@ -1734,15 +1733,15 @@ getAnyConn deleted' dbConn connId =
Just (cData@ConnData {deleted}, cMode)
| deleted /= deleted' -> pure $ Left SEConnNotFound
| otherwise -> do
rQ <- getRcvQueuesByConnId_ dbConn connId
sQ <- getSndQueuesByConnId_ dbConn connId
pure $ case (rQ, sQ, cMode) of
(Just rqs, Just sqs, CMInvitation) -> Right $ SomeConn SCDuplex (DuplexConnection cData rqs sqs)
(Just (rq :| _), Nothing, CMInvitation) -> Right $ SomeConn SCRcv (RcvConnection cData rq)
(Nothing, Just (sq :| _), CMInvitation) -> Right $ SomeConn SCSnd (SndConnection cData sq)
(Just (rq :| _), Nothing, CMContact) -> Right $ SomeConn SCContact (ContactConnection cData rq)
(Nothing, Nothing, _) -> Right $ SomeConn SCNew (NewConnection cData)
_ -> Left SEConnNotFound
rQ <- getRcvQueuesByConnId_ dbConn connId
sQ <- getSndQueuesByConnId_ dbConn connId
pure $ case (rQ, sQ, cMode) of
(Just rqs, Just sqs, CMInvitation) -> Right $ SomeConn SCDuplex (DuplexConnection cData rqs sqs)
(Just (rq :| _), Nothing, CMInvitation) -> Right $ SomeConn SCRcv (RcvConnection cData rq)
(Nothing, Just (sq :| _), CMInvitation) -> Right $ SomeConn SCSnd (SndConnection cData sq)
(Just (rq :| _), Nothing, CMContact) -> Right $ SomeConn SCContact (ContactConnection cData rq)
(Nothing, Nothing, _) -> Right $ SomeConn SCNew (NewConnection cData)
_ -> Left SEConnNotFound
getConns :: DB.Connection -> [ConnId] -> IO [Either StoreError SomeConn]
getConns = getAnyConns_ False
@@ -1804,7 +1803,7 @@ checkRatchetKeyHashExists db connId hash = do
deleteRatchetKeyHashesExpired :: DB.Connection -> NominalDiffTime -> IO ()
deleteRatchetKeyHashesExpired db ttl = do
cutoffTs <- addUTCTime (- ttl) <$> getCurrentTime
cutoffTs <- addUTCTime (-ttl) <$> getCurrentTime
DB.execute db "DELETE FROM processed_ratchet_key_hashes WHERE created_at < ?" (Only cutoffTs)
-- | returns all connection queues, the first queue is the primary one
@@ -2253,7 +2252,7 @@ deleteRcvFile' db rcvFileId =
getNextRcvChunkToDownload :: DB.Connection -> XFTPServer -> NominalDiffTime -> IO (Maybe RcvFileChunk)
getNextRcvChunkToDownload db server@ProtocolServer {host, port, keyHash} ttl = do
cutoffTs <- addUTCTime (- ttl) <$> getCurrentTime
cutoffTs <- addUTCTime (-ttl) <$> getCurrentTime
maybeFirstRow toChunk $
DB.query
db
@@ -2290,7 +2289,7 @@ getNextRcvChunkToDownload db server@ProtocolServer {host, port, keyHash} ttl = d
getNextRcvFileToDecrypt :: DB.Connection -> NominalDiffTime -> IO (Maybe RcvFile)
getNextRcvFileToDecrypt db ttl = do
cutoffTs <- addUTCTime (- ttl) <$> getCurrentTime
cutoffTs <- addUTCTime (-ttl) <$> getCurrentTime
fileId_ :: Maybe DBRcvFileId <-
maybeFirstRow fromOnly $
DB.query
@@ -2308,7 +2307,7 @@ getNextRcvFileToDecrypt db ttl = do
getPendingRcvFilesServers :: DB.Connection -> NominalDiffTime -> IO [XFTPServer]
getPendingRcvFilesServers db ttl = do
cutoffTs <- addUTCTime (- ttl) <$> getCurrentTime
cutoffTs <- addUTCTime (-ttl) <$> getCurrentTime
map toXFTPServer
<$> DB.query
db
@@ -2350,7 +2349,7 @@ getCleanupRcvFilesDeleted db =
getRcvFilesExpired :: DB.Connection -> NominalDiffTime -> IO [(DBRcvFileId, RcvFileId, FilePath)]
getRcvFilesExpired db ttl = do
cutoffTs <- addUTCTime (- ttl) <$> getCurrentTime
cutoffTs <- addUTCTime (-ttl) <$> getCurrentTime
DB.query
db
[sql|
@@ -2458,7 +2457,7 @@ getChunkReplicaRecipients_ db replicaId =
getNextSndFileToPrepare :: DB.Connection -> NominalDiffTime -> IO (Maybe SndFile)
getNextSndFileToPrepare db ttl = do
cutoffTs <- addUTCTime (- ttl) <$> getCurrentTime
cutoffTs <- addUTCTime (-ttl) <$> getCurrentTime
fileId_ :: Maybe DBSndFileId <-
maybeFirstRow fromOnly $
DB.query
@@ -2539,7 +2538,7 @@ createSndFileReplica db SndFileChunk {sndChunkId} NewSndChunkReplica {server, re
getNextSndChunkToUpload :: DB.Connection -> XFTPServer -> NominalDiffTime -> IO (Maybe SndFileChunk)
getNextSndChunkToUpload db server@ProtocolServer {host, port, keyHash} ttl = do
cutoffTs <- addUTCTime (- ttl) <$> getCurrentTime
cutoffTs <- addUTCTime (-ttl) <$> getCurrentTime
chunk_ <-
maybeFirstRow toChunk $
DB.query
@@ -2608,7 +2607,7 @@ updateSndChunkReplicaStatus db replicaId status = do
getPendingSndFilesServers :: DB.Connection -> NominalDiffTime -> IO [XFTPServer]
getPendingSndFilesServers db ttl = do
cutoffTs <- addUTCTime (- ttl) <$> getCurrentTime
cutoffTs <- addUTCTime (-ttl) <$> getCurrentTime
map toXFTPServer
<$> DB.query
db
@@ -2647,7 +2646,7 @@ getCleanupSndFilesDeleted db =
getSndFilesExpired :: DB.Connection -> NominalDiffTime -> IO [(DBSndFileId, SndFileId, Maybe FilePath)]
getSndFilesExpired db ttl = do
cutoffTs <- addUTCTime (- ttl) <$> getCurrentTime
cutoffTs <- addUTCTime (-ttl) <$> getCurrentTime
DB.query
db
[sql|
@@ -2687,7 +2686,7 @@ getDeletedSndChunkReplica db deletedSndChunkReplicaId =
getNextDeletedSndChunkReplica :: DB.Connection -> XFTPServer -> NominalDiffTime -> IO (Maybe DeletedSndChunkReplica)
getNextDeletedSndChunkReplica db ProtocolServer {host, port, keyHash} ttl = do
cutoffTs <- addUTCTime (- ttl) <$> getCurrentTime
cutoffTs <- addUTCTime (-ttl) <$> getCurrentTime
replicaId_ :: Maybe Int64 <-
maybeFirstRow fromOnly $
DB.query
@@ -2716,7 +2715,7 @@ deleteDeletedSndChunkReplica db deletedSndChunkReplicaId =
getPendingDelFilesServers :: DB.Connection -> NominalDiffTime -> IO [XFTPServer]
getPendingDelFilesServers db ttl = do
cutoffTs <- addUTCTime (- ttl) <$> getCurrentTime
cutoffTs <- addUTCTime (-ttl) <$> getCurrentTime
map toXFTPServer
<$> DB.query
db
@@ -2731,5 +2730,5 @@ getPendingDelFilesServers db ttl = do
deleteDeletedSndChunkReplicasExpired :: DB.Connection -> NominalDiffTime -> IO ()
deleteDeletedSndChunkReplicasExpired db ttl = do
cutoffTs <- addUTCTime (- ttl) <$> getCurrentTime
cutoffTs <- addUTCTime (-ttl) <$> getCurrentTime
DB.execute db "DELETE FROM deleted_snd_chunk_replicas WHERE created_at < ?" (Only cutoffTs)
src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs
-1
View File
@@ -6,7 +6,6 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
module Simplex.Messaging.Agent.Store.SQLite.Migrations
src/Simplex/Messaging/Agent/TRcvQueues.hs
-1
View File
@@ -1,4 +1,3 @@
{-# LANGUAGE LambdaCase #-}
module Simplex.Messaging.Agent.TRcvQueues
( TRcvQueues (getRcvQueues),
empty,
src/Simplex/Messaging/Client.hs
+16 -16
View File
@@ -429,11 +429,11 @@ getProtocolClient transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize,
where
response entityId
| entityId == entId =
case respOrErr of
Left e -> Left $ PCEResponseError e
Right r -> case protocolError r of
Just e -> Left $ PCEProtocolError e
_ -> Right r
case respOrErr of
Left e -> Left $ PCEResponseError e
Right r -> case protocolError r of
Just e -> Left $ PCEProtocolError e
_ -> Right r
| otherwise = Left . PCEUnexpectedResponse $ bshow respOrErr
sendMsg :: Either err msg -> IO ()
sendMsg = \case
@@ -661,13 +661,13 @@ sendProtocolCommands c@ProtocolClient {batch, blockSize} cs = do
validate rs
| diff == 0 = pure $ L.fromList rs
| diff > 0 = do
putStrLn "send error: fewer responses than expected"
pure $ L.fromList $ rs <> replicate diff (Response "" $ Left $ PCETransportError TEBadBlock)
putStrLn "send error: fewer responses than expected"
pure $ L.fromList $ rs <> replicate diff (Response "" $ Left $ PCETransportError TEBadBlock)
| otherwise = do
putStrLn "send error: more responses than expected"
pure $ L.fromList $ take (L.length cs) rs
where
diff = L.length cs - length rs
putStrLn "send error: more responses than expected"
pure $ L.fromList $ take (L.length cs) rs
where
diff = L.length cs - length rs
streamProtocolCommands :: forall err msg. ProtocolEncoding err (ProtoCommand msg) => ProtocolClient err msg -> NonEmpty (ClientCommand msg) -> ([Response err msg] -> IO ()) -> IO ()
streamProtocolCommands c@ProtocolClient {batch, blockSize} cs cb = do
@@ -688,8 +688,8 @@ sendBatch c@ProtocolClient {client_ = PClient {sndQ}} b = do
(: []) <$> getResponse c r
data ClientBatch err msg
-- ByteString in CBTransmissions does not include count byte, it is added by tEncodeBatch
= CBTransmissions ByteString Int [Request err msg]
= -- ByteString in CBTransmissions does not include count byte, it is added by tEncodeBatch
CBTransmissions ByteString Int [Request err msg]
| CBTransmission ByteString (Request err msg)
| CBLargeTransmission (Request err msg)
@@ -713,9 +713,9 @@ batchClientTransmissions batch blkSize
encodeBatch :: ByteString -> Int -> [Request err msg] -> NonEmpty (PCTransmission err msg) -> (ClientBatch err msg, Maybe (NonEmpty (PCTransmission err msg)))
encodeBatch s n rs ts@((t, r) :| ts_)
| B.length s' <= blkSize - 3 && n < 255 =
case L.nonEmpty ts_ of
Just ts' -> encodeBatch s' n' rs' ts'
Nothing -> (CBTransmissions s' n' (reverse rs'), Nothing)
case L.nonEmpty ts_ of
Just ts' -> encodeBatch s' n' rs' ts'
Nothing -> (CBTransmissions s' n' (reverse rs'), Nothing)
| n == 0 = (CBLargeTransmission r, L.nonEmpty ts_)
| otherwise = (CBTransmissions s n (reverse rs), Just ts)
where
src/Simplex/Messaging/Client/Agent.hs
+14 -13
View File
@@ -18,7 +18,7 @@ import Control.Monad
import Control.Monad.Except
import Control.Monad.IO.Unlift
import Control.Monad.Trans.Except
import Data.Bifunctor (first, bimap)
import Data.Bifunctor (bimap, first)
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Either (partitionEithers)
@@ -36,11 +36,11 @@ import Simplex.Messaging.Agent.RetryInterval
import Simplex.Messaging.Client
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Protocol (BrokerMsg, ProtocolServer (..), QueueId, SMPServer, NtfPrivateSignKey, NotifierId, RcvPrivateSignKey, RecipientId)
import Simplex.Messaging.Protocol (BrokerMsg, NotifierId, NtfPrivateSignKey, ProtocolServer (..), QueueId, RcvPrivateSignKey, RecipientId, SMPServer)
import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport
import Simplex.Messaging.Util (catchAll_, ($>>=), toChunks)
import Simplex.Messaging.Util (catchAll_, toChunks, ($>>=))
import System.Timeout (timeout)
import UnliftIO (async)
import UnliftIO.Exception (Exception)
@@ -238,7 +238,7 @@ getSMPServerClient' ca@SMPClientAgent {agentCfg, smpClients, msgQ} srv =
(tempErrs, finalErrs) = partition (temporaryClientError . snd) errs
mapM_ (atomically . addSubscription ca srv) oks
mapM_ (liftIO . notify . CAResubscribed srv) $ L.nonEmpty $ map fst oks
mapM_ (atomically . removePendingSubscription ca srv . fst) finalErrs
mapM_ (atomically . removePendingSubscription ca srv . fst) finalErrs
mapM_ (liftIO . notify . CASubError srv) $ L.nonEmpty finalErrs
mapM_ (throwE . snd) $ listToMaybe tempErrs
@@ -281,7 +281,7 @@ subscribeQueue ca srv sub = do
handleErr e = do
atomically . when (e /= PCENetworkError && e /= PCEResponseTimeout) $
removePendingSubscription ca srv $ fst sub
removePendingSubscription ca srv (fst sub)
throwE e
subscribeQueuesSMP :: SMPClientAgent -> SMPServer -> NonEmpty (RecipientId, RcvPrivateSignKey) -> IO (NonEmpty (RecipientId, Either SMPClientError ()))
@@ -300,14 +300,15 @@ subscribeQueues_ party ca srv subs = do
smpSubscribeQueues :: SMPSubParty -> SMPClientAgent -> SMPClient -> SMPServer -> NonEmpty (QueueId, C.APrivateSignKey) -> IO (NonEmpty (QueueId, Either SMPClientError ()))
smpSubscribeQueues party ca smp srv subs = do
rs <- L.zip subs <$> subscribe smp (L.map swap subs)
atomically $ forM rs $ \(sub, r) -> (fst sub,) <$> case r of
Right () -> do
addSubscription ca srv $ first (party,) sub
pure $ Right ()
Left e -> do
when (e /= PCENetworkError && e /= PCEResponseTimeout) $
removePendingSubscription ca srv $ (party,) $ fst sub
pure $ Left e
atomically $ forM rs $ \(sub, r) ->
(fst sub,) <$> case r of
Right () -> do
addSubscription ca srv $ first (party,) sub
pure $ Right ()
Left e -> do
when (e /= PCENetworkError && e /= PCEResponseTimeout) $
removePendingSubscription ca srv (party, fst sub)
pure $ Left e
where
subscribe = case party of
SPRecipient -> subscribeSMPQueues
src/Simplex/Messaging/Crypto.hs
+2 -2
View File
@@ -680,9 +680,9 @@ instance CryptoSignature ASignature where
signatureBytes (ASignature _ sig) = signatureBytes sig
decodeSignature s
| B.length s == Ed25519.signatureSize =
ASignature SEd25519 . SignatureEd25519 <$> ed Ed25519.signature s
ASignature SEd25519 . SignatureEd25519 <$> ed Ed25519.signature s
| B.length s == Ed448.signatureSize =
ASignature SEd448 . SignatureEd448 <$> ed Ed448.signature s
ASignature SEd448 . SignatureEd448 <$> ed Ed448.signature s
| otherwise = Left "bad signature size"
where
ed alg = first show . CE.eitherCryptoError . alg
src/Simplex/Messaging/Crypto/File.hs
-1
View File
@@ -1,6 +1,5 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Simplex.Messaging.Crypto.File
src/Simplex/Messaging/Crypto/Lazy.hs
+8 -9
View File
@@ -1,7 +1,6 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
@@ -90,10 +89,10 @@ unPad = fmap snd . splitLen
splitLen :: LazyByteString -> Either CryptoError (Int64, LazyByteString)
splitLen padded
| LB.length lenStr == 8 = case smpDecode $ LB.toStrict lenStr of
Right len
| len < 0 -> Left CryptoInvalidMsgError
| otherwise -> Right (len, LB.take len rest)
Left _ -> Left CryptoInvalidMsgError
Right len
| len < 0 -> Left CryptoInvalidMsgError
| otherwise -> Right (len, LB.take len rest)
Left _ -> Left CryptoInvalidMsgError
| otherwise = Left CryptoInvalidMsgError
where
(lenStr, rest) = LB.splitAt 8 padded
@@ -112,10 +111,10 @@ sbDecrypt :: SbKey -> CbNonce -> LazyByteString -> Either CryptoError LazyByteSt
sbDecrypt (SbKey key) (CbNonce nonce) packet
| LB.length tag' < 16 = Left CBDecryptError
| otherwise = case secretBox sbDecryptChunk key nonce c of
Right (tag :| cs)
| BA.constEq (LB.toStrict tag') tag -> unPad $ LB.fromChunks cs
| otherwise -> Left CBDecryptError
Left e -> Left e
Right (tag :| cs)
| BA.constEq (LB.toStrict tag') tag -> unPad $ LB.fromChunks cs
| otherwise -> Left CBDecryptError
Left e -> Left e
where
(tag', c) = LB.splitAt 16 packet
src/Simplex/Messaging/Crypto/Ratchet.hs
+7 -7
View File
@@ -112,11 +112,11 @@ x3dh v (sk1, rk1) dh1 dh2 dh3 =
(hk, nhk, sk)
-- for backwards compatibility with clients using agent version before 3.4.0
| v == 1 =
let (hk', rest) = B.splitAt 32 dhs
in uncurry (hk',,) $ B.splitAt 32 rest
let (hk', rest) = B.splitAt 32 dhs
in uncurry (hk',,) $ B.splitAt 32 rest
| otherwise =
let salt = B.replicate 64 '\0'
in hkdf3 salt dhs "SimpleXX3DH"
let salt = B.replicate 64 '\0'
in hkdf3 salt dhs "SimpleXX3DH"
type RatchetX448 = Ratchet 'X448
@@ -428,9 +428,9 @@ rcDecrypt rc@Ratchet {rcRcv, rcAD = Str rcAD} rcMKSkipped msg' = do
| rcNr + maxSkip < untilN = Left $ CERatchetTooManySkipped (untilN + 1 - rcNr)
| rcNr == untilN = Right (r, M.empty)
| otherwise =
let (rcCKr', rcNr', mks) = advanceRcvRatchet (untilN - rcNr) rcCKr rcNr M.empty
r' = r {rcRcv = Just rr {rcCKr = rcCKr'}, rcNr = rcNr'}
in Right (r', M.singleton rcHKr mks)
let (rcCKr', rcNr', mks) = advanceRcvRatchet (untilN - rcNr) rcCKr rcNr M.empty
r' = r {rcRcv = Just rr {rcCKr = rcCKr'}, rcNr = rcNr'}
in Right (r', M.singleton rcHKr mks)
advanceRcvRatchet :: Word32 -> RatchetKey -> Word32 -> SkippedHdrMsgKeys -> (RatchetKey, Word32, SkippedHdrMsgKeys)
advanceRcvRatchet 0 ck msgNs mks = (ck, msgNs, mks)
advanceRcvRatchet n ck msgNs mks =
src/Simplex/Messaging/Encoding.hs
+1 -1
View File
@@ -109,7 +109,7 @@ lenP = fromIntegral . c2w <$> A.anyChar
{-# INLINE lenP #-}
instance Encoding a => Encoding (Maybe a) where
smpEncode s = maybe "0" (("1" <>) . smpEncode) s
smpEncode = maybe "0" (("1" <>) . smpEncode)
{-# INLINE smpEncode #-}
smpP =
smpP >>= \case
src/Simplex/Messaging/Notifications/Protocol.hs
+1 -1
View File
@@ -518,7 +518,7 @@ instance ToJSON NtfTknStatus where
instance FromJSON NtfTknStatus where
parseJSON = J.withText "NtfTknStatus" $ either fail pure . smpDecode . encodeUtf8
checkEntity :: forall t e e'. (NtfEntityI e, NtfEntityI e') => t e' -> Either String (t e)
checkEntity c = case testEquality (sNtfEntity @e) (sNtfEntity @e') of
Just Refl -> Right c
src/Simplex/Messaging/Notifications/Server.hs
+33 -32
View File
@@ -22,7 +22,7 @@ import qualified Data.ByteString.Char8 as B
import Data.Functor (($>))
import Data.Int (Int64)
import Data.List (intercalate, sort)
import Data.List.NonEmpty (NonEmpty(..))
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as L
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
@@ -208,7 +208,7 @@ ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAge
-- | Subscribe to queues. The list of results can have a different order.
subscribeQueues :: SMPServer -> NonEmpty NtfSubData -> IO (NonEmpty (NtfSubData, Either SMPClientError ()))
subscribeQueues srv subs =
L.map (second snd) . L.zip subs <$> subscribeQueuesNtfs ca srv (L.map sub subs)
L.zipWith (\s r -> (s, snd r)) subs <$> subscribeQueuesNtfs ca srv (L.map sub subs)
where
sub NtfSubData {smpQueue = SMPQueueNtf {notifierId}, notifierKey} = (notifierId, notifierKey)
@@ -248,10 +248,11 @@ ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAge
forM errs (\((_, ntfId), err) -> handleSubError (SMPQueueNtf srv ntfId) err)
>>= logSubErrors srv . catMaybes . L.toList
logSubStatus srv event n = when (n > 0) $
logInfo $ "SMP server " <> event <> " " <> showServer' srv <> " (" <> tshow n <> " subscriptions)"
logSubStatus srv event n =
when (n > 0) . logInfo $
"SMP server " <> event <> " " <> showServer' srv <> " (" <> tshow n <> " subscriptions)"
logSubErrors :: SMPServer -> [NtfSubStatus] -> M ()
logSubErrors :: SMPServer -> [NtfSubStatus] -> M ()
logSubErrors srv errs = forM_ (L.group $ sort errs) $ \errs' -> do
logError $ "SMP subscription errors on server " <> showServer' srv <> ": " <> tshow (L.head errs') <> " (" <> tshow (length errs') <> " errors)"
@@ -289,14 +290,14 @@ ntfPush s@NtfPushServer {pushQ} = forever $ do
case ntf of
PNVerification _
| status /= NTInvalid && status /= NTExpired ->
deliverNotification pp tkn ntf >>= \case
Right _ -> do
status_ <- atomically $ stateTVar tknStatus $ \case
NTActive -> (Nothing, NTActive)
NTConfirmed -> (Nothing, NTConfirmed)
_ -> (Just NTConfirmed, NTConfirmed)
forM_ status_ $ \status' -> withNtfLog $ \sl -> logTokenStatus sl ntfTknId status'
_ -> pure ()
deliverNotification pp tkn ntf >>= \case
Right _ -> do
status_ <- atomically $ stateTVar tknStatus $ \case
NTActive -> (Nothing, NTActive)
NTConfirmed -> (Nothing, NTConfirmed)
_ -> (Just NTConfirmed, NTConfirmed)
forM_ status_ $ \status' -> withNtfLog $ \sl -> logTokenStatus sl ntfTknId status'
_ -> pure ()
| otherwise -> logError "bad notification token status"
PNCheckMessages -> checkActiveTkn status $ do
void $ deliverNotification pp tkn ntf
@@ -463,16 +464,16 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu
else pure $ NRErr AUTH
TVFY code -- this allows repeated verification for cases when client connection dropped before server response
| (status == NTRegistered || status == NTConfirmed || status == NTActive) && tknRegCode == code -> do
logDebug "TVFY - token verified"
st <- asks store
updateTknStatus tkn NTActive
tIds <- atomically $ removeInactiveTokenRegistrations st tkn
forM_ tIds cancelInvervalNotifications
incNtfStat tknVerified
pure NROk
logDebug "TVFY - token verified"
st <- asks store
updateTknStatus tkn NTActive
tIds <- atomically $ removeInactiveTokenRegistrations st tkn
forM_ tIds cancelInvervalNotifications
incNtfStat tknVerified
pure NROk
| otherwise -> do
logDebug "TVFY - incorrect code or token status"
pure $ NRErr AUTH
logDebug "TVFY - incorrect code or token status"
pure $ NRErr AUTH
TCHK -> do
logDebug "TCHK"
pure $ NRTkn status
@@ -509,16 +510,16 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu
TCRN int
| int < 20 -> pure $ NRErr QUOTA
| otherwise -> do
logDebug "TCRN"
atomically $ writeTVar tknCronInterval int
atomically (TM.lookup tknId intervalNotifiers) >>= \case
Nothing -> runIntervalNotifier int
Just IntervalNotifier {interval, action} ->
unless (interval == int) $ do
uninterruptibleCancel action
runIntervalNotifier int
withNtfLog $ \s -> logTokenCron s tknId int
pure NROk
logDebug "TCRN"
atomically $ writeTVar tknCronInterval int
atomically (TM.lookup tknId intervalNotifiers) >>= \case
Nothing -> runIntervalNotifier int
Just IntervalNotifier {interval, action} ->
unless (interval == int) $ do
uninterruptibleCancel action
runIntervalNotifier int
withNtfLog $ \s -> logTokenCron s tknId int
pure NROk
where
runIntervalNotifier interval = do
action <- async . intervalNotifier $ fromIntegral interval * 1000000 * 60
src/Simplex/Messaging/Notifications/Server/Env.hs
+1 -1
View File
@@ -34,7 +34,7 @@ import Simplex.Messaging.Server.Expiration
import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport (ATransport)
import Simplex.Messaging.Transport.Server (loadFingerprint, loadTLSServerParams, TransportServerConfig)
import Simplex.Messaging.Transport.Server (TransportServerConfig, loadFingerprint, loadTLSServerParams)
import System.IO (IOMode (..))
import System.Mem.Weak (Weak)
import UnliftIO.STM
src/Simplex/Messaging/Notifications/Server/Main.hs
+1 -2
View File
@@ -7,7 +7,6 @@
module Simplex.Messaging.Notifications.Server.Main where
import Data.Either (fromRight)
import Data.Functor (($>))
import Data.Ini (lookupValue, readIniFile)
import Data.Maybe (fromMaybe)
@@ -92,7 +91,7 @@ ntfServerCLI cfgPath logPath =
hSetBuffering stdout LineBuffering
hSetBuffering stderr LineBuffering
fp <- checkSavedFingerprint cfgPath defaultX509Config
let host = fromRight "<hostnames>" $ T.unpack <$> lookupValue "TRANSPORT" "host" ini
let host = either (const "<hostnames>") T.unpack $ lookupValue "TRANSPORT" "host" ini
port = T.unpack $ strictIni "TRANSPORT" "port" ini
cfg@NtfServerConfig {transports, storeLogFile} = serverConfig
srv = ProtoServerWithAuth (NtfServer [THDomainName host] (if port == "443" then "" else port) (C.KeyHash fp)) Nothing
src/Simplex/Messaging/Notifications/Server/Push/APNS.hs
+8 -8
View File
@@ -356,15 +356,15 @@ apnsPushProviderClient c@APNSPushClient {nonceDrg, apnsCfg} tkn@NtfTknData {toke
result status reason'
| status == Just N.ok200 = pure ()
| status == Just N.badRequest400 =
case reason' of
"BadDeviceToken" -> throwError PPTokenInvalid
"DeviceTokenNotForTopic" -> throwError PPTokenInvalid
"TopicDisallowed" -> throwError PPPermanentError
_ -> err status reason'
case reason' of
"BadDeviceToken" -> throwError PPTokenInvalid
"DeviceTokenNotForTopic" -> throwError PPTokenInvalid
"TopicDisallowed" -> throwError PPPermanentError
_ -> err status reason'
| status == Just N.forbidden403 = case reason' of
"ExpiredProviderToken" -> throwError PPPermanentError -- there should be no point retrying it as the token was refreshed
"InvalidProviderToken" -> throwError PPPermanentError
_ -> err status reason'
"ExpiredProviderToken" -> throwError PPPermanentError -- there should be no point retrying it as the token was refreshed
"InvalidProviderToken" -> throwError PPPermanentError
_ -> err status reason'
| status == Just N.gone410 = throwError PPTokenInvalid
| status == Just N.serviceUnavailable503 = liftIO (disconnectApnsHTTP2Client c) >> throwError PPRetryLater
-- Just tooManyRequests429 -> TooManyRequests - too many requests for the same token
src/Simplex/Messaging/Notifications/Server/Store.hs
-1
View File
@@ -4,7 +4,6 @@
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Simplex.Messaging.Notifications.Server.Store where
src/Simplex/Messaging/Notifications/Server/StoreLog.hs
-1
View File
@@ -5,7 +5,6 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StrictData #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
module Simplex.Messaging.Notifications.Server.StoreLog
src/Simplex/Messaging/Notifications/Transport.hs
+3 -3
View File
@@ -50,9 +50,9 @@ ntfServerHandshake c kh ntfVRange = do
getHandshake th >>= \case
NtfClientHandshake {ntfVersion, keyHash}
| keyHash /= kh ->
throwError $ TEHandshake IDENTITY
| ntfVersion `isCompatible` ntfVRange -> do
pure (th :: THandle c) {thVersion = ntfVersion}
throwError $ TEHandshake IDENTITY
| ntfVersion `isCompatible` ntfVRange ->
pure (th :: THandle c) {thVersion = ntfVersion}
| otherwise -> throwError $ TEHandshake VERSION
-- | Notifcations server client transport handshake.
src/Simplex/Messaging/Parsers.hs
+1 -1
View File
@@ -85,7 +85,7 @@ blobFieldDecoder dec = \case
Left e -> returnError ConversionFailed f ("couldn't parse field: " ++ e)
f -> returnError ConversionFailed f "expecting SQLBlob column type"
fromTextField_ :: (Typeable a) => (Text -> Maybe a) -> Field -> Ok a
fromTextField_ :: Typeable a => (Text -> Maybe a) -> Field -> Ok a
fromTextField_ fromText = \case
f@(Field (SQLText t) _) ->
case fromText t of
src/Simplex/Messaging/Protocol.hs
+22 -20
View File
@@ -135,7 +135,7 @@ module Simplex.Messaging.Protocol
noAuthSrv,
-- * TCP transport functions
TransportBatch(..),
TransportBatch (..),
tPut,
tPutLog,
tGet,
@@ -309,17 +309,19 @@ instance StrEncoding SubscriptionMode where
SMSubscribe -> "subscribe"
SMOnlyCreate -> "only-create"
strP =
(A.string "subscribe" $> SMSubscribe) <|> (A.string "only-create" $> SMOnlyCreate)
<?> "SubscriptionMode"
(A.string "subscribe" $> SMSubscribe)
<|> (A.string "only-create" $> SMOnlyCreate)
<?> "SubscriptionMode"
instance Encoding SubscriptionMode where
smpEncode = \case
SMSubscribe -> "S"
SMOnlyCreate -> "C"
smpP = A.anyChar >>= \case
'S' -> pure SMSubscribe
'C' -> pure SMOnlyCreate
_ -> fail "bad SubscriptionMode"
smpP =
A.anyChar >>= \case
'S' -> pure SMSubscribe
'C' -> pure SMOnlyCreate
_ -> fail "bad SubscriptionMode"
data BrokerMsg where
-- SMP broker messages (responses, client messages, notifications)
@@ -1306,7 +1308,7 @@ tPutLog th s = do
pure r
-- ByteString does not include length byte, it is added by tEncodeBatch
data TransportBatch = TBTransmissions Int ByteString | TBTransmission ByteString | TBLargeTransmission
data TransportBatch = TBTransmissions Int ByteString | TBTransmission ByteString | TBLargeTransmission
-- | encodes and batches transmissions into blocks,
batchTransmissions :: Bool -> Int -> NonEmpty SentRawTransmission -> [TransportBatch]
@@ -1319,22 +1321,22 @@ batchTransmissions batch bSize
let (n, s, ts_) = encodeBatch 0 "" ts
r = if n == 0 then TBLargeTransmission else TBTransmissions n s
rs' = r : rs
in case ts_ of
Just ts' -> mkBatch rs' ts'
_ -> rs'
in case ts_ of
Just ts' -> mkBatch rs' ts'
_ -> rs'
mkBatch1 :: ByteString -> TransportBatch
mkBatch1 s = if B.length s > bSize - 2 then TBLargeTransmission else TBTransmission s
encodeBatch :: Int -> ByteString -> NonEmpty ByteString -> (Int, ByteString, Maybe (NonEmpty ByteString))
encodeBatch n s ts@(t :| ts_)
| n == 255 = (n, s, Just ts)
| otherwise =
let s' = s <> smpEncode (Large t)
n' = n + 1
in if B.length s' > bSize - 3 -- one byte is reserved for the number of messages in the batch
then (n,s,) $ if n == 0 then L.nonEmpty ts_ else Just ts
else case L.nonEmpty ts_ of
Just ts' -> encodeBatch n' s' ts'
_ -> (n', s', Nothing)
let s' = s <> smpEncode (Large t)
n' = n + 1
in if B.length s' > bSize - 3 -- one byte is reserved for the number of messages in the batch
then (n,s,) $ if n == 0 then L.nonEmpty ts_ else Just ts
else case L.nonEmpty ts_ of
Just ts' -> encodeBatch n' s' ts'
_ -> (n', s', Nothing)
tEncode :: SentRawTransmission -> ByteString
tEncode (sig, t) = smpEncode (C.signatureBytes sig) <> t
@@ -1373,8 +1375,8 @@ tDecodeParseValidate :: forall err cmd. ProtocolEncoding err cmd => SessionId ->
tDecodeParseValidate sessionId v = \case
Right RawTransmission {signature, signed, sessId, corrId, entityId, command}
| sessId == sessionId ->
let decodedTransmission = (,corrId,entityId,command) <$> C.decodeSignature signature
in either (const $ tError corrId) (tParseValidate signed) decodedTransmission
let decodedTransmission = (,corrId,entityId,command) <$> C.decodeSignature signature
in either (const $ tError corrId) (tParseValidate signed) decodedTransmission
| otherwise -> (Nothing, "", (CorrId corrId, "", Left $ fromProtocolError @err @cmd PESession))
Left _ -> tError ""
where
src/Simplex/Messaging/Server.hs
+30 -30
View File
@@ -1,6 +1,5 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
@@ -8,6 +7,7 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
@@ -116,9 +116,9 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
restoreServerMessages
restoreServerStats
raceAny_
( serverThread s "server subscribedQ" subscribedQ subscribers subscriptions cancelSub :
serverThread s "server ntfSubscribedQ" ntfSubscribedQ Env.notifiers ntfSubscriptions (\_ -> pure ()) :
map runServer transports <> expireMessagesThread_ cfg <> serverStatsThread_ cfg <> controlPortThread_ cfg
( serverThread s "server subscribedQ" subscribedQ subscribers subscriptions cancelSub
: serverThread s "server ntfSubscribedQ" ntfSubscribedQ Env.notifiers ntfSubscriptions (\_ -> pure ())
: map runServer transports <> expireMessagesThread_ cfg <> serverStatsThread_ cfg <> controlPortThread_ cfg
)
`finally` withLock (savingLock s) "final" (saveServer False)
where
@@ -148,7 +148,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
updateSubscribers :: STM (Maybe (QueueId, Client))
updateSubscribers = do
(qId, clnt) <- readTQueue $ subQ s
let clientToBeNotified = \c' ->
let clientToBeNotified c' =
if sameClientSession clnt c'
then pure Nothing
else do
@@ -277,9 +277,9 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
hPutStrLn h $ "Clients: " <> show (length clients)
forM_ (M.toList clients) $ \(cid, Client {sessionId, connected, activeAt, subscriptions}) -> do
hPutStrLn h . B.unpack $ "Client " <> encode cid <> " $" <> encode sessionId
readTVarIO connected >>= hPutStrLn h . (" connected: " <>) . show
readTVarIO activeAt >>= hPutStrLn h . (" activeAt: " <>) . B.unpack . strEncode
readTVarIO subscriptions >>= hPutStrLn h . (" subscriptions: " <>) . show . M.size
readTVarIO connected >>= hPutStrLn h . (" connected: " <>) . show
readTVarIO activeAt >>= hPutStrLn h . (" activeAt: " <>) . B.unpack . strEncode
readTVarIO subscriptions >>= hPutStrLn h . (" subscriptions: " <>) . show . M.size
CPStats -> do
ServerStats {fromTime, qCreated, qSecured, qDeleted, msgSent, msgRecv, msgSentNtf, msgRecvNtf, qCount, msgCount} <- unliftIO u $ asks serverStats
putStat "fromTime" fromTime
@@ -666,27 +666,27 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Serv
sendMessage qr msgFlags msgBody
| B.length msgBody > maxMessageLength = pure $ err LARGE_MSG
| otherwise = case status qr of
QueueOff -> return $ err AUTH
QueueActive ->
case C.maxLenBS msgBody of
Left _ -> pure $ err LARGE_MSG
Right body -> do
msg_ <- time "SEND" $ do
q <- getStoreMsgQueue "SEND" $ recipientId qr
expireMessages q
atomically . writeMsg q =<< mkMessage body
case msg_ of
Nothing -> pure $ err QUOTA
Just msg -> time "SEND ok" $ do
stats <- asks serverStats
when (notification msgFlags) $ do
atomically . trySendNotification msg =<< asks idsDrg
atomically $ modifyTVar' (msgSentNtf stats) (+ 1)
atomically $ updatePeriodStats (activeQueuesNtf stats) (recipientId qr)
atomically $ modifyTVar' (msgSent stats) (+ 1)
atomically $ modifyTVar' (msgCount stats) (subtract 1)
atomically $ updatePeriodStats (activeQueues stats) (recipientId qr)
pure ok
QueueOff -> return $ err AUTH
QueueActive ->
case C.maxLenBS msgBody of
Left _ -> pure $ err LARGE_MSG
Right body -> do
msg_ <- time "SEND" $ do
q <- getStoreMsgQueue "SEND" $ recipientId qr
expireMessages q
atomically . writeMsg q =<< mkMessage body
case msg_ of
Nothing -> pure $ err QUOTA
Just msg -> time "SEND ok" $ do
stats <- asks serverStats
when (notification msgFlags) $ do
atomically . trySendNotification msg =<< asks idsDrg
atomically $ modifyTVar' (msgSentNtf stats) (+ 1)
atomically $ updatePeriodStats (activeQueuesNtf stats) (recipientId qr)
atomically $ modifyTVar' (msgSent stats) (+ 1)
atomically $ modifyTVar' (msgCount stats) (subtract 1)
atomically $ updatePeriodStats (activeQueues stats) (recipientId qr)
pure ok
where
mkMessage :: C.MaxLenBS MaxMessageLen -> m Message
mkMessage body = do
@@ -767,7 +767,7 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Serv
msgTs' = msg.msgTs
setDelivered :: Sub -> Message -> STM Bool
setDelivered s msg = tryPutTMVar (delivered s) $ msg.msgId
setDelivered s msg = tryPutTMVar (delivered s) msg.msgId
getStoreMsgQueue :: T.Text -> RecipientId -> m MsgQueue
getStoreMsgQueue name rId = time (name <> " getMsgQueue") $ do
src/Simplex/Messaging/Server/Env/STM.hs
+1 -1
View File
@@ -31,7 +31,7 @@ import Simplex.Messaging.Server.StoreLog
import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport (ATransport)
import Simplex.Messaging.Transport.Server (loadFingerprint, loadTLSServerParams, TransportServerConfig)
import Simplex.Messaging.Transport.Server (TransportServerConfig, loadFingerprint, loadTLSServerParams)
import Simplex.Messaging.Version
import System.IO (IOMode (..))
import System.Mem.Weak (Weak)
src/Simplex/Messaging/Server/Main.hs
+17 -17
View File
@@ -11,7 +11,6 @@ module Simplex.Messaging.Server.Main where
import Control.Monad (void)
import Crypto.Random (getRandomBytes)
import qualified Data.ByteString.Char8 as B
import Data.Either (fromRight)
import Data.Functor (($>))
import Data.Ini (lookupValue, readIniFile)
import Data.Maybe (fromMaybe)
@@ -24,7 +23,7 @@ import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Protocol (BasicAuth (..), ProtoServerWithAuth (ProtoServerWithAuth), pattern SMPServer)
import Simplex.Messaging.Server (runSMPServer)
import Simplex.Messaging.Server.CLI
import Simplex.Messaging.Server.Env.STM (ServerConfig (..), defaultInactiveClientExpiration, defaultMessageExpiration, defMsgExpirationDays)
import Simplex.Messaging.Server.Env.STM (ServerConfig (..), defMsgExpirationDays, defaultInactiveClientExpiration, defaultMessageExpiration)
import Simplex.Messaging.Server.Expiration
import Simplex.Messaging.Transport (simplexMQVersion, supportedSMPServerVRange)
import Simplex.Messaging.Transport.Client (TransportHost (..))
@@ -60,15 +59,15 @@ smpServerCLI cfgPath logPath =
initializeServer opts
| scripted opts = initialize opts
| otherwise = do
putStrLn "Use `smp-server init -h` for available options."
void $ withPrompt "SMP server will be initialized (press Enter)" getLine
enableStoreLog <- onOffPrompt "Enable store log to restore queues and messages on server restart" True
logStats <- onOffPrompt "Enable logging daily statistics" False
putStrLn "Require a password to create new messaging queues?"
password <- withPrompt "'r' for random (default), 'n' - no password, or enter password: " serverPassword
let host = fromMaybe (ip opts) (fqdn opts)
host' <- withPrompt ("Enter server FQDN or IP address for certificate (" <> host <> "): ") getLine
initialize opts {enableStoreLog, logStats, fqdn = if null host' then fqdn opts else Just host', password}
putStrLn "Use `smp-server init -h` for available options."
void $ withPrompt "SMP server will be initialized (press Enter)" getLine
enableStoreLog <- onOffPrompt "Enable store log to restore queues and messages on server restart" True
logStats <- onOffPrompt "Enable logging daily statistics" False
putStrLn "Require a password to create new messaging queues?"
password <- withPrompt "'r' for random (default), 'n' - no password, or enter password: " serverPassword
let host = fromMaybe (ip opts) (fqdn opts)
host' <- withPrompt ("Enter server FQDN or IP address for certificate (" <> host <> "): ") getLine
initialize opts {enableStoreLog, logStats, fqdn = if null host' then fqdn opts else Just host', password}
where
serverPassword =
getLine >>= \case
@@ -121,8 +120,8 @@ smpServerCLI cfgPath logPath =
\# The password will not be shared with the connecting contacts, you must share it only\n\
\# with the users who you want to allow creating messaging queues on your server.\n"
<> ( case basicAuth of
Just auth -> "create_password: " <> T.unpack (safeDecodeUtf8 $ strEncode auth)
_ -> "# create_password: password to create new queues (any printable ASCII characters without whitespace, '@', ':' and '/')"
Just auth -> "create_password: " <> T.unpack (safeDecodeUtf8 $ strEncode auth)
_ -> "# create_password: password to create new queues (any printable ASCII characters without whitespace, '@', ':' and '/')"
)
<> "\n\n\
\[TRANSPORT]\n\
@@ -141,7 +140,7 @@ smpServerCLI cfgPath logPath =
hSetBuffering stdout LineBuffering
hSetBuffering stderr LineBuffering
fp <- checkSavedFingerprint cfgPath defaultX509Config
let host = fromRight "<hostnames>" $ T.unpack <$> lookupValue "TRANSPORT" "host" ini
let host = either (const "<hostnames>") T.unpack $ lookupValue "TRANSPORT" "host" ini
port = T.unpack $ strictIni "TRANSPORT" "port" ini
cfg@ServerConfig {transports, storeLogFile, newQueueBasicAuth, messageExpiration, inactiveClientExpiration} = serverConfig
srv = ProtoServerWithAuth (SMPServer [THDomainName host] (if port == "5223" then "" else port) (C.KeyHash fp)) newQueueBasicAuth
@@ -186,9 +185,10 @@ smpServerCLI cfgPath logPath =
allowNewQueues = fromMaybe True $ iniOnOff "AUTH" "new_queues" ini,
newQueueBasicAuth = either error id <$> strDecodeIni "AUTH" "create_password" ini,
messageExpiration =
Just defaultMessageExpiration
{ ttl = 86400 * readIniDefault defMsgExpirationDays "STORE_LOG" "expire_messages_days" ini
},
Just
defaultMessageExpiration
{ ttl = 86400 * readIniDefault defMsgExpirationDays "STORE_LOG" "expire_messages_days" ini
},
inactiveClientExpiration =
settingIsOn "INACTIVE_CLIENTS" "disconnect" ini
$> ExpirationConfig
src/Simplex/Messaging/Server/MsgStore/STM.hs
+1 -1
View File
@@ -64,7 +64,7 @@ flushMsgQueue :: STMMsgStore -> RecipientId -> STM [Message]
flushMsgQueue st rId = TM.lookupDelete rId st >>= maybe (pure []) (flushTQueue . msgQueue)
snapshotMsgQueue :: STMMsgStore -> RecipientId -> STM [Message]
snapshotMsgQueue st rId = TM.lookup rId st >>= maybe (pure []) (snapshotTQueue . msgQueue)
snapshotMsgQueue st rId = TM.lookup rId st >>= maybe (pure []) (snapshotTQueue . msgQueue)
where
snapshotTQueue q = do
msgs <- flushTQueue q
src/Simplex/Messaging/Server/StoreLog.hs
-1
View File
@@ -4,7 +4,6 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Simplex.Messaging.Server.StoreLog
src/Simplex/Messaging/Transport.hs
+2 -2
View File
@@ -354,9 +354,9 @@ smpServerHandshake c kh smpVRange = do
getHandshake th >>= \case
ClientHandshake {smpVersion, keyHash}
| keyHash /= kh ->
throwE $ TEHandshake IDENTITY
throwE $ TEHandshake IDENTITY
| smpVersion `isCompatible` smpVRange -> do
pure $ smpThHandle th smpVersion
pure $ smpThHandle th smpVersion
| otherwise -> throwE $ TEHandshake VERSION
-- | Client SMP transport handshake.
src/Simplex/Messaging/Transport/Buffer.hs
+4 -4
View File
@@ -8,8 +8,8 @@ import Control.Concurrent.STM
import qualified Control.Exception as E
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import GHC.IO.Exception (IOErrorType (..), IOException (..), ioException)
import System.Timeout (timeout)
import GHC.IO.Exception (ioException, IOException (..), IOErrorType (..))
data TBuffer = TBuffer
{ buffer :: TVar ByteString,
@@ -41,9 +41,9 @@ getBuffered tb@TBuffer {buffer} n t_ getChunk = withBufferLock tb $ do
readChunks firstChunk b
| B.length b >= n = pure b
| otherwise =
get >>= \case
"" -> pure b
s -> readChunks False $ b <> s
get >>= \case
"" -> pure b
s -> readChunks False $ b <> s
where
get
| firstChunk = getChunk
src/Simplex/Messaging/Transport/Credentials.hs
-2
View File
@@ -1,7 +1,5 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Simplex.Messaging.Transport.Credentials
( tlsCredentials,
src/Simplex/Messaging/Transport/HTTP2/Client.hs
+1 -2
View File
@@ -22,10 +22,9 @@ import qualified Network.TLS as T
import Numeric.Natural (Natural)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Transport (SessionId)
import Simplex.Messaging.Transport (SessionId, TLS)
import Simplex.Messaging.Transport.Client (TransportClientConfig (..), TransportHost (..), runTLSTransportClient)
import Simplex.Messaging.Transport.HTTP2
import Simplex.Messaging.Transport (TLS)
import UnliftIO.STM
import UnliftIO.Timeout
src/Simplex/Messaging/Transport/HTTP2/File.hs
+4 -5
View File
@@ -1,11 +1,10 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
module Simplex.Messaging.Transport.HTTP2.File where
import Data.ByteString.Builder (Builder, byteString)
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import Data.ByteString.Builder (Builder, byteString)
import Data.Int (Int64)
import Data.Word (Word32)
import GHC.IO.Handle.Internals (ioe_EOF)
@@ -22,9 +21,9 @@ hReceiveFile getBody h size = get $ fromIntegral size
ch <- getBody fileBlockSize
let chSize = fromIntegral $ B.length ch
if
| chSize > sz -> pure (chSize - sz)
| chSize > 0 -> B.hPut h ch >> get (sz - chSize)
| otherwise -> pure (- fromIntegral sz)
| chSize > sz -> pure (chSize - sz)
| chSize > 0 -> B.hPut h ch >> get (sz - chSize)
| otherwise -> pure (-fromIntegral sz)
hSendFile :: Handle -> (Builder -> IO ()) -> Word32 -> IO ()
hSendFile h send = go
src/Simplex/Messaging/Transport/HTTP2/Server.hs
-1
View File
@@ -1,5 +1,4 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module Simplex.Messaging.Transport.HTTP2.Server where
src/Simplex/Messaging/Transport/Server.hs
+5 -4
View File
@@ -46,10 +46,11 @@ data TransportServerConfig = TransportServerConfig
deriving (Eq, Show)
defaultTransportServerConfig :: TransportServerConfig
defaultTransportServerConfig = TransportServerConfig
{ logTLSErrors = True,
transportTimeout = 40000000
}
defaultTransportServerConfig =
TransportServerConfig
{ logTLSErrors = True,
transportTimeout = 40000000
}
serverTransportConfig :: TransportServerConfig -> TransportConfig
serverTransportConfig TransportServerConfig {logTLSErrors} =
src/Simplex/Messaging/Transport/WebSockets.hs
+1 -1
View File
@@ -15,9 +15,9 @@ import qualified Network.WebSockets.Stream as S
import Simplex.Messaging.Transport
( TProxy,
Transport (..),
TransportConfig (..),
TransportError (..),
TransportPeer (..),
TransportConfig (..),
closeTLS,
smpBlockSize,
withTlsUnique,
src/Simplex/Messaging/Util.hs
+8 -8
View File
@@ -62,7 +62,7 @@ liftEitherError :: (MonadIO m, MonadError e' m) => (e -> e') -> IO (Either e a)
liftEitherError f a = liftIOEither (first f <$> a)
{-# INLINE liftEitherError #-}
liftEitherWith :: (MonadError e' m) => (e -> e') -> Either e a -> m a
liftEitherWith :: MonadError e' m => (e -> e') -> Either e a -> m a
liftEitherWith f = liftEither . first f
{-# INLINE liftEitherWith #-}
@@ -102,7 +102,7 @@ catchAllErrors err action handle = tryAllErrors err action >>= either handle pur
{-# INLINE catchAllErrors #-}
catchThrow :: (MonadUnliftIO m, MonadError e m) => m a -> (E.SomeException -> e) -> m a
catchThrow action err = catchAllErrors err action throwError
catchThrow action err = catchAllErrors err action throwError
{-# INLINE catchThrow #-}
allFinally :: (MonadUnliftIO m, MonadError e m) => (E.SomeException -> e) -> m a -> m b -> m a
@@ -115,12 +115,12 @@ eitherToMaybe = either (const Nothing) Just
groupOn :: Eq k => (a -> k) -> [a] -> [[a]]
groupOn = groupBy . eqOn
-- it is equivalent to groupBy ((==) `on` f),
-- but it redefines `on` to avoid duplicate computation for most values.
-- source: https://hackage.haskell.org/package/extra-1.7.13/docs/src/Data.List.Extra.html#groupOn
-- the on2 in this package is specialized to only use `==` as the function, `eqOn f` is equivalent to `(==) `on` f`
where
eqOn f = \x -> let fx = f x in \y -> fx == f y
-- it is equivalent to groupBy ((==) `on` f),
-- but it redefines `on` to avoid duplicate computation for most values.
-- source: https://hackage.haskell.org/package/extra-1.7.13/docs/src/Data.List.Extra.html#groupOn
-- the on2 in this package is specialized to only use `==` as the function, `eqOn f` is equivalent to `(==) `on` f`
eqOn f x = let fx = f x in \y -> fx == f y
groupAllOn :: Ord k => (a -> k) -> [a] -> [[a]]
groupAllOn f = groupOn f . sortOn f
@@ -129,7 +129,7 @@ toChunks :: Int -> [a] -> [NonEmpty a]
toChunks _ [] = []
toChunks n xs =
let (ys, xs') = splitAt n xs
in maybe id (:) (L.nonEmpty ys) (toChunks n xs')
in maybe id (:) (L.nonEmpty ys) (toChunks n xs')
safeDecodeUtf8 :: ByteString -> Text
safeDecodeUtf8 = decodeUtf8With onError
tests/AgentTests.hs
+17 -17
View File
@@ -45,42 +45,42 @@ agentTests (ATransport t) = do
describe "Migration tests" migrationTests
describe "SMP agent protocol syntax" $ syntaxTests t
describe "Establishing duplex connection" $ do
it "should connect via one server and one agent" $
it "should connect via one server and one agent" $ do
smpAgentTest2_1_1 $ testDuplexConnection t
it "should connect via one server and one agent (random IDs)" $
it "should connect via one server and one agent (random IDs)" $ do
smpAgentTest2_1_1 $ testDuplexConnRandomIds t
it "should connect via one server and 2 agents" $
it "should connect via one server and 2 agents" $ do
smpAgentTest2_2_1 $ testDuplexConnection t
it "should connect via one server and 2 agents (random IDs)" $
it "should connect via one server and 2 agents (random IDs)" $ do
smpAgentTest2_2_1 $ testDuplexConnRandomIds t
it "should connect via 2 servers and 2 agents" $
it "should connect via 2 servers and 2 agents" $ do
smpAgentTest2_2_2 $ testDuplexConnection t
it "should connect via 2 servers and 2 agents (random IDs)" $
it "should connect via 2 servers and 2 agents (random IDs)" $ do
smpAgentTest2_2_2 $ testDuplexConnRandomIds t
describe "Establishing connections via `contact connection`" $ do
it "should connect via contact connection with one server and 3 agents" $
it "should connect via contact connection with one server and 3 agents" $ do
smpAgentTest3 $ testContactConnection t
it "should connect via contact connection with one server and 2 agents (random IDs)" $
it "should connect via contact connection with one server and 2 agents (random IDs)" $ do
smpAgentTest2_2_1 $ testContactConnRandomIds t
it "should support rejecting contact request" $
it "should support rejecting contact request" $ do
smpAgentTest2_2_1 $ testRejectContactRequest t
describe "Connection subscriptions" $ do
it "should connect via one server and one agent" $
it "should connect via one server and one agent" $ do
smpAgentTest3_1_1 $ testSubscription t
it "should send notifications to client when server disconnects" $
it "should send notifications to client when server disconnects" $ do
smpAgentServerTest $ testSubscrNotification t
describe "Message delivery and server reconnection" $ do
it "should deliver messages after losing server connection and re-connecting" $
it "should deliver messages after losing server connection and re-connecting" $ do
smpAgentTest2_2_2_needs_server $ testMsgDeliveryServerRestart t
it "should connect to the server when server goes up if it initially was down" $
it "should connect to the server when server goes up if it initially was down" $ do
smpAgentTestN [] $ testServerConnectionAfterError t
it "should deliver pending messages after agent restarting" $
it "should deliver pending messages after agent restarting" $ do
smpAgentTest1_1_1 $ testMsgDeliveryAgentRestart t
it "should concurrently deliver messages to connections without blocking" $
it "should concurrently deliver messages to connections without blocking" $ do
smpAgentTest2_2_1 $ testConcurrentMsgDelivery t
it "should deliver messages if one of connections has quota exceeded" $
it "should deliver messages if one of connections has quota exceeded" $ do
smpAgentTest2_2_1 $ testMsgDeliveryQuotaExceeded t
it "should resume delivering messages after exceeding quota once all messages are received" $
it "should resume delivering messages after exceeding quota once all messages are received" $ do
smpAgentTest2_2_1 $ testResumeDeliveryQuotaExceeded t
type AEntityTransmission p e = (ACorrId, ConnId, ACommand p e)
tests/AgentTests/ConnectionRequestTests.hs
+12 -13
View File
@@ -2,7 +2,6 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
module AgentTests.ConnectionRequestTests where
@@ -113,24 +112,24 @@ connectionRequestTests =
it "should serialize connection requests" $ do
strEncode connectionRequest
`shouldBe` "simplex:/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D"
<> urlEncode True testDhKeyStrUri
<> "&e2e=v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"
<> urlEncode True testDhKeyStrUri
<> "&e2e=v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"
strEncode connectionRequestCurrentRange
`shouldBe` "simplex:/invitation#/?v=1-4&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D"
<> urlEncode True testDhKeyStrUri
<> "%2Csmp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D"
<> urlEncode True testDhKeyStrUri
<> "&e2e=v%3D1-2%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"
<> urlEncode True testDhKeyStrUri
<> "%2Csmp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D"
<> urlEncode True testDhKeyStrUri
<> "&e2e=v%3D1-2%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"
strEncode connectionRequestClientDataEmpty
`shouldBe` "simplex:/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D"
<> urlEncode True testDhKeyStrUri
<> "&e2e=v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"
<> "&data=%7B%7D"
<> urlEncode True testDhKeyStrUri
<> "&e2e=v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"
<> "&data=%7B%7D"
strEncode connectionRequestClientData
`shouldBe` "simplex:/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1%26dh%3D"
<> urlEncode True testDhKeyStrUri
<> "&e2e=v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"
<> "&data=%7B%22type%22%3A%22group_link%22%2C%20%22group_link_id%22%3A%22abc%22%7D"
<> urlEncode True testDhKeyStrUri
<> "&e2e=v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"
<> "&data=%7B%22type%22%3A%22group_link%22%2C%20%22group_link_id%22%3A%22abc%22%7D"
it "should parse connection requests" $ do
strDecode
( "https://simplex.chat/invitation#/?smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23"
tests/AgentTests/FunctionalAPITests.hs
+1 -1
View File
@@ -1930,7 +1930,7 @@ testDeliveryReceiptsVersion t = do
disconnectAgentClient a'
disconnectAgentClient b'
testDeliveryReceiptsConcurrent :: (HasCallStack) => ATransport -> IO ()
testDeliveryReceiptsConcurrent :: HasCallStack => ATransport -> IO ()
testDeliveryReceiptsConcurrent t =
withSmpServerConfigOn t cfg {msgQueueQuota = 128} testPort $ \_ -> do
withAgentClients2 $ \a b -> do
tests/AgentTests/SQLiteTests.hs
-1
View File
@@ -7,7 +7,6 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
module AgentTests.SQLiteTests (storeTests) where
tests/CoreTests/BatchingTests.hs
+2 -2
View File
@@ -4,7 +4,7 @@ module CoreTests.BatchingTests (batchingTests) where
import Control.Concurrent.STM
import Control.Monad
import Crypto.Random (MonadRandom(..))
import Crypto.Random (MonadRandom (..))
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import qualified Data.List.NonEmpty as L
@@ -12,7 +12,7 @@ import Simplex.Messaging.Client
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Protocol
import Simplex.Messaging.Transport
import Simplex.Messaging.Version (VersionRange(..))
import Simplex.Messaging.Version (VersionRange (..))
import Test.Hspec
batchingTests :: Spec
tests/CoreTests/CryptoTests.hs
+1 -1
View File
@@ -191,7 +191,7 @@ testAESGCM = it "should encrypt / decrypt string with a random symmetric key" $
cipher `shouldNotBe` plain
s `shouldBe` plain
testEncoding :: (C.AlgorithmI a) => C.SAlgorithm a -> Spec
testEncoding :: C.AlgorithmI a => C.SAlgorithm a -> Spec
testEncoding alg = it "should encode / decode key" . ioProperty $ do
(k, pk) <- C.generateKeyPair alg
pure $ \(_ :: Int) ->
tests/CoreTests/RetryIntervalTests.hs
-1
View File
@@ -1,4 +1,3 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
module CoreTests.RetryIntervalTests where
tests/CoreTests/UtilTests.hs
+1 -1
View File
@@ -6,8 +6,8 @@ import Control.Exception (Exception, SomeException, throwIO)
import Control.Monad.Except
import Control.Monad.IO.Class
import Data.IORef
import Simplex.Messaging.Util
import Simplex.Messaging.Client.Agent ()
import Simplex.Messaging.Util
import Test.Hspec
import qualified UnliftIO.Exception as UE
tests/CoreTests/VersionRangeTests.hs
+4 -3
View File
@@ -39,13 +39,14 @@ versionRangeTests = modifyMaxSuccess (const 1000) $ do
isCompatible (1 :: Version) (vr 2 2) `shouldBe` False
it "compatibleVersion should pass isCompatible check" . property $
\((min1, max1) :: (V, V)) ((min2, max2) :: (V, V)) ->
min1 > max1 || min2 > max2 -- one of ranges is invalid, skip testing it
min1 > max1
|| min2 > max2 -- one of ranges is invalid, skip testing it
|| let w = fromIntegral . fromEnum
vr1 = mkVersionRange (w min1) (w max1) :: VersionRange
vr2 = mkVersionRange (w min2) (w max2) :: VersionRange
in case compatibleVersion vr1 vr2 of
Just (Compatible v) -> v `isCompatible` vr1 && v `isCompatible` vr2
_ -> True
Just (Compatible v) -> v `isCompatible` vr1 && v `isCompatible` vr2
_ -> True
where
vr = mkVersionRange
compatible :: (VersionRange, VersionRange) -> Maybe Version -> Expectation
tests/ServerTests.hs
-1
View File
@@ -832,7 +832,6 @@ testRestoreExpireMessages at@(ATransport t) =
msgs'' <- B.readFile testStoreMsgsFile
length (B.lines msgs'') `shouldBe` 2
B.lines msgs'' `shouldBe` drop 2 (B.lines msgs)
where
runTest :: Transport c => TProxy c -> (THandle c -> IO ()) -> ThreadId -> Expectation
runTest _ test' server = do
tests/XFTPAgent.hs
+6 -6
View File
@@ -292,8 +292,8 @@ testXFTPAgentSendRestore = withGlobalLogging logCfgNoLogs $ do
-- receive file
rcp <- getSMPAgentClient' agentCfg initAgentServers testDB2
runRight_ $
void $ testReceive rcp rfd1 filePath
runRight_ . void $
testReceive rcp rfd1 filePath
testXFTPAgentSendCleanup :: HasCallStack => IO ()
testXFTPAgentSendCleanup = withGlobalLogging logCfgNoLogs $ do
@@ -342,8 +342,8 @@ testXFTPAgentDelete = withGlobalLogging logCfgNoLogs $
-- receive file
rcp1 <- getSMPAgentClient' agentCfg initAgentServers testDB2
runRight_ $
void $ testReceive rcp1 rfd1 filePath
runRight_ . void $
testReceive rcp1 rfd1 filePath
length <$> listDirectory xftpServerFiles `shouldReturn` 6
@@ -377,8 +377,8 @@ testXFTPAgentDeleteRestore = withGlobalLogging logCfgNoLogs $ do
-- receive file
rcp1 <- getSMPAgentClient' agentCfg initAgentServers testDB2
runRight_ $
void $ testReceive rcp1 rfd1 filePath
runRight_ . void $
testReceive rcp1 rfd1 filePath
disconnectAgentClient rcp1
disconnectAgentClient sndr
pure (sfId, sndDescr, rfd2)