Merge remote-tracking branch 'origin/master' into ab/bench-target

2026-09-01 20:18:26 +00:00 · 2024-04-11 19:58:49 +03:00
parent 8ba036b594 3b1dd6dff9
commit f3865f7d1f
54 changed files with 1669 additions and 1160 deletions
@@ -14,12 +14,6 @@ source-repository-package
    location: https://github.com/simplex-chat/aeson.git
    tag: aab7b5a14d6c5ea64c64dcaee418de1bb00dcc2b

-- old bs/text compat for 8.10
-source-repository-package
-    type: git
-    location: https://github.com/simplex-chat/base64.git
-    tag: 2d77b6dbcaffc00570a70be8694049f3710e7c94
-
 source-repository-package
    type: git
    location: https://github.com/simplex-chat/hs-socks.git
@@ -1,5 +1,5 @@
 name: simplexmq
-version: 5.6.1.0
+version: 5.6.2.1
 synopsis: SimpleXMQ message broker
 description: |
  This package includes <./docs/Simplex-Messaging-Server.html server>,
@@ -31,7 +31,7 @@ dependencies:
  - async == 2.2.*
  - attoparsec == 0.14.*
  - base >= 4.14 && < 5
-  - base64 == 1.0.*
+  - base64-bytestring >= 1.0 && < 1.3
  - case-insensitive == 1.2.*
  - composition == 1.0.*
  - constraints >= 0.12 && < 0.14
@@ -169,6 +169,11 @@ tests:
      - silently == 1.2.*
      - main-tester == 0.2.*
      - timeit == 2.0.*
+    ghc-options:
+      - -threaded
+      - -rtsopts
+      - -with-rtsopts=-A64M
+      - -with-rtsopts=-N1

 benchmarks:
  simplexmq-bench:
@@ -0,0 +1,120 @@
+# XFTP version agreement
+
+## Problem
+
+XFTP is using HTTP2 protocol for encoding requests and responses.
+Unlike SMP which has a connection handshake initiated by a server and signals available versions XFTP/HTTP2 is almost entirely client-driven.
+So, a client can only try to guess which protocol versions are supported by a server by sending a probe/hello request first.
+Determining the endpoint for such a request is an implicit version agreement by itself.
+Sending such a request to an old server would error out and requiring it from old clients would break them.
+
+## Solution
+
+The TLS layer used by the XFTP server has an optional [ALPN](https://datatracker.ietf.org/doc/html/rfc7301) extension which allows the client and server to negotiate protocols and store the decision in TLS session context.
+Unless a client and a server run ALPN-aware versions, they would default to the old "unversioned" protocol.
+
+TLS extension content is a 65kb chunk, but ALPN standard breaks it into 254b-sized chunks making it unusable for things like key exchange.
+The exchange is still client-driven: the client proposes a list, and then a server callback picks one.
+In effect, this makes it usable only to signal that some application-level handshake is desired and supported.
+
+## Implementation
+
+ALPN can be used to negotiate for any TLS-based protocol, but the description will focus on XFTP.
+
+TransportClientConfig gets a new `alpn :: Maybe [ALPN]` field so a TLS transport can use it during TLS client creation.
+XFTP client sets it to `Just ["xftp/1"]`.
+The exact value is not important as long it is in agreement with the server side, but ALPN RFC insists on it being an IANA-registered identifier.
+
+XFTP server sets `onALPNClientSuggest` TLS hook to pick the protocol when it is provided.
+The `tls` library treats SHOULD from the RFC as MUST and does a client-side check that the server responded with one of the client-proposed protocols.
+
+Upon connection, transport implementation invokes `getNegotiatedProtocol` and stores it in `tlsALPN :: Maybe ALPN` field of transport context.
+HTTP2 transport implementation using `withHTTP2` passes negotiated "protocol" to client and server setup callbacks where they store it in their respective wrappers along with TLS session ID.
+A server request handler then knows by looking at the `sessionALPN` if it should require a "handshake" request first.
+A client code that got HTTP2Client with `sessionALPN` set knows if it has to proceed with handshake request.
+A handshake request still has to be initiated by a client, so it should be kept minimal, just enough data to pass the initiative to a server.
+A reply to that initial request should contain a server version range for the client to pick.
+A client then commits to a version, sending its part of a handshake.
+
+In the future ALPN negotiation can be dropped in favor of mandatory handshakes or used to signal further handshake schemes.
+
+The XFTP handshake data types and validation code are cloned from SMP.
+Currently they carry version information and session authentication parameters.
+Authentication parameters made mandatory as this exchange is guarded by the handshake version.
+
+### Server side
+
+`runHTTP2Server` callback used by `xftpServer` should get access to the session state to track handshakes.
+A local `TMap SessionId Handshake` is enough to switch request handlers.
+The HTTP2 server framework is extended with a way to signal client disconnection to remove sessions from this map.
+
+The `Handshake` type mimics implicit state in stream based handshakes of SMP and NTF.
+
+```haskell
+data Handshake
+  = HandshakeSent C.PrivateKeyX25519 -- server private key that will be merged with client public in `THandleAuth`
+  | HandshakeAccepted THandleAuth VersionXFTP -- session steady state after handshakes
+```
+
+An HTTP2 request without ALPN is treated as legacy and requires no session entry.
+Its `Request`s are marked with `THandleParams {thVersion = VersionXFTP 1, ..}`.
+
+An HTTP2 request with ALPN requires a session lookup.
+- A lack of entry indicates that a client must send an empty request, to which the server replies with its "server handshake" block and stores its private state in `HandshakeSent`.
+- If the session entry contains `HandshakeSent`, then the only valid request content is the "client handshake" block.
+  The server validates client handshake (in the same way as SMP) and stores authentication and version in `HandshakeAccepted`
+- If the session entry contains `HandshakeAccepted`, then the server just passes it to `THandleParams`.
+
+### Client side
+
+`getXFTPClient` tweaks its transport config to include the ALPN marker and then checks if the client got its `sessionALPN` value.
+If there's a value set, it then sends an initial block and checks out the server handshake in response.
+After validation, it sends "client handshake" request to finish version negotiation.
+
+```haskell
+let tcConfig = (transportClientConfig xftpNetworkConfig) {alpn = Just ["xftp/1"]}
+-- ...
+http2Client <- liftEitherError xftpClientError $ getVerifiedHTTP2Client -- ...
+thVersion <- case sessionALPN http2Client of
+  Nothing -> pure $ VersionXFTP 1
+  Just proto -> negotiate http2Client proto
+```
+
+The resulting `XFTPClient` then contains a negotiated version and can be used to send transmissions with a more recent encoding.
+
+## Block encoding
+
+### Client Hello (request)
+
+A request with an empty body and no padding.
+
+### Server handshake (response)
+
+SMP-encoded and padded to `xftpBlockSize` (~16kb).
+
+```haskell
+data XFTPServerHandshake = XFTPServerHandshake
+  { xftpVersionRange :: VersionRangeXFTP,
+    sessionId :: SessionId, -- validated by client against TLS unique
+    authPubKey ::
+      ( X.CertificateChain, -- fingerprint validated by client against pre-shared hash
+        X.SignedExact X.PubKey -- signature validated by client against server key from TLS
+      )
+  }
+```
+
+### Client handshake (request)
+
+SMP-encoded and padded to `xftpBlockSize` (~16kb).
+
+```haskell
+data XFTPClientHandshake = XFTPClientHandshake
+  { xftpVersion :: VersionXFTP,
+    keyHash :: C.KeyHash, -- validated by server against its own cert fingerprint
+    authPubKey :: C.PublicKeyX25519
+  }
+```
+
+### Server confirmation (response)
+
+A response with an empty body and no padding.
@@ -5,7 +5,7 @@ cabal-version: 1.12
 -- see: https://github.com/sol/hpack

 name:           simplexmq
-version:        5.6.1.0
+version:        5.6.2.1
 synopsis:       SimpleXMQ message broker
 description:    This package includes <./docs/Simplex-Messaging-Server.html server>,
                <./docs/Simplex-Messaging-Client.html client> and
@@ -119,8 +119,6 @@ library
      Simplex.Messaging.Crypto.SNTRUP761.Bindings.FFI
      Simplex.Messaging.Crypto.SNTRUP761.Bindings.RNG
      Simplex.Messaging.Encoding
-      Simplex.Messaging.Encoding.Base64
-      Simplex.Messaging.Encoding.Base64.URL
      Simplex.Messaging.Encoding.String
      Simplex.Messaging.Notifications.Client
      Simplex.Messaging.Notifications.Protocol
@@ -191,7 +189,7 @@ library
    , async ==2.2.*
    , attoparsec ==0.14.*
    , base >=4.14 && <5
-    , base64 ==1.0.*
+    , base64-bytestring >=1.0 && <1.3
    , case-insensitive ==1.2.*
    , composition ==1.0.*
    , constraints >=0.12 && <0.14
@@ -266,7 +264,7 @@ executable ntf-server
    , async ==2.2.*
    , attoparsec ==0.14.*
    , base >=4.14 && <5
-    , base64 ==1.0.*
+    , base64-bytestring >=1.0 && <1.3
    , case-insensitive ==1.2.*
    , composition ==1.0.*
    , constraints >=0.12 && <0.14
@@ -342,7 +340,7 @@ executable smp-agent
    , async ==2.2.*
    , attoparsec ==0.14.*
    , base >=4.14 && <5
-    , base64 ==1.0.*
+    , base64-bytestring >=1.0 && <1.3
    , case-insensitive ==1.2.*
    , composition ==1.0.*
    , constraints >=0.12 && <0.14
@@ -418,7 +416,7 @@ executable smp-server
    , async ==2.2.*
    , attoparsec ==0.14.*
    , base >=4.14 && <5
-    , base64 ==1.0.*
+    , base64-bytestring >=1.0 && <1.3
    , case-insensitive ==1.2.*
    , composition ==1.0.*
    , constraints >=0.12 && <0.14
@@ -494,7 +492,7 @@ executable xftp
    , async ==2.2.*
    , attoparsec ==0.14.*
    , base >=4.14 && <5
-    , base64 ==1.0.*
+    , base64-bytestring >=1.0 && <1.3
    , case-insensitive ==1.2.*
    , composition ==1.0.*
    , constraints >=0.12 && <0.14
@@ -570,7 +568,7 @@ executable xftp-server
    , async ==2.2.*
    , attoparsec ==0.14.*
    , base >=4.14 && <5
-    , base64 ==1.0.*
+    , base64-bytestring >=1.0 && <1.3
    , case-insensitive ==1.2.*
    , composition ==1.0.*
    , constraints >=0.12 && <0.14
@@ -669,7 +667,7 @@ test-suite simplexmq-test
      tests
  default-extensions:
      StrictData
-  ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -O2
+  ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -O2 -threaded -rtsopts -with-rtsopts=-A64M -with-rtsopts=-N1
  build-depends:
      HUnit ==1.6.*
    , QuickCheck ==2.14.*
@@ -680,7 +678,7 @@ test-suite simplexmq-test
    , async ==2.2.*
    , attoparsec ==0.14.*
    , base >=4.14 && <5
-    , base64 ==1.0.*
+    , base64-bytestring >=1.0 && <1.3
    , case-insensitive ==1.2.*
    , composition ==1.0.*
    , constraints >=0.12 && <0.14
@@ -179,7 +179,8 @@ runXFTPRcvWorker c srv Worker {doWork} = do
        RcvFileChunk {rcvFileId, rcvFileEntityId, fileTmpPath, replicas = []} -> rcvWorkerInternalError c rcvFileId rcvFileEntityId (Just fileTmpPath) "chunk has no replicas"
        fc@RcvFileChunk {userId, rcvFileId, rcvFileEntityId, digest, fileTmpPath, replicas = replica@RcvFileChunkReplica {rcvChunkReplicaId, server, delay} : _} -> do
          let ri' = maybe ri (\d -> ri {initialInterval = d, increaseAfter = 0}) delay
-          withRetryIntervalLimit xftpConsecutiveRetries ri' $ \delay' loop ->
+          withRetryIntervalLimit xftpConsecutiveRetries ri' $ \delay' loop -> do
+            lift $ waitForUserNetwork c
            downloadFileChunk fc replica
              `catchAgentError` \e -> retryOnError "XFTP rcv worker" (retryLoop loop e delay') (retryDone e) e
          where
@@ -389,7 +390,7 @@ runXFTPSndPrepareWorker c Worker {doWork} = do
      let numRecipients' = min numRecipients maxRecipients
      -- concurrently?
      -- separate worker to create chunks? record retries and delay on snd_file_chunks?
-      forM_ (filter (not . chunkCreated) chunks) $ createChunk numRecipients'
+      forM_ (filter (\SndFileChunk {replicas} -> null replicas) chunks) $ createChunk numRecipients'
      withStore' c $ \db -> updateSndFileStatus db sndFileId SFSUploading
      where
        AgentConfig {xftpMaxRecipientsPerRequest = maxRecipients, messageRetryInterval = ri} = cfg
@@ -413,9 +414,6 @@ runXFTPSndPrepareWorker c Worker {doWork} = do
          let chunkSpecs = prepareChunkSpecs fsEncPath chunkSizes
          chunkDigests <- liftIO $ mapM getChunkDigest chunkSpecs
          pure (FileDigest digest, zip chunkSpecs $ coerce chunkDigests)
-        chunkCreated :: SndFileChunk -> Bool
-        chunkCreated SndFileChunk {replicas} =
-          any (\SndFileChunkReplica {replicaStatus} -> replicaStatus == SFRSCreated) replicas
        createChunk :: Int -> SndFileChunk -> AM ()
        createChunk numRecipients' ch = do
          atomically $ assertAgentForeground c
@@ -425,7 +423,8 @@ runXFTPSndPrepareWorker c Worker {doWork} = do
          where
            tryCreate = do
              usedSrvs <- newTVarIO ([] :: [XFTPServer])
-              withRetryInterval (riFast ri) $ \_ loop ->
+              withRetryInterval (riFast ri) $ \_ loop -> do
+                lift $ waitForUserNetwork c
                createWithNextSrv usedSrvs
                  `catchAgentError` \e -> retryOnError "XFTP prepare worker" (retryLoop loop) (throwError e) e
              where
@@ -457,7 +456,8 @@ runXFTPSndWorker c srv Worker {doWork} = do
        SndFileChunk {sndFileId, sndFileEntityId, filePrefixPath, replicas = []} -> sndWorkerInternalError c sndFileId sndFileEntityId (Just filePrefixPath) "chunk has no replicas"
        fc@SndFileChunk {userId, sndFileId, sndFileEntityId, filePrefixPath, digest, replicas = replica@SndFileChunkReplica {sndChunkReplicaId, server, delay} : _} -> do
          let ri' = maybe ri (\d -> ri {initialInterval = d, increaseAfter = 0}) delay
-          withRetryIntervalLimit xftpConsecutiveRetries ri' $ \delay' loop ->
+          withRetryIntervalLimit xftpConsecutiveRetries ri' $ \delay' loop -> do
+            lift $ waitForUserNetwork c
            uploadFileChunk cfg fc replica
              `catchAgentError` \e -> retryOnError "XFTP snd worker" (retryLoop loop e delay') (retryDone e) e
          where
@@ -623,7 +623,8 @@ runXFTPDelWorker c srv Worker {doWork} = do
      where
        processDeletedReplica replica@DeletedSndChunkReplica {deletedSndChunkReplicaId, userId, server, chunkDigest, delay} = do
          let ri' = maybe ri (\d -> ri {initialInterval = d, increaseAfter = 0}) delay
-          withRetryIntervalLimit xftpConsecutiveRetries ri' $ \delay' loop ->
+          withRetryIntervalLimit xftpConsecutiveRetries ri' $ \delay' loop -> do
+            lift $ waitForUserNetwork c
            deleteChunkReplica
              `catchAgentError` \e -> retryOnError "XFTP del worker" (retryLoop loop e delay') (retryDone e) e
          where
@@ -4,11 +4,14 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}

 module Simplex.FileTransfer.Client where

+import Control.Logger.Simple
 import Control.Monad
 import Control.Monad.Except
 import Crypto.Random (ChaChaDRG)
@@ -20,9 +23,10 @@ import Data.Int (Int64)
 import Data.List.NonEmpty (NonEmpty (..))
 import Data.Time (UTCTime)
 import Data.Word (Word32)
+import qualified Data.X509 as X
+import qualified Data.X509.Validation as XV
 import qualified Network.HTTP.Types as N
 import qualified Network.HTTP2.Client as H
-import Simplex.FileTransfer.Description (mb)
 import Simplex.FileTransfer.Protocol
 import Simplex.FileTransfer.Transport
 import Simplex.Messaging.Client
@@ -37,6 +41,7 @@ import Simplex.Messaging.Client
 import Simplex.Messaging.Client.Agent ()
 import qualified Simplex.Messaging.Crypto as C
 import qualified Simplex.Messaging.Crypto.Lazy as LC
+import Simplex.Messaging.Encoding (smpDecode, smpEncode)
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol
  ( BasicAuth,
@@ -45,12 +50,13 @@ import Simplex.Messaging.Protocol
    RecipientId,
    SenderId,
  )
-import Simplex.Messaging.Transport (THandleParams (..), supportedParameters)
-import Simplex.Messaging.Transport.Client (TransportClientConfig, TransportHost)
+import Simplex.Messaging.Transport (HandshakeError (VERSION), THandleAuth (..), THandleParams (..), TransportError (..), supportedParameters)
+import Simplex.Messaging.Transport.Client (TransportClientConfig, TransportHost, alpn)
 import Simplex.Messaging.Transport.HTTP2
 import Simplex.Messaging.Transport.HTTP2.Client
 import Simplex.Messaging.Transport.HTTP2.File
-import Simplex.Messaging.Util (bshow, whenM)
+import Simplex.Messaging.Util (bshow, liftEitherWith, liftError', tshow, whenM)
+import Simplex.Messaging.Version (compatibleVersion, pattern Compatible)
 import UnliftIO
 import UnliftIO.Directory

@@ -63,7 +69,7 @@ data XFTPClient = XFTPClient

 data XFTPClientConfig = XFTPClientConfig
  { xftpNetworkConfig :: NetworkConfig,
-    uploadTimeoutPerMb :: Int64
+    serverVRange :: VersionRangeXFTP
  }

 data XFTPChunkBody = XFTPChunkBody
@@ -85,12 +91,12 @@ defaultXFTPClientConfig :: XFTPClientConfig
 defaultXFTPClientConfig =
  XFTPClientConfig
    { xftpNetworkConfig = defaultNetworkConfig,
-      uploadTimeoutPerMb = 10000000 -- 10 seconds
+      serverVRange = supportedFileServerVRange
    }

-getXFTPClient :: TransportSession FileResponse -> XFTPClientConfig -> (XFTPClient -> IO ()) -> IO (Either XFTPClientError XFTPClient)
-getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {xftpNetworkConfig} disconnected = runExceptT $ do
-  let tcConfig = transportClientConfig xftpNetworkConfig
+getXFTPClient :: TVar ChaChaDRG -> TransportSession FileResponse -> XFTPClientConfig -> (XFTPClient -> IO ()) -> IO (Either XFTPClientError XFTPClient)
+getXFTPClient g transportSession@(_, srv, _) config@XFTPClientConfig {xftpNetworkConfig, serverVRange} disconnected = runExceptT $ do
+  let tcConfig = (transportClientConfig xftpNetworkConfig) {alpn = Just ["xftp/1"]}
      http2Config = xftpHTTP2Config tcConfig config
      username = proxyUsername transportSession
      ProtocolServer _ host port keyHash = srv
@@ -98,13 +104,50 @@ getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {xftpNetworkC
  clientVar <- newTVarIO Nothing
  let usePort = if null port then "443" else port
      clientDisconnected = readTVarIO clientVar >>= mapM_ disconnected
-  http2Client <- withExceptT xftpClientError . ExceptT $ getVerifiedHTTP2Client (Just username) useHost usePort (Just keyHash) Nothing http2Config clientDisconnected
-  let HTTP2Client {sessionId} = http2Client
-      thParams = THandleParams {sessionId, blockSize = xftpBlockSize, thVersion = currentXFTPVersion, thAuth = Nothing, implySessId = False, batch = True}
-      c = XFTPClient {http2Client, thParams, transportSession, config}
+  http2Client <- liftError' xftpClientError $ getVerifiedHTTP2Client (Just username) useHost usePort (Just keyHash) Nothing http2Config clientDisconnected
+  let HTTP2Client {sessionId, sessionALPN} = http2Client
+      thParams0 = THandleParams {sessionId, blockSize = xftpBlockSize, thVersion = VersionXFTP 1, thAuth = Nothing, implySessId = False, batch = True}
+  logDebug $ "Client negotiated handshake protocol: " <> tshow sessionALPN
+  thParams <- case sessionALPN of
+    Just "xftp/1" -> xftpClientHandshakeV1 g serverVRange keyHash http2Client thParams0
+    Nothing -> pure thParams0
+    _ -> throwError $ PCETransportError (TEHandshake VERSION)
+  let c = XFTPClient {http2Client, thParams, transportSession, config}
  atomically $ writeTVar clientVar $ Just c
  pure c

+xftpClientHandshakeV1 :: TVar ChaChaDRG -> VersionRangeXFTP -> C.KeyHash -> HTTP2Client -> THandleParamsXFTP -> ExceptT XFTPClientError IO THandleParamsXFTP
+xftpClientHandshakeV1 g serverVRange keyHash@(C.KeyHash kh) c@HTTP2Client {sessionId, serverKey} thParams0 = do
+  shs <- getServerHandshake
+  (v, sk) <- processServerHandshake shs
+  (k, pk) <- atomically $ C.generateKeyPair g
+  sendClientHandshake XFTPClientHandshake {xftpVersion = v, keyHash, authPubKey = k}
+  pure thParams0 {thAuth = Just THandleAuth {peerPubKey = sk, privKey = pk}, thVersion = v}
+  where
+    getServerHandshake = do
+      let helloReq = H.requestNoBody "POST" "/" []
+      HTTP2Response {respBody = HTTP2Body {bodyHead = shsBody}} <-
+        liftError' (const $ PCEResponseError HANDSHAKE) $ sendRequest c helloReq Nothing
+      liftHS . smpDecode =<< liftHS (C.unPad shsBody)
+    processServerHandshake XFTPServerHandshake {xftpVersionRange, sessionId = serverSessId, authPubKey = serverAuth} = do
+      unless (sessionId == serverSessId) $ throwError $ PCEResponseError SESSION
+      case xftpVersionRange `compatibleVersion` serverVRange of
+        Nothing -> throwError $ PCEResponseError HANDSHAKE
+        Just (Compatible v) ->
+          fmap (v,) . liftHS $ do
+            let (X.CertificateChain cert, exact) = serverAuth
+            case cert of
+              [_leaf, ca] | XV.Fingerprint kh == XV.getFingerprint ca X.HashSHA256 -> pure ()
+              _ -> throwError "bad certificate"
+            pubKey <- maybe (throwError "bad server key type") (`C.verifyX509` exact) serverKey
+            C.x509ToPublic (pubKey, []) >>= C.pubKey
+    sendClientHandshake chs = do
+      chs' <- liftHS $ C.pad (smpEncode chs) xftpBlockSize
+      let chsReq = H.requestBuilder "POST" "/" [] $ byteString chs'
+      HTTP2Response {respBody = HTTP2Body {bodyHead}} <- liftError' (const $ PCEResponseError HANDSHAKE) $ sendRequest c chsReq Nothing
+      unless (B.null bodyHead) $ throwError $ PCEResponseError HANDSHAKE
+    liftHS = liftEitherWith (const $ PCEResponseError HANDSHAKE)
+
 closeXFTPClient :: XFTPClient -> IO ()
 closeXFTPClient XFTPClient {http2Client} = closeHTTP2Client http2Client

@@ -144,8 +187,8 @@ sendXFTPCommand c@XFTPClient {thParams} pKey fId cmd chunkSpec_ = do
 sendXFTPTransmission :: XFTPClient -> ByteString -> Maybe XFTPChunkSpec -> ExceptT XFTPClientError IO (FileResponse, HTTP2Body)
 sendXFTPTransmission XFTPClient {config, thParams, http2Client} t chunkSpec_ = do
  let req = H.requestStreaming N.methodPost "/" [] streamBody
-      reqTimeout = (\XFTPChunkSpec {chunkSize} -> chunkTimeout config chunkSize) <$> chunkSpec_
-  HTTP2Response {respBody = body@HTTP2Body {bodyHead}} <- withExceptT xftpClientError . ExceptT $ sendRequest http2Client req reqTimeout
+      reqTimeout = xftpReqTimeout config $ (\XFTPChunkSpec {chunkSize} -> chunkSize) <$> chunkSpec_
+  HTTP2Response {respBody = body@HTTP2Body {bodyHead}} <- withExceptT xftpClientError . ExceptT $ sendRequest http2Client req (Just reqTimeout)
  when (B.length bodyHead /= xftpBlockSize) $ throwError $ PCEResponseError BLOCK
  -- TODO validate that the file ID is the same as in the request?
  (_, _, (_, _fId, respOrErr)) <- liftEither . first PCEResponseError $ xftpDecodeTransmission thParams bodyHead
@@ -198,15 +241,20 @@ downloadXFTPChunk g c@XFTPClient {config} rpKey fId chunkSpec@XFTPRcvChunkSpec {
        let t = chunkTimeout config chunkSize
        ExceptT (sequence <$> (t `timeout` download cbState)) >>= maybe (throwError PCEResponseTimeout) pure
        where
-          download cbState = runExceptT $
-            withExceptT PCEResponseError $
+          download cbState =
+            runExceptT . withExceptT PCEResponseError $
              receiveEncFile chunkPart cbState chunkSpec `catchError` \e ->
                whenM (doesFileExist filePath) (removeFile filePath) >> throwError e
      _ -> throwError $ PCEResponseError NO_FILE
    (r, _) -> throwError . PCEUnexpectedResponse $ bshow r

+xftpReqTimeout :: XFTPClientConfig -> Maybe Word32 -> Int
+xftpReqTimeout cfg@XFTPClientConfig {xftpNetworkConfig = NetworkConfig {tcpTimeout}} chunkSize_ =
+  maybe tcpTimeout (chunkTimeout cfg) chunkSize_
+
 chunkTimeout :: XFTPClientConfig -> Word32 -> Int
-chunkTimeout config chunkSize = fromIntegral $ (fromIntegral chunkSize * uploadTimeoutPerMb config) `div` mb 1
+chunkTimeout XFTPClientConfig {xftpNetworkConfig = NetworkConfig {tcpTimeout, tcpTimeoutPerKb}} sz =
+  tcpTimeout + fromIntegral (min ((fromIntegral sz `div` 1024) * tcpTimeoutPerKb) (fromIntegral (maxBound :: Int)))

 deleteXFTPChunk :: XFTPClient -> C.APrivateAuthKey -> SenderId -> ExceptT XFTPClientError IO ()
 deleteXFTPChunk c spKey sId = sendXFTPCommand c spKey sId FDEL Nothing >>= okResponse
@@ -11,6 +11,7 @@ import Control.Logger.Simple (logInfo)
 import Control.Monad
 import Control.Monad.Except
 import Control.Monad.Trans (lift)
+import Crypto.Random (ChaChaDRG)
 import Data.Bifunctor (first)
 import qualified Data.ByteString.Char8 as B
 import Data.Text (Text)
@@ -60,15 +61,15 @@ newXFTPAgent config = do

 type ME a = ExceptT XFTPClientAgentError IO a

-getXFTPServerClient :: XFTPClientAgent -> XFTPServer -> ME XFTPClient
-getXFTPServerClient XFTPClientAgent {xftpClients, config} srv = do
+getXFTPServerClient :: TVar ChaChaDRG -> XFTPClientAgent -> XFTPServer -> ME XFTPClient
+getXFTPServerClient g XFTPClientAgent {xftpClients, config} srv = do
  atomically getClientVar >>= either newXFTPClient waitForXFTPClient
  where
    connectClient :: ME XFTPClient
    connectClient =
      ExceptT $
        first (XFTPClientAgentError srv)
-          <$> getXFTPClient (1, srv, Nothing) (xftpConfig config) clientDisconnected
+          <$> getXFTPClient g (1, srv, Nothing) (xftpConfig config) clientDisconnected

    clientDisconnected :: XFTPClient -> IO ()
    clientDisconnected _ = do
@@ -333,9 +333,9 @@ cliSendFileOpts SendOptions {filePath, outputDir, numRecipients, xftpServers, re
          rKeys <- atomically $ L.fromList <$> replicateM numRecipients (C.generateAuthKeyPair C.SEd25519 g)
          digest <- liftIO $ getChunkDigest chunkSpec
          let ch = FileInfo {sndKey, size = fromIntegral chunkSize, digest}
-          c <- withRetry retryCount $ getXFTPServerClient a xftpServer
+          c <- withRetry retryCount $ getXFTPServerClient g a xftpServer
          (sndId, rIds) <- withRetry retryCount $ createXFTPChunk c spKey ch (L.map fst rKeys) auth
-          withReconnect a xftpServer retryCount $ \c' -> uploadXFTPChunk c' spKey sndId chunkSpec
+          withReconnect g a xftpServer retryCount $ \c' -> uploadXFTPChunk c' spKey sndId chunkSpec
          logInfo $ "uploaded chunk " <> tshow chunkNo
          uploaded <- atomically . stateTVar uploadedChunks $ \cs ->
            let cs' = fromIntegral chunkSize : cs in (sum cs', cs')
@@ -445,7 +445,7 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath,
      when (FileSize encSize /= size) $ throwError $ CLIError "File size mismatch"
      liftIO $ printNoNewLine "Decrypting file..."
      CryptoFile path _ <- withExceptT cliCryptoError $ decryptChunks encSize chunkPaths key nonce $ fmap CF.plain . getFilePath
-      forM_ chunks $ acknowledgeFileChunk a
+      forM_ chunks $ acknowledgeFileChunk g a
      whenM (doesPathExist encPath) $ removeDirectoryRecursive encPath
      liftIO $ do
        printNoNewLine $ "File downloaded: " <> path
@@ -456,7 +456,7 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath,
      logInfo $ "downloading chunk " <> tshow chunkNo <> " from " <> showServer server <> "..."
      chunkPath <- uniqueCombine encPath $ show chunkNo
      let chunkSpec = XFTPRcvChunkSpec chunkPath (unFileSize chunkSize) (unFileDigest digest)
-      withReconnect a server retryCount $ \c -> downloadXFTPChunk g c replicaKey (unChunkReplicaId replicaId) chunkSpec
+      withReconnect g a server retryCount $ \c -> downloadXFTPChunk g c replicaKey (unChunkReplicaId replicaId) chunkSpec
      logInfo $ "downloaded chunk " <> tshow chunkNo <> " to " <> T.pack chunkPath
      downloaded <- atomically . stateTVar downloadedChunks $ \cs ->
        let cs' = fromIntegral (unFileSize chunkSize) : cs in (sum cs', cs')
@@ -472,12 +472,12 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath,
          ifM (doesDirectoryExist path) (uniqueCombine path name) $
            ifM (doesFileExist path) (throwError "File already exists") (pure path)
        _ -> (`uniqueCombine` name) . (</> "Downloads") =<< getHomeDirectory
-    acknowledgeFileChunk :: XFTPClientAgent -> FileChunk -> ExceptT CLIError IO ()
-    acknowledgeFileChunk a FileChunk {replicas = replica : _} = do
+    acknowledgeFileChunk :: TVar ChaChaDRG -> XFTPClientAgent -> FileChunk -> ExceptT CLIError IO ()
+    acknowledgeFileChunk g a FileChunk {replicas = replica : _} = do
      let FileChunkReplica {server, replicaId, replicaKey} = replica
-      c <- withRetry retryCount $ getXFTPServerClient a server
+      c <- withRetry retryCount $ getXFTPServerClient g a server
      withRetry retryCount $ ackXFTPChunk c replicaKey (unChunkReplicaId replicaId)
-    acknowledgeFileChunk _ _ = throwError $ CLIError "chunk has no replicas"
+    acknowledgeFileChunk _ _ _ = throwError $ CLIError "chunk has no replicas"

 printProgress :: String -> Int64 -> Int64 -> IO ()
 printProgress s part total = printNoNewLine $ s <> " " <> show ((part * 100) `div` total) <> "%"
@@ -501,7 +501,8 @@ cliDeleteFile DeleteOptions {fileDescription, retryCount, yes} = do
    deleteFileChunk :: XFTPClientAgent -> FileChunk -> ExceptT CLIError IO ()
    deleteFileChunk a FileChunk {chunkNo, replicas = replica : _} = do
      let FileChunkReplica {server, replicaId, replicaKey} = replica
-      withReconnect a server retryCount $ \c -> deleteXFTPChunk c replicaKey (unChunkReplicaId replicaId)
+      g <- liftIO C.newRandom
+      withReconnect g a server retryCount $ \c -> deleteXFTPChunk c replicaKey (unChunkReplicaId replicaId)
      logInfo $ "deleted chunk " <> tshow chunkNo <> " from " <> showServer server
    deleteFileChunk _ _ = throwError $ CLIError "chunk has no replicas"

@@ -569,9 +570,9 @@ prepareChunkSpecs filePath chunkSizes = reverse . snd $ foldl' addSpec (0, []) c
 getEncPath :: MonadIO m => Maybe FilePath -> String -> m FilePath
 getEncPath path name = (`uniqueCombine` (name <> ".encrypted")) =<< maybe (liftIO getCanonicalTemporaryDirectory) pure path

-withReconnect :: Show e => XFTPClientAgent -> XFTPServer -> Int -> (XFTPClient -> ExceptT e IO a) -> ExceptT CLIError IO a
-withReconnect a srv n run = withRetry n $ do
-  c <- withRetry n $ getXFTPServerClient a srv
+withReconnect :: Show e => TVar ChaChaDRG -> XFTPClientAgent -> XFTPServer -> Int -> (XFTPClient -> ExceptT e IO a) -> ExceptT CLIError IO a
+withReconnect g a srv n run = withRetry n $ do
+  c <- withRetry n $ getXFTPServerClient g a srv
  withExceptT (CLIError . show) (run c) `catchError` \e -> do
    liftIO $ closeXFTPServerClient a srv
    throwError e
@@ -25,7 +25,7 @@ import Data.List.NonEmpty (NonEmpty (..))
 import Data.Maybe (isNothing)
 import Data.Type.Equality
 import Data.Word (Word32)
-import Simplex.FileTransfer.Transport (VersionXFTP, XFTPErrorType (..), XFTPVersion, pattern VersionXFTP, xftpClientHandshake)
+import Simplex.FileTransfer.Transport (VersionXFTP, XFTPErrorType (..), XFTPVersion, xftpClientHandshakeStub, pattern VersionXFTP)
 import Simplex.Messaging.Client (authTransmission)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
@@ -144,7 +144,7 @@ instance FilePartyI p => ProtocolMsgTag (FileCommandTag p) where
 instance Protocol XFTPVersion XFTPErrorType FileResponse where
  type ProtoCommand FileResponse = FileCmd
  type ProtoType FileResponse = 'PXFTP
-  protocolClientHandshake = xftpClientHandshake
+  protocolClientHandshake = xftpClientHandshakeStub
  protocolPing = FileCmd SFRecipient PING
  protocolError = \case
    FRErr e -> Just e
@@ -329,9 +329,9 @@ checkParty' c = case testEquality (sFileParty @p) (sFileParty @p') of
  _ -> Nothing

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

 xftpEncodeTransmission :: ProtocolEncoding XFTPVersion e c => THandleParams XFTPVersion -> Transmission c -> Either TransportError ByteString
 xftpEncodeTransmission thParams (corrId, fId, msg) = do
@@ -1,4 +1,3 @@
-{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
@@ -10,6 +9,7 @@
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}

 module Simplex.FileTransfer.Server where

@@ -18,7 +18,8 @@ import Control.Monad
 import Control.Monad.Except
 import Control.Monad.Reader
 import Data.Bifunctor (first)
-import Data.ByteString.Builder (byteString)
+import qualified Data.ByteString.Base64.URL as B64
+import Data.ByteString.Builder (Builder, byteString)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Int (Int64)
@@ -32,6 +33,7 @@ import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, getCurrentTime)
 import Data.Time.Clock.System (SystemTime (..), getSystemTime)
 import Data.Time.Format.ISO8601 (iso8601Show)
 import Data.Word (Word32)
+import qualified Data.X509 as X
 import GHC.IO.Handle (hSetNewlineMode)
 import GHC.Stats (getRTSStats)
 import qualified Network.HTTP.Types as N
@@ -46,19 +48,22 @@ import Simplex.FileTransfer.Server.StoreLog
 import Simplex.FileTransfer.Transport
 import qualified Simplex.Messaging.Crypto as C
 import qualified Simplex.Messaging.Crypto.Lazy as LC
-import qualified Simplex.Messaging.Encoding.Base64.URL as U
+import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Protocol (CorrId, RcvPublicAuthKey, RcvPublicDhKey, RecipientId, TransmissionAuth)
+import Simplex.Messaging.Protocol (CorrId (..), RcvPublicAuthKey, RcvPublicDhKey, RecipientId, TransmissionAuth)
 import Simplex.Messaging.Server (dummyVerifyCmd, verifyCmdAuthorization)
 import Simplex.Messaging.Server.Expiration
 import Simplex.Messaging.Server.Stats
-import Simplex.Messaging.Transport (THandleParams (..))
+import Simplex.Messaging.TMap (TMap)
+import qualified Simplex.Messaging.TMap as TM
+import Simplex.Messaging.Transport (SessionId, THandleAuth (..), THandleParams (..))
 import Simplex.Messaging.Transport.Buffer (trimCR)
 import Simplex.Messaging.Transport.HTTP2
 import Simplex.Messaging.Transport.HTTP2.File (fileBlockSize)
 import Simplex.Messaging.Transport.HTTP2.Server
-import Simplex.Messaging.Transport.Server (runTCPServer)
+import Simplex.Messaging.Transport.Server (runTCPServer, tlsServerCredentials)
 import Simplex.Messaging.Util
+import Simplex.Messaging.Version (isCompatible)
 import System.Exit (exitFailure)
 import System.FilePath ((</>))
 import System.IO (hPrint, hPutStrLn, universalNewlineMode)
@@ -70,7 +75,7 @@ import qualified UnliftIO.Exception as E
 type M a = ReaderT XFTPEnv IO a

 data XFTPTransportRequest = XFTPTransportRequest
-  { thParams :: THandleParams XFTPVersion,
+  { thParams :: THandleParamsXFTP,
    reqBody :: HTTP2Body,
    request :: H.Request,
    sendResponse :: H.Response -> IO ()
@@ -84,20 +89,75 @@ runXFTPServer cfg = do
 runXFTPServerBlocking :: TMVar Bool -> XFTPServerConfig -> IO ()
 runXFTPServerBlocking started cfg = newXFTPServerEnv cfg >>= runReaderT (xftpServer cfg started)

+data Handshake
+  = HandshakeSent C.PrivateKeyX25519
+  | HandshakeAccepted THandleAuth VersionXFTP
+
 xftpServer :: XFTPServerConfig -> TMVar Bool -> M ()
-xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpiration} started = do
+xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpiration, fileExpiration} started = do
+  mapM_ (expireServerFiles Nothing) fileExpiration
  restoreServerStats
  raceAny_ (runServer : expireFilesThread_ cfg <> serverStatsThread_ cfg <> controlPortThread_ cfg) `finally` stopServer
  where
    runServer :: M ()
    runServer = do
      serverParams <- asks tlsServerParams
+      let (chain, pk) = tlsServerCredentials serverParams
+      signKey <- liftIO $ case C.x509ToPrivate (pk, []) >>= C.privKey of
+        Right pk' -> pure pk'
+        Left e -> putStrLn ("servers has no valid key: " <> show e) >> exitFailure
      env <- ask
-      liftIO $
-        runHTTP2Server started xftpPort defaultHTTP2BufferSize serverParams transportConfig inactiveClientExpiration $ \sessionId r sendResponse -> do
-          reqBody <- getHTTP2Body r xftpBlockSize
-          let thParams = THandleParams {sessionId, blockSize = xftpBlockSize, thVersion = currentXFTPVersion, thAuth = Nothing, implySessId = False, batch = True}
-          processRequest XFTPTransportRequest {thParams, request = r, reqBody, sendResponse} `runReaderT` env
+      sessions <- atomically TM.empty
+      let cleanup sessionId = atomically $ TM.delete sessionId sessions
+      liftIO . runHTTP2Server started xftpPort defaultHTTP2BufferSize serverParams transportConfig inactiveClientExpiration cleanup $ \sessionId sessionALPN r sendResponse -> do
+        reqBody <- getHTTP2Body r xftpBlockSize
+        let thParams0 = THandleParams {sessionId, blockSize = xftpBlockSize, thVersion = VersionXFTP 1, thAuth = Nothing, implySessId = False, batch = True}
+            req0 = XFTPTransportRequest {thParams = thParams0, request = r, reqBody, sendResponse}
+        flip runReaderT env $ case sessionALPN of
+          Nothing -> processRequest req0
+          Just "xftp/1" ->
+            xftpServerHandshakeV1 chain signKey sessions req0 >>= \case
+              Nothing -> pure () -- handshake response sent
+              Just thParams -> processRequest req0 {thParams} -- proceed with new version (XXX: may as well switch the request handler here)
+          _ -> liftIO . sendResponse $ H.responseNoBody N.ok200 [] -- shouldn't happen: means server picked handshake protocol it doesn't know about
+    xftpServerHandshakeV1 :: X.CertificateChain -> C.APrivateSignKey -> TMap SessionId Handshake -> XFTPTransportRequest -> M (Maybe (THandleParams XFTPVersion))
+    xftpServerHandshakeV1 chain serverSignKey sessions XFTPTransportRequest {thParams = thParams@THandleParams {sessionId}, reqBody = HTTP2Body {bodyHead}, sendResponse} = do
+      s <- atomically $ TM.lookup sessionId sessions
+      r <- runExceptT $ case s of
+        Nothing -> processHello
+        Just (HandshakeSent pk) -> processClientHandshake pk
+        Just (HandshakeAccepted auth v) -> pure $ Just thParams {thAuth = Just auth, thVersion = v}
+      either sendError pure r
+      where
+        processHello = do
+          unless (B.null bodyHead) $ throwError HANDSHAKE
+          (k, pk) <- atomically . C.generateKeyPair =<< asks random
+          atomically $ TM.insert sessionId (HandshakeSent pk) sessions
+          let authPubKey = (chain, C.signX509 serverSignKey $ C.publicToX509 k)
+          let hs = XFTPServerHandshake {xftpVersionRange = supportedFileServerVRange, sessionId, authPubKey}
+          shs <- encodeXftp hs
+          liftIO . sendResponse $ H.responseBuilder N.ok200 [] shs
+          pure Nothing
+        processClientHandshake privKey = do
+          unless (B.length bodyHead == xftpBlockSize) $ throwError HANDSHAKE
+          body <- liftHS $ C.unPad bodyHead
+          XFTPClientHandshake {xftpVersion, keyHash, authPubKey} <- liftHS $ smpDecode body
+          kh <- asks serverIdentity
+          unless (keyHash == kh) $ throwError HANDSHAKE
+          unless (xftpVersion `isCompatible` supportedFileServerVRange) $ throwError HANDSHAKE
+          let auth = THandleAuth {peerPubKey = authPubKey, privKey}
+          atomically $ TM.insert sessionId (HandshakeAccepted auth xftpVersion) sessions
+          liftIO . sendResponse $ H.responseNoBody N.ok200 []
+          pure Nothing
+        sendError :: XFTPErrorType -> M (Maybe (THandleParams XFTPVersion))
+        sendError err = do
+          runExceptT (encodeXftp err) >>= \case
+            Right bs -> liftIO . sendResponse $ H.responseBuilder N.ok200 [] bs
+            Left _ -> logError $ "Error encoding handshake error: " <> tshow err
+          pure Nothing
+        encodeXftp :: Encoding a => a -> ExceptT XFTPErrorType (ReaderT XFTPEnv IO) Builder
+        encodeXftp a = byteString <$> liftHS (C.pad (smpEncode a) xftpBlockSize)
+        liftHS = liftEitherWith (const HANDSHAKE)

    stopServer :: M ()
    stopServer = do
@@ -110,28 +170,10 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira

    expireFiles :: ExpirationConfig -> M ()
    expireFiles expCfg = do
-      st <- asks store
      let interval = checkInterval expCfg * 1000000
      forever $ do
        liftIO $ threadDelay' interval
-        old <- liftIO $ expireBeforeEpoch expCfg
-        sIds <- M.keysSet <$> readTVarIO (files st)
-        forM_ sIds $ \sId -> do
-          threadDelay 100000
-          atomically (expiredFilePath st sId old)
-            >>= mapM_ (maybeRemove $ delete st sId)
-      where
-        maybeRemove del = maybe del (remove del)
-        remove del filePath =
-          ifM
-            (doesFileExist filePath)
-            ((removeFile filePath >> del) `catch` \(e :: SomeException) -> logError $ "failed to remove expired file " <> tshow filePath <> ": " <> tshow e)
-            del
-        delete st sId = do
-          withFileLog (`logDeleteFile` sId)
-          void $ atomically $ deleteFile st sId
-          FileServerStats {filesExpired} <- asks serverStats
-          atomically $ modifyTVar' filesExpired (+ 1)
+        expireServerFiles (Just 100000) expCfg

    serverStatsThread_ :: XFTPServerConfig -> [M ()]
    serverStatsThread_ XFTPServerConfig {logStatsInterval = Just interval, logStatsStartTime, serverStatsLogFile} =
@@ -201,7 +243,7 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
          role <- newTVarIO CPRNone
          cpLoop h role
          where
-            cpLoop h role  = do
+            cpLoop h role = do
              s <- trimCR <$> B.hGetLine h
              case strDecode s of
                Right CPQuit -> hClose h
@@ -235,12 +277,13 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
              CPQuit -> pure ()
              CPSkip -> pure ()
              where
-                withUserRole action = readTVarIO role >>= \case
-                  CPRAdmin -> action
-                  CPRUser -> action
-                  _ -> do
-                    logError "Unauthorized control port command"
-                    hPutStrLn h "AUTH"
+                withUserRole action =
+                  readTVarIO role >>= \case
+                    CPRAdmin -> action
+                    CPRUser -> action
+                    _ -> do
+                      logError "Unauthorized control port command"
+                      hPutStrLn h "AUTH"

 data ServerFile = ServerFile
  { filePath :: FilePath,
@@ -253,10 +296,11 @@ processRequest XFTPTransportRequest {thParams, reqBody = body@HTTP2Body {bodyHea
  | B.length bodyHead /= xftpBlockSize = sendXFTPResponse ("", "", FRErr BLOCK) Nothing
  | otherwise = do
      case xftpDecodeTransmission thParams bodyHead of
-        Right (sig_, signed, (corrId, fId, cmdOrErr)) -> do
+        Right (sig_, signed, (corrId, fId, cmdOrErr)) ->
          case cmdOrErr of
            Right cmd -> do
-              verifyXFTPTransmission sig_ signed fId cmd >>= \case
+              let THandleParams {thAuth} = thParams
+              verifyXFTPTransmission ((,C.cbNonce (bs corrId)) <$> thAuth) sig_ signed fId cmd >>= \case
                VRVerified req -> uncurry send =<< processXFTPRequest body req
                VRFailed -> send (FRErr AUTH) Nothing
            Left e -> send (FRErr e) Nothing
@@ -264,7 +308,6 @@ processRequest XFTPTransportRequest {thParams, reqBody = body@HTTP2Body {bodyHea
            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
      let t_ = xftpEncodeTransmission thParams (corrId, fId, resp)
      liftIO $ sendResponse $ H.responseStreaming N.ok200 [] $ streamBody t_
@@ -283,8 +326,8 @@ processRequest XFTPTransportRequest {thParams, reqBody = body@HTTP2Body {bodyHea

 data VerificationResult = VRVerified XFTPRequest | VRFailed

-verifyXFTPTransmission :: Maybe TransmissionAuth -> ByteString -> XFTPFileId -> FileCmd -> M VerificationResult
-verifyXFTPTransmission tAuth authorized fId cmd =
+verifyXFTPTransmission :: Maybe (THandleAuth, C.CbNonce) -> Maybe TransmissionAuth -> ByteString -> XFTPFileId -> FileCmd -> M VerificationResult
+verifyXFTPTransmission auth_ tAuth authorized fId cmd =
  case cmd of
    FileCmd SFSender (FNEW file rcps auth') -> pure $ XFTPReqNew file rcps auth' `verifyWith` sndKey file
    FileCmd SFRecipient PING -> pure $ VRVerified XFTPReqPing
@@ -299,7 +342,7 @@ verifyXFTPTransmission tAuth authorized fId cmd =
          Right (fr, k) -> XFTPReqCmd fId fr cmd `verifyWith` k
          _ -> maybe False (dummyVerifyCmd Nothing authorized) tAuth `seq` VRFailed
    -- TODO verify with DH authorization
-    req `verifyWith` k = if verifyCmdAuthorization Nothing tAuth authorized k then VRVerified req else VRFailed
+    req `verifyWith` k = if verifyCmdAuthorization auth_ tAuth authorized k then VRVerified req else VRFailed

 processXFTPRequest :: HTTP2Body -> XFTPRequest -> M (FileResponse, Maybe ServerFile)
 processXFTPRequest HTTP2Body {bodyPart} = \case
@@ -392,7 +435,7 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
              \used -> let used' = used + fromIntegral size in if used' <= quota then (True, used') else (False, used)
          receive = do
            path <- asks $ filesPath . config
-            let fPath = path </> B.unpack (U.encode senderId)
+            let fPath = path </> B.unpack (B64.encode senderId)
            receiveChunk (XFTPRcvChunkSpec fPath size digest) >>= \case
              Right () -> do
                stats <- asks serverStats
@@ -413,18 +456,20 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
    sendServerFile :: FileRec -> RcvPublicDhKey -> M (FileResponse, Maybe ServerFile)
    sendServerFile FileRec {senderId, filePath, fileInfo = FileInfo {size}} rDhKey = do
      readTVarIO filePath >>= \case
-        Just path -> do
-          g <- asks random
-          (sDhKey, spDhKey) <- atomically $ C.generateKeyPair g
-          let dhSecret = C.dh' rDhKey spDhKey
-          cbNonce <- atomically $ C.randomCbNonce g
-          case LC.cbInit dhSecret cbNonce of
-            Right sbState -> do
-              stats <- asks serverStats
-              atomically $ modifyTVar' (fileDownloads stats) (+ 1)
-              atomically $ updatePeriodStats (filesDownloaded stats) senderId
-              pure (FRFile sDhKey cbNonce, Just ServerFile {filePath = path, fileSize = size, sbState})
-            _ -> pure (FRErr INTERNAL, Nothing)
+        Just path -> ifM (doesFileExist path) sendFile (pure (FRErr AUTH, Nothing))
+          where
+            sendFile = do
+              g <- asks random
+              (sDhKey, spDhKey) <- atomically $ C.generateKeyPair g
+              let dhSecret = C.dh' rDhKey spDhKey
+              cbNonce <- atomically $ C.randomCbNonce g
+              case LC.cbInit dhSecret cbNonce of
+                Right sbState -> do
+                  stats <- asks serverStats
+                  atomically $ modifyTVar' (fileDownloads stats) (+ 1)
+                  atomically $ updatePeriodStats (filesDownloaded stats) senderId
+                  pure (FRFile sDhKey cbNonce, Just ServerFile {filePath = path, fileSize = size, sbState})
+                _ -> pure (FRErr INTERNAL, Nothing)
        _ -> pure (FRErr NO_FILE, Nothing)

    deleteServerFile :: FileRec -> M FileResponse
@@ -457,6 +502,33 @@ deleteServerFile_ FileRec {senderId, fileInfo, filePath} = do
      atomically $ modifyTVar' (filesCount stats) (subtract 1)
      atomically $ modifyTVar' (filesSize stats) (subtract $ fromIntegral $ size fileInfo)

+expireServerFiles :: Maybe Int -> ExpirationConfig -> M ()
+expireServerFiles itemDelay expCfg = do
+  st <- asks store
+  usedStart <- readTVarIO $ usedStorage st
+  old <- liftIO $ expireBeforeEpoch expCfg
+  files' <- readTVarIO (files st)
+  logInfo $ "Expiration check: " <> tshow (M.size files') <> " files"
+  forM_ (M.keys files') $ \sId -> do
+    mapM_ threadDelay itemDelay
+    atomically (expiredFilePath st sId old)
+      >>= mapM_ (maybeRemove $ delete st sId)
+  usedEnd <- readTVarIO $ usedStorage st
+  logInfo $ "Used " <> mbs usedStart <> " -> " <> mbs usedEnd <> ", " <> mbs (usedStart - usedEnd) <> " reclaimed."
+  where
+    mbs bs = tshow (bs `div` 1048576) <> "mb"
+    maybeRemove del = maybe del (remove del)
+    remove del filePath =
+      ifM
+        (doesFileExist filePath)
+        ((removeFile filePath >> del) `catch` \(e :: SomeException) -> logError $ "failed to remove expired file " <> tshow filePath <> ": " <> tshow e)
+        del
+    delete st sId = do
+      withFileLog (`logDeleteFile` sId)
+      void . atomically $ deleteFile st sId -- will not update usedStorage if sId isn't in store
+      FileServerStats {filesExpired} <- asks serverStats
+      atomically $ modifyTVar' filesExpired (+ 1)
+
 randomId :: Int -> M ByteString
 randomId n = atomically . C.randomBytes n =<< asks random

@@ -2,19 +2,23 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE StrictData #-}

 module Simplex.FileTransfer.Server.Env where

-import Control.Logger.Simple (logInfo)
+import Control.Logger.Simple
 import Control.Monad
 import Control.Monad.IO.Unlift
 import Crypto.Random
+import Data.Default (def)
 import Data.Int (Int64)
+import Data.List (find)
 import Data.List.NonEmpty (NonEmpty)
 import qualified Data.Map.Strict as M
+import Data.Maybe (fromMaybe)
 import Data.Time.Clock (getCurrentTime)
 import Data.Word (Word32)
 import Data.X509.Validation (Fingerprint (..))
@@ -27,6 +31,7 @@ import Simplex.FileTransfer.Server.StoreLog
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Protocol (BasicAuth, RcvPublicAuthKey)
 import Simplex.Messaging.Server.Expiration
+import Simplex.Messaging.Transport (ALPN)
 import Simplex.Messaging.Transport.Server (TransportServerConfig, loadFingerprint, loadTLSServerParams)
 import Simplex.Messaging.Util (tshow)
 import System.IO (IOMode (..))
@@ -94,6 +99,9 @@ defaultFileExpiration =
      checkInterval = 2 * 3600 -- seconds, 2 hours
    }

+supportedXFTPhandshakes :: [ALPN]
+supportedXFTPhandshakes = ["xftp/1"]
+
 newXFTPServerEnv :: XFTPServerConfig -> IO XFTPEnv
 newXFTPServerEnv config@XFTPServerConfig {storeLogFile, fileSizeQuota, caCertificateFile, certificateFile, privateKeyFile} = do
  random <- liftIO C.newRandom
@@ -104,7 +112,14 @@ newXFTPServerEnv config@XFTPServerConfig {storeLogFile, fileSizeQuota, caCertifi
  forM_ fileSizeQuota $ \quota -> do
    logInfo $ "Total / available storage: " <> tshow quota <> " / " <> tshow (quota - used)
    when (quota < used) $ logInfo "WARNING: storage quota is less than used storage, no files can be uploaded!"
-  tlsServerParams <- liftIO $ loadTLSServerParams caCertificateFile certificateFile privateKeyFile
+  tlsServerParams' <- liftIO $ loadTLSServerParams caCertificateFile certificateFile privateKeyFile
+  let tlsServerParams =
+        tlsServerParams'
+          { T.serverHooks =
+              def
+                { T.onALPNClientSuggest = Just $ pure . fromMaybe "" . find (`elem` supportedXFTPhandshakes)
+                }
+          }
  Fingerprint fp <- liftIO $ loadFingerprint caCertificateFile
  serverStats <- atomically . newFileServerStats =<< liftIO getCurrentTime
  pure XFTPEnv {config, store, storeLog, random, tlsServerParams, serverIdentity = C.KeyHash fp, serverStats}
@@ -22,6 +22,7 @@ import Control.Concurrent.STM
 import Control.Monad.Except
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import qualified Data.ByteString.Char8 as B
+import qualified Data.ByteString.Lazy.Char8 as LB
 import Data.Composition ((.:), (.:.))
 import Data.List.NonEmpty (NonEmpty)
 import qualified Data.List.NonEmpty as L
@@ -88,7 +89,7 @@ readWriteFileStore f st = do
  pure s

 readFileStore :: FilePath -> FileStore -> IO ()
-readFileStore f st = mapM_ addFileLogRecord . B.lines =<< B.readFile f
+readFileStore f st = mapM_ (addFileLogRecord . LB.toStrict) . LB.lines =<< LB.readFile f
  where
    addFileLogRecord s = case strDecode s of
      Left e -> B.putStrLn $ "Log parsing error (" <> B.pack e <> "): " <> B.take 100 s
@@ -9,9 +9,16 @@

 module Simplex.FileTransfer.Transport
  ( supportedFileServerVRange,
-    xftpClientHandshake, -- stub
-    XFTPVersion,
+    xftpClientHandshakeStub,
+    XFTPClientHandshake (..),
+    -- xftpClientHandshake,
+    XFTPServerHandshake (..),
+    -- xftpServerHandshake,
+    THandleXFTP,
+    THandleParamsXFTP,
    VersionXFTP,
+    VersionRangeXFTP,
+    XFTPVersion,
    pattern VersionXFTP,
    XFTPErrorType (..),
    XFTPRcvChunkSpec (..),
@@ -30,20 +37,21 @@ import Control.Monad.Except
 import Control.Monad.IO.Class
 import qualified Data.Aeson.TH as J
 import qualified Data.Attoparsec.ByteString.Char8 as A
-import Data.Bifunctor (first)
+import Data.Bifunctor (bimap, first)
 import qualified Data.ByteArray as BA
 import Data.ByteString.Builder (Builder, byteString)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy.Char8 as LB
 import Data.Word (Word16, Word32)
+import qualified Data.X509 as X
 import qualified Simplex.Messaging.Crypto as C
 import qualified Simplex.Messaging.Crypto.Lazy as LC
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers
 import Simplex.Messaging.Protocol (CommandError)
-import Simplex.Messaging.Transport (HandshakeError (..), THandle, TransportError (..))
+import Simplex.Messaging.Transport (HandshakeError (..), SessionId, THandle (..), THandleParams (..), TransportError (..))
 import Simplex.Messaging.Transport.HTTP2.File
 import Simplex.Messaging.Util (bshow)
 import Simplex.Messaging.Version
@@ -68,6 +76,9 @@ type VersionRangeXFTP = VersionRange XFTPVersion
 pattern VersionXFTP :: Word16 -> VersionXFTP
 pattern VersionXFTP v = Version v

+type THandleXFTP c = THandle XFTPVersion c
+type THandleParamsXFTP = THandleParams XFTPVersion
+
 initialXFTPVersion :: VersionXFTP
 initialXFTPVersion = VersionXFTP 1

@@ -75,8 +86,45 @@ supportedFileServerVRange :: VersionRangeXFTP
 supportedFileServerVRange = mkVersionRange initialXFTPVersion initialXFTPVersion

 -- XFTP protocol does not support handshake
-xftpClientHandshake :: c -> C.KeyPairX25519 -> C.KeyHash -> VersionRangeXFTP -> ExceptT TransportError IO (THandle XFTPVersion c)
-xftpClientHandshake _c _ks _keyHash _xftpVRange = throwError $ TEHandshake VERSION
+xftpClientHandshakeStub :: c -> C.KeyPairX25519 -> C.KeyHash -> VersionRangeXFTP -> ExceptT TransportError IO (THandle XFTPVersion c)
+xftpClientHandshakeStub _c _ks _keyHash _xftpVRange = throwError $ TEHandshake VERSION
+
+data XFTPServerHandshake = XFTPServerHandshake
+  { xftpVersionRange :: VersionRangeXFTP,
+    sessionId :: SessionId,
+    -- | pub key to agree shared secrets for command authorization and entity ID encryption.
+    authPubKey :: (X.CertificateChain, X.SignedExact X.PubKey)
+  }
+
+data XFTPClientHandshake = XFTPClientHandshake
+  { -- | agreed XFTP server protocol version
+    xftpVersion :: VersionXFTP,
+    -- | server identity - CA certificate fingerprint
+    keyHash :: C.KeyHash,
+    -- | pub key to agree shared secret for entity ID encryption, shared secret for command authorization is agreed using per-queue keys.
+    authPubKey :: C.PublicKeyX25519
+  }
+
+instance Encoding XFTPClientHandshake where
+  smpEncode XFTPClientHandshake {xftpVersion, keyHash, authPubKey} =
+    smpEncode (xftpVersion, keyHash, authPubKey)
+  smpP = do
+    (xftpVersion, keyHash) <- smpP
+    authPubKey <- smpP
+    Tail _compat <- smpP
+    pure XFTPClientHandshake {xftpVersion, keyHash, authPubKey}
+
+instance Encoding XFTPServerHandshake where
+  smpEncode XFTPServerHandshake {xftpVersionRange, sessionId, authPubKey} =
+    smpEncode (xftpVersionRange, sessionId, auth)
+    where
+      auth = bimap C.encodeCertChain C.SignedObject authPubKey
+  smpP = do
+    (xftpVersionRange, sessionId) <- smpP
+    cert <- C.certChainP
+    C.SignedObject key <- smpP
+    Tail _compat <- smpP
+    pure XFTPServerHandshake {xftpVersionRange, sessionId, authPubKey = (cert, key)}

 sendEncFile :: Handle -> (Builder -> IO ()) -> LC.SbState -> Word32 -> IO ()
 sendEncFile h send = go
@@ -139,6 +187,8 @@ data XFTPErrorType
    BLOCK
  | -- | incorrect SMP session ID (TLS Finished message / tls-unique binding RFC5929)
    SESSION
+  | -- | incorrect handshake command
+    HANDSHAKE
  | -- | SMP command is unknown or has invalid syntax
    CMD {cmdErr :: CommandError}
  | -- | command authorization error - bad signature or non-existing SMP queue
@@ -181,6 +231,7 @@ instance Encoding XFTPErrorType where
  smpEncode = \case
    BLOCK -> "BLOCK"
    SESSION -> "SESSION"
+    HANDSHAKE -> "HANDSHAKE"
    CMD err -> "CMD " <> smpEncode err
    AUTH -> "AUTH"
    SIZE -> "SIZE"
@@ -199,6 +250,7 @@ instance Encoding XFTPErrorType where
    A.takeTill (== ' ') >>= \case
      "BLOCK" -> pure BLOCK
      "SESSION" -> pure SESSION
+      "HANDSHAKE" -> pure HANDSHAKE
      "CMD" -> CMD <$> _smpP
      "AUTH" -> pure AUTH
      "SIZE" -> pure SIZE
@@ -82,6 +82,7 @@ module Simplex.Messaging.Agent
    setNtfServers,
    setNetworkConfig,
    getNetworkConfig,
+    setUserNetworkInfo,
    reconnectAllServers,
    registerNtfToken,
    verifyNtfToken,
@@ -402,17 +403,32 @@ testProtocolServer c userId srv = withAgentEnv' c $ case protocolTypeI @p of
  SPXFTP -> runXFTPServerTest c userId srv
  SPNTF -> runNTFServerTest c userId srv

-- | set SOCKS5 proxy on/off and optionally set TCP timeout
+-- | set SOCKS5 proxy on/off and optionally set TCP timeouts for fast network
 setNetworkConfig :: AgentClient -> NetworkConfig -> IO ()
-setNetworkConfig c cfg' = do
-  cfg <- atomically $ do
-    swapTVar (useNetworkConfig c) cfg'
-  when (cfg /= cfg') $ reconnectAllServers c
+setNetworkConfig c@AgentClient {useNetworkConfig} cfg' = do
+  changed <- atomically $ do
+    (_, cfg) <- readTVar useNetworkConfig
+    if cfg == cfg'
+      then pure False
+      else True <$ (writeTVar useNetworkConfig $! (slowNetworkConfig cfg', cfg'))
+  when changed $ reconnectAllServers c

+-- returns fast network config
 getNetworkConfig :: AgentClient -> IO NetworkConfig
-getNetworkConfig = readTVarIO . useNetworkConfig
+getNetworkConfig = fmap snd . readTVarIO . useNetworkConfig
 {-# INLINE getNetworkConfig #-}

+setUserNetworkInfo :: AgentClient -> UserNetworkInfo -> IO ()
+setUserNetworkInfo c@AgentClient {userNetworkState} UserNetworkInfo {networkType = nt'} = withAgentEnv' c $ do
+  d <- asks $ initialInterval . userNetworkInterval . config
+  ts <- liftIO getCurrentTime
+  atomically $ do
+    ns@UserNetworkState {networkType = nt} <- readTVar userNetworkState
+    when (nt' /= nt) $
+      writeTVar userNetworkState $! case nt' of
+        UNNone -> ns {networkType = nt', offline = Just UNSOffline {offlineDelay = d, offlineFrom = ts}}
+        _ -> ns {networkType = nt', offline = Nothing}
+
 reconnectAllServers :: AgentClient -> IO ()
 reconnectAllServers c = do
  reconnectServerClients c smpClients
@@ -1267,6 +1283,7 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} ConnData {connId} sq (Worker {doWork
        let mId = unId msgId
            ri' = maybe id updateRetryInterval2 msgRetryState ri
        withRetryLock2 ri' qLock $ \riState loop -> do
+          lift $ waitForUserNetwork c
          resp <- tryError $ case msgType of
            AM_CONN_INFO -> sendConfirmation c sq msgBody
            AM_CONN_INFO_REPLY -> sendConfirmation c sq msgBody
@@ -2047,7 +2064,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), _v,
              pure ack'
            where
              queueDrained = case conn of
-                DuplexConnection _ _ sqs -> void $ enqueueMessages c cData sqs SMP.noMsgFlags $ QCONT (sndAddress rq)
+                DuplexConnection _ _ sqs -> void $ enqueueMessages c cData sqs SMP.noMsgFlags $ A_QCONT (sndAddress rq)
                _ -> pure ()
              processClientMsg srvTs msgFlags msgBody = do
                clientMsg@SMP.ClientMsgEnvelope {cmHeader = SMP.PubHeader phVer e2ePubKey_} <-
@@ -2096,7 +2113,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), _v,
                                notify $ MSG msgMeta msgFlags body
                                pure ACKPending
                              A_RCVD rcpts -> qDuplex conn'' "RCVD" $ messagesRcvd rcpts msgMeta
-                              QCONT addr -> qDuplexAckDel conn'' "QCONT" $ continueSending srvMsgId addr
+                              A_QCONT addr -> qDuplexAckDel conn'' "QCONT" $ continueSending srvMsgId addr
                              QADD qs -> qDuplexAckDel conn'' "QADD" $ qAddMsg srvMsgId qs
                              QKEY qs -> qDuplexAckDel conn'' "QKEY" $ qKeyMsg srvMsgId qs
                              QUSE qs -> qDuplexAckDel conn'' "QUSE" $ qUseMsg srvMsgId qs
@@ -2310,6 +2327,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), _v,
                atomically $
                  TM.lookup (qAddress sq) (smpDeliveryWorkers c)
                    >>= mapM_ (\(_, retryLock) -> tryPutTMVar retryLock ())
+                notify QCONT
              Nothing -> qError "QCONT: queue address not found"

          messagesRcvd :: NonEmpty AMessageReceipt -> MsgMeta -> Connection 'CDuplex -> AM ACKd
@@ -2351,10 +2369,10 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), _v,
                    case L.nonEmpty keepSqs of
                      Just sqs' -> do
                        -- move inside case?
-                        withStore' c $ \db -> mapM_ (deleteConnSndQueue db connId) delSqs
                        sq_@SndQueue {sndPublicKey, e2ePubKey} <- lift $ newSndQueue userId connId qInfo
-                        let sq'' = (sq_ :: NewSndQueue) {primary = True, dbReplaceQueueId = Just dbQueueId}
-                        sq2 <- withStore c $ \db -> addConnSndQueue db connId sq''
+                        sq2 <- withStore c $ \db -> do
+                          liftIO $ mapM_ (deleteConnSndQueue db connId) delSqs
+                          addConnSndQueue db connId (sq_ :: NewSndQueue) {primary = True, dbReplaceQueueId = Just dbQueueId}
                        case (sndPublicKey, e2ePubKey) of
                          (Just sndPubKey, Just dhPublicKey) -> do
                            logServer "<--" c srv rId $ "MSG <QADD>:" <> logSecret srvMsgId <> " " <> logSecret (senderId queueAddress)
@@ -27,6 +27,7 @@ module Simplex.Messaging.Agent.Client
    withConnLock,
    withConnLocks,
    withInvLock,
+    withLockMap,
    closeAgentClient,
    closeProtocolServerClients,
    reconnectServerClients,
@@ -80,6 +81,7 @@ module Simplex.Messaging.Agent.Client
    agentClientStore,
    agentDRG,
    getAgentSubscriptions,
+    slowNetworkConfig,
    Worker (..),
    SessionVar (..),
    SubscriptionsInfo (..),
@@ -99,6 +101,11 @@ module Simplex.Messaging.Agent.Client
    agentOperations,
    agentOperationBracket,
    waitUntilActive,
+    UserNetworkInfo (..),
+    UserNetworkType (..),
+    UserNetworkState (..),
+    UNSOffline (..),
+    waitForUserNetwork,
    throwWhenInactive,
    throwWhenNoDelivery,
    beginAgentOperation,
@@ -132,7 +139,7 @@ import Control.Applicative ((<|>))
 import Control.Concurrent (ThreadId, forkIO, threadDelay)
 import Control.Concurrent.Async (Async, uninterruptibleCancel)
 import Control.Concurrent.STM (retry, throwSTM)
-import Control.Exception (AsyncException (..))
+import Control.Exception (AsyncException (..), BlockedIndefinitelyOnSTM (..))
 import Control.Logger.Simple
 import Control.Monad
 import Control.Monad.Except
@@ -142,11 +149,13 @@ import Crypto.Random (ChaChaDRG)
 import qualified Data.Aeson as J
 import qualified Data.Aeson.TH as J
 import Data.Bifunctor (bimap, first, second)
+import Data.ByteString.Base64
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Composition ((.:.))
 import Data.Either (lefts, partitionEithers)
 import Data.Functor (($>))
+import Data.Int (Int64)
 import Data.List (deleteFirstsBy, foldl', partition, (\\))
 import Data.List.NonEmpty (NonEmpty (..), (<|))
 import qualified Data.List.NonEmpty as L
@@ -157,7 +166,7 @@ import Data.Set (Set)
 import qualified Data.Set as S
 import Data.Text (Text)
 import Data.Text.Encoding
-import Data.Time (UTCTime, defaultTimeLocale, formatTime, getCurrentTime)
+import Data.Time (UTCTime, defaultTimeLocale, diffUTCTime, formatTime, getCurrentTime)
 import Data.Time.Clock.System (getSystemTime)
 import Data.Word (Word16)
 import Network.Socket (HostName)
@@ -165,7 +174,7 @@ import Simplex.FileTransfer.Client (XFTPChunkSpec (..), XFTPClient, XFTPClientCo
 import qualified Simplex.FileTransfer.Client as X
 import Simplex.FileTransfer.Description (ChunkReplicaId (..), FileDigest (..), kb)
 import Simplex.FileTransfer.Protocol (FileInfo (..), FileResponse)
-import Simplex.FileTransfer.Transport (XFTPRcvChunkSpec (..), XFTPErrorType (DIGEST), XFTPVersion)
+import Simplex.FileTransfer.Transport (XFTPErrorType (DIGEST), XFTPRcvChunkSpec (..), XFTPVersion)
 import Simplex.FileTransfer.Types (DeletedSndChunkReplica (..), NewSndChunkReplica (..), RcvFileChunkReplica (..), SndFileChunk (..), SndFileChunkReplica (..))
 import Simplex.FileTransfer.Util (uniqueCombine)
 import Simplex.Messaging.Agent.Env.SQLite
@@ -181,7 +190,6 @@ import Simplex.Messaging.Client
 import Simplex.Messaging.Client.Agent ()
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
-import Simplex.Messaging.Encoding.Base64 (encode)
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Notifications.Client
 import Simplex.Messaging.Notifications.Protocol
@@ -195,6 +203,7 @@ import Simplex.Messaging.Protocol
    ErrorType,
    MsgFlags (..),
    MsgId,
+    NtfPublicAuthKey,
    NtfServer,
    NtfServerWithAuth,
    ProtoServer,
@@ -206,22 +215,21 @@ import Simplex.Messaging.Protocol
    QueueIdsKeys (..),
    RcvMessage (..),
    RcvNtfPublicDhKey,
-    NtfPublicAuthKey,
    SMPMsgMeta (..),
    SProtocolType (..),
    SndPublicAuthKey,
    SubscriptionMode (..),
    UserProtocol,
+    VersionRangeSMPC,
+    VersionSMPC,
    XFTPServer,
    XFTPServerWithAuth,
-    VersionSMPC,
-    VersionRangeSMPC,
    sameSrvAddr',
  )
 import qualified Simplex.Messaging.Protocol as SMP
-import Simplex.Messaging.Transport (SMPVersion)
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
+import Simplex.Messaging.Transport (SMPVersion)
 import Simplex.Messaging.Transport.Client (TransportHost)
 import Simplex.Messaging.Util
 import Simplex.Messaging.Version
@@ -264,7 +272,8 @@ data AgentClient = AgentClient
    ntfClients :: TMap NtfTransportSession NtfClientVar,
    xftpServers :: TMap UserId (NonEmpty XFTPServerWithAuth),
    xftpClients :: TMap XFTPTransportSession XFTPClientVar,
-    useNetworkConfig :: TVar NetworkConfig,
+    useNetworkConfig :: TVar (NetworkConfig, NetworkConfig), -- (slow, fast) networks
+    userNetworkState :: TVar UserNetworkState,
    subscrConns :: TVar (Set ConnId),
    activeSubs :: TRcvQueues,
    pendingSubs :: TRcvQueues,
@@ -395,6 +404,23 @@ data AgentStatsKey = AgentStatsKey
  }
  deriving (Eq, Ord, Show)

+data UserNetworkInfo = UserNetworkInfo
+  { networkType :: UserNetworkType
+  }
+  deriving (Show)
+
+data UserNetworkType = UNNone | UNCellular | UNWifi | UNEthernet | UNOther
+  deriving (Eq, Show)
+
+data UserNetworkState = UserNetworkState
+  { networkType :: UserNetworkType,
+    offline :: Maybe UNSOffline
+  }
+  deriving (Show)
+
+data UNSOffline = UNSOffline {offlineDelay :: Int64, offlineFrom :: UTCTime}
+  deriving (Show)
+
 -- | Creates an SMP agent client instance that receives commands and sends responses via 'TBQueue's.
 newAgentClient :: Int -> InitialAgentServers -> Env -> STM AgentClient
 newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg} agentEnv = do
@@ -410,7 +436,8 @@ newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg} agentEnv =
  ntfClients <- TM.empty
  xftpServers <- newTVar xftp
  xftpClients <- TM.empty
-  useNetworkConfig <- newTVar netCfg
+  useNetworkConfig <- newTVar (slowNetworkConfig netCfg, netCfg)
+  userNetworkState <- newTVar $ UserNetworkState UNOther Nothing
  subscrConns <- newTVar S.empty
  activeSubs <- RQ.empty
  pendingSubs <- RQ.empty
@@ -445,6 +472,7 @@ newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg} agentEnv =
        xftpServers,
        xftpClients,
        useNetworkConfig,
+        userNetworkState,
        subscrConns,
        activeSubs,
        pendingSubs,
@@ -469,6 +497,13 @@ newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg} agentEnv =
        agentEnv
      }

+slowNetworkConfig :: NetworkConfig -> NetworkConfig
+slowNetworkConfig cfg@NetworkConfig {tcpConnectTimeout, tcpTimeout, tcpTimeoutPerKb} =
+  cfg {tcpConnectTimeout = slow tcpConnectTimeout, tcpTimeout = slow tcpTimeout, tcpTimeoutPerKb = slow tcpTimeoutPerKb}
+  where
+    slow :: Integral a => a -> a
+    slow t = (t * 3) `div` 2
+
 agentClientStore :: AgentClient -> SQLiteStore
 agentClientStore AgentClient {agentEnv = Env {store}} = store
 {-# INLINE agentClientStore #-}
@@ -531,7 +566,8 @@ getSMPServerClient c@AgentClient {active, smpClients, msgQ} tSess@(userId, srv,
      g <- asks random
      env <- ask
      liftError' (protocolClientError SMP $ B.unpack $ strEncode srv) $
-        getProtocolClient g tSess cfg (Just msgQ) $ clientDisconnected env v
+        getProtocolClient g tSess cfg (Just msgQ) $
+          clientDisconnected env v

    clientDisconnected :: Env -> SMPClientVar -> SMPClient -> IO ()
    clientDisconnected env v client = do
@@ -580,6 +616,7 @@ resubscribeSMPSession c@AgentClient {smpSubWorkers} tSess =
      withRetryInterval ri $ \_ loop -> do
        pending <- atomically getPending
        forM_ (L.nonEmpty pending) $ \qs -> do
+          waitForUserNetwork c
          void . tryAgentError' $ reconnectSMPClient timeoutCounts c tSess qs
          loop
    getPending = RQ.getSessQueues tSess $ pendingSubs c
@@ -592,7 +629,7 @@ resubscribeSMPSession c@AgentClient {smpSubWorkers} tSess =

 reconnectSMPClient :: TVar Int -> AgentClient -> SMPTransportSession -> NonEmpty RcvQueue -> AM ()
 reconnectSMPClient tc c tSess@(_, srv, _) qs = do
-  NetworkConfig {tcpTimeout} <- readTVarIO $ useNetworkConfig c
+  NetworkConfig {tcpTimeout} <- atomically $ getNetworkConfig c
  -- this allows 3x of timeout per batch of subscription (90 queues per batch empirically)
  let t = (length qs `div` 90 + 1) * tcpTimeout * 3
  ExceptT (sequence <$> (t `timeout` runExceptT resubscribe)) >>= \case
@@ -634,7 +671,8 @@ getNtfServerClient c@AgentClient {active, ntfClients} tSess@(userId, srv, _) = d
      cfg <- lift $ getClientConfig c ntfCfg
      g <- asks random
      liftError' (protocolClientError NTF $ B.unpack $ strEncode srv) $
-        getProtocolClient g tSess cfg Nothing $ clientDisconnected v
+        getProtocolClient g tSess cfg Nothing $
+          clientDisconnected v

    clientDisconnected :: NtfClientVar -> NtfClient -> IO ()
    clientDisconnected v client = do
@@ -644,7 +682,7 @@ getNtfServerClient c@AgentClient {active, ntfClients} tSess@(userId, srv, _) = d
      logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv

 getXFTPServerClient :: AgentClient -> XFTPTransportSession -> AM XFTPClient
-getXFTPServerClient c@AgentClient {active, xftpClients, useNetworkConfig} tSess@(userId, srv, _) = do
+getXFTPServerClient c@AgentClient {active, xftpClients} tSess@(userId, srv, _) = do
  unlessM (readTVarIO active) . throwError $ INACTIVE
  atomically (getTSessVar c tSess xftpClients)
    >>= either
@@ -654,9 +692,11 @@ getXFTPServerClient c@AgentClient {active, xftpClients, useNetworkConfig} tSess@
    connectClient :: XFTPClientVar -> AM XFTPClient
    connectClient v = do
      cfg <- asks $ xftpCfg . config
-      xftpNetworkConfig <- readTVarIO useNetworkConfig
+      g <- asks random
+      xftpNetworkConfig <- atomically $ getNetworkConfig c
      liftError' (protocolClientError XFTP $ B.unpack $ strEncode srv) $
-        X.getXFTPClient tSess cfg {xftpNetworkConfig} $ clientDisconnected v
+        X.getXFTPClient g tSess cfg {xftpNetworkConfig} $
+          clientDisconnected v

    clientDisconnected :: XFTPClientVar -> XFTPClient -> IO ()
    clientDisconnected v client = do
@@ -688,7 +728,7 @@ removeTSessVar' v tSess vs =

 waitForProtocolClient :: ProtocolTypeI (ProtoType msg) => AgentClient -> TransportSession msg -> ClientVar msg -> AM (Client msg)
 waitForProtocolClient c (_, srv, _) v = do
-  NetworkConfig {tcpConnectTimeout} <- readTVarIO $ useNetworkConfig c
+  NetworkConfig {tcpConnectTimeout} <- atomically $ getNetworkConfig c
  client_ <- liftIO $ tcpConnectTimeout `timeout` atomically (readTMVar $ sessionVar v)
  liftEither $ case client_ of
    Just (Right smpClient) -> Right smpClient
@@ -724,11 +764,51 @@ hostEvent :: forall v err msg. (ProtocolTypeI (ProtoType msg), ProtocolServerCli
 hostEvent event = event (AProtocolType $ protocolTypeI @(ProtoType msg)) . clientTransportHost

 getClientConfig :: AgentClient -> (AgentConfig -> ProtocolClientConfig v) -> AM' (ProtocolClientConfig v)
-getClientConfig AgentClient {useNetworkConfig} cfgSel = do
+getClientConfig c cfgSel = do
  cfg <- asks $ cfgSel . config
-  networkConfig <- readTVarIO useNetworkConfig
+  networkConfig <- atomically $ getNetworkConfig c
  pure cfg {networkConfig}

+getNetworkConfig :: AgentClient -> STM NetworkConfig
+getNetworkConfig c = do
+  (slowCfg, fastCfg) <- readTVar (useNetworkConfig c)
+  UserNetworkState {networkType} <- readTVar (userNetworkState c)
+  pure $ case networkType of
+    UNCellular -> slowCfg
+    UNNone -> slowCfg
+    _ -> fastCfg
+
+waitForUserNetwork :: AgentClient -> AM' ()
+waitForUserNetwork AgentClient {userNetworkState} =
+  (offline <$> readTVarIO userNetworkState) >>= mapM_ waitWhileOffline
+  where
+    waitWhileOffline UNSOffline {offlineDelay = d} =
+      unlessM (liftIO $ waitOnline d False) $ do -- network delay reached, increase delay
+        ts' <- liftIO getCurrentTime
+        ni <- asks $ userNetworkInterval . config
+        atomically $ do
+          ns@UserNetworkState {offline} <- readTVar userNetworkState
+          forM_ offline $ \UNSOffline {offlineDelay = d', offlineFrom = ts} ->
+            -- Using `min` to avoid multiple updates in a short period of time
+            -- and to reset `offlineDelay` if network went `on` and `off` again.
+            writeTVar userNetworkState $!
+              let d'' = nextRetryDelay (diffToMicroseconds $ diffUTCTime ts' ts) (min d d') ni
+                in ns {offline = Just UNSOffline {offlineDelay = d'', offlineFrom = ts}}
+    waitOnline :: Int64 -> Bool -> IO Bool
+    waitOnline t online'
+      | t <= 0 = pure online'
+      | otherwise =
+          registerDelay (fromIntegral maxWait)
+            >>= atomically . onlineOrDelay
+            >>= waitOnline (t - maxWait)
+      where
+        maxWait = min t $ fromIntegral (maxBound :: Int)
+        onlineOrDelay delay = do
+          online <- isNothing . offline <$> readTVar userNetworkState
+          expired <- readTVar delay
+          unless (online || expired) retry
+          pure online
+
 closeAgentClient :: AgentClient -> IO ()
 closeAgentClient c = do
  atomically $ writeTVar (active c) False
@@ -784,8 +864,8 @@ closeClient c clientSel tSess =

 closeClient_ :: ProtocolServerClient v err msg => AgentClient -> ClientVar msg -> IO ()
 closeClient_ c v = do
-  NetworkConfig {tcpConnectTimeout} <- readTVarIO $ useNetworkConfig c
-  tcpConnectTimeout `timeout` atomically (readTMVar $ sessionVar v) >>= \case
+  NetworkConfig {tcpConnectTimeout} <- atomically $ getNetworkConfig c
+  E.handle (\BlockedIndefinitelyOnSTM -> pure ()) $ tcpConnectTimeout `timeout` atomically (readTMVar $ sessionVar v) >>= \case
    Just (Right client) -> closeProtocolServerClient client `catchAll_` pure ()
    _ -> pure ()

@@ -799,7 +879,7 @@ withConnLock c connId name = ExceptT . withConnLock' c connId name . runExceptT

 withConnLock' :: AgentClient -> ConnId -> String -> AM' a -> AM' a
 withConnLock' _ "" _ = id
-withConnLock' AgentClient {connLocks} connId name = withLockMap_ connLocks connId name
+withConnLock' AgentClient {connLocks} connId name = withLockMap connLocks connId name
 {-# INLINE withConnLock' #-}

 withInvLock :: AgentClient -> ByteString -> String -> AM a -> AM a
@@ -807,16 +887,16 @@ withInvLock c key name = ExceptT . withInvLock' c key name . runExceptT
 {-# INLINE withInvLock #-}

 withInvLock' :: AgentClient -> ByteString -> String -> AM' a -> AM' a
-withInvLock' AgentClient {invLocks} = withLockMap_ invLocks
+withInvLock' AgentClient {invLocks} = withLockMap invLocks
 {-# INLINE withInvLock' #-}

 withConnLocks :: AgentClient -> [ConnId] -> String -> AM' a -> AM' a
 withConnLocks AgentClient {connLocks} = withLocksMap_ connLocks . filter (not . B.null)
 {-# INLINE withConnLocks #-}

-withLockMap_ :: (Ord k, MonadUnliftIO m) => TMap k Lock -> k -> String -> m a -> m a
-withLockMap_ = withGetLock . getMapLock
-{-# INLINE withLockMap_ #-}
+withLockMap :: (Ord k, MonadUnliftIO m) => TMap k Lock -> k -> String -> m a -> m a
+withLockMap = withGetLock . getMapLock
+{-# INLINE withLockMap #-}

 withLocksMap_ :: (Ord k, MonadUnliftIO m) => TMap k Lock -> [k] -> String -> m a -> m a
 withLocksMap_ = withGetLocks . getMapLock
@@ -945,13 +1025,13 @@ runXFTPServerTest :: AgentClient -> UserId -> XFTPServerWithAuth -> AM' (Maybe P
 runXFTPServerTest c userId (ProtoServerWithAuth srv auth) = do
  cfg <- asks $ xftpCfg . config
  g <- asks random
-  xftpNetworkConfig <- readTVarIO $ useNetworkConfig c
+  xftpNetworkConfig <- atomically $ getNetworkConfig c
  workDir <- getXFTPWorkPath
  filePath <- getTempFilePath workDir
  rcvPath <- getTempFilePath workDir
  liftIO $ do
    let tSess = (userId, srv, Nothing)
-    X.getXFTPClient tSess cfg {xftpNetworkConfig} (\_ -> pure ()) >>= \case
+    X.getXFTPClient g tSess cfg {xftpNetworkConfig} (\_ -> pure ()) >>= \case
      Right xftp -> withTestChunk filePath $ do
        (sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
        (rcvKey, rpKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
@@ -1035,7 +1115,7 @@ mkSMPTSession q = mkTSession (qUserId q) (qServer q) (qConnId q)
 {-# INLINE mkSMPTSession #-}

 getSessionMode :: AgentClient -> IO TransportSessionMode
-getSessionMode = fmap sessionMode . readTVarIO . useNetworkConfig
+getSessionMode = atomically . fmap sessionMode . getNetworkConfig
 {-# INLINE getSessionMode #-}

 newRcvQueue :: AgentClient -> UserId -> ConnId -> SMPServerWithAuth -> VersionRangeSMPC -> SubscriptionMode -> AM (NewRcvQueue, SMPQueueUri)
@@ -1127,7 +1207,7 @@ sendTSessionBatches statCmd statBatchSize toRQ action c qs =
  where
    batchQueues :: AM' [(SMPTransportSession, NonEmpty q)]
    batchQueues = do
-      mode <- sessionMode <$> readTVarIO (useNetworkConfig c)
+      mode <- atomically $ sessionMode <$> getNetworkConfig c
      pure . M.assocs $ foldl' (batch mode) M.empty qs
      where
        batch mode m q =
@@ -1770,3 +1850,7 @@ $(J.deriveJSON defaultJSON ''WorkersSummary)
 $(J.deriveJSON defaultJSON {J.fieldLabelModifier = takeWhile (/= '_')} ''AgentWorkersDetails)

 $(J.deriveJSON defaultJSON ''AgentWorkersSummary)
+
+$(J.deriveJSON (enumJSON $ dropPrefix "UN") ''UserNetworkType)
+
+$(J.deriveJSON defaultJSON ''UserNetworkInfo)
@@ -92,6 +92,7 @@ data AgentConfig = AgentConfig
    xftpCfg :: XFTPClientConfig,
    reconnectInterval :: RetryInterval,
    messageRetryInterval :: RetryInterval2,
+    userNetworkInterval :: RetryInterval,
    messageTimeout :: NominalDiffTime,
    connDeleteDeliveryTimeout :: NominalDiffTime,
    helloTimeout :: NominalDiffTime,
@@ -126,7 +127,7 @@ defaultReconnectInterval =
  RetryInterval
    { initialInterval = 2_000000,
      increaseAfter = 10_000000,
-      maxInterval = 180_000000
+      maxInterval = 60_000000
    }

 defaultMessageRetryInterval :: RetryInterval2
@@ -134,18 +135,26 @@ defaultMessageRetryInterval =
  RetryInterval2
    { riFast =
        RetryInterval
-          { initialInterval = 1_000000,
+          { initialInterval = 2_000000,
            increaseAfter = 10_000000,
            maxInterval = 60_000000
          },
      riSlow =
        RetryInterval
-          { initialInterval = 180_000000, -- 3 minutes
+          { initialInterval = 300_000000, -- 5 minutes
            increaseAfter = 60_000000,
-            maxInterval = 3 * 3600_000000 -- 3 hours
+            maxInterval = 6 * 3600_000000 -- 6 hours
          }
    }

+defaultUserNetworkInterval :: RetryInterval
+defaultUserNetworkInterval =
+  RetryInterval
+    { initialInterval = 1200_000000, -- 20 minutes
+      increaseAfter = 0,
+      maxInterval = 7200_000000 -- 2 hours
+    }
+
 defaultAgentConfig :: AgentConfig
 defaultAgentConfig =
  AgentConfig
@@ -161,6 +170,7 @@ defaultAgentConfig =
      xftpCfg = defaultXFTPClientConfig,
      reconnectInterval = defaultReconnectInterval,
      messageRetryInterval = defaultMessageRetryInterval,
+      userNetworkInterval = defaultUserNetworkInterval,
      messageTimeout = 2 * nominalDay,
      connDeleteDeliveryTimeout = 2 * nominalDay,
      helloTimeout = 2 * nominalDay,
@@ -160,7 +160,8 @@ runNtfWorker c srv Worker {doWork} = do
        \nextSub@(NtfSubscription {connId}, _, _) -> do
          logInfo $ "runNtfWorker, nextSub " <> tshow nextSub
          ri <- asks $ reconnectInterval . config
-          withRetryInterval ri $ \_ loop ->
+          withRetryInterval ri $ \_ loop -> do
+            lift $ waitForUserNetwork c
            processSub nextSub
              `catchAgentError` retryOnError c "NtfWorker" loop (workerInternalError c connId . show)
    processSub :: (NtfSubscription, NtfSubNTFAction, NtfActionTs) -> AM ()
@@ -243,7 +244,8 @@ runNtfSMPWorker c srv Worker {doWork} = do
        \nextSub@(NtfSubscription {connId}, _, _) -> do
          logInfo $ "runNtfSMPWorker, nextSub " <> tshow nextSub
          ri <- asks $ reconnectInterval . config
-          withRetryInterval ri $ \_ loop ->
+          withRetryInterval ri $ \_ loop -> do
+            lift $ waitForUserNetwork c
            processSub nextSub
              `catchAgentError` retryOnError c "NtfSMPWorker" loop (workerInternalError c connId . show)
    processSub :: (NtfSubscription, NtfSubSMPAction, NtfActionTs) -> AM ()
@@ -163,6 +163,7 @@ import Data.Aeson (FromJSON (..), ToJSON (..))
 import qualified Data.Aeson.TH as J
 import Data.Attoparsec.ByteString.Char8 (Parser)
 import qualified Data.Attoparsec.ByteString.Char8 as A
+import Data.ByteString.Base64
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Functor (($>))
@@ -201,7 +202,6 @@ import Simplex.Messaging.Crypto.Ratchet
    SndE2ERatchetParams
  )
 import Simplex.Messaging.Encoding
-import Simplex.Messaging.Encoding.Base64 (base64P, encode)
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers
 import Simplex.Messaging.Protocol
@@ -405,6 +405,7 @@ data ACommand (p :: AParty) (e :: AEntity) where
  MSGNTF :: SMPMsgMeta -> ACommand Agent AEConn
  ACK :: AgentMsgId -> Maybe MsgReceiptInfo -> ACommand Client AEConn
  RCVD :: MsgMeta -> NonEmpty MsgReceipt -> ACommand Agent AEConn
+  QCONT :: ACommand Agent AEConn
  SWCH :: ACommand Client AEConn
  OFF :: ACommand Client AEConn
  DEL :: ACommand Client AEConn
@@ -467,6 +468,7 @@ data ACommandTag (p :: AParty) (e :: AEntity) where
  MSGNTF_ :: ACommandTag Agent AEConn
  ACK_ :: ACommandTag Client AEConn
  RCVD_ :: ACommandTag Agent AEConn
+  QCONT_ :: ACommandTag Agent AEConn
  SWCH_ :: ACommandTag Client AEConn
  OFF_ :: ACommandTag Client AEConn
  DEL_ :: ACommandTag Client AEConn
@@ -522,6 +524,7 @@ aCommandTag = \case
  MSGNTF {} -> MSGNTF_
  ACK {} -> ACK_
  RCVD {} -> RCVD_
+  QCONT -> QCONT_
  SWCH -> SWCH_
  OFF -> OFF_
  DEL -> DEL_
@@ -996,7 +999,7 @@ agentMessageType = \case
    HELLO -> AM_HELLO_
    A_MSG _ -> AM_A_MSG_
    A_RCVD {} -> AM_A_RCVD_
-    QCONT _ -> AM_QCONT_
+    A_QCONT _ -> AM_QCONT_
    QADD _ -> AM_QADD_
    QKEY _ -> AM_QKEY_
    QUSE _ -> AM_QUSE_
@@ -1020,7 +1023,7 @@ data AMsgType
  = HELLO_
  | A_MSG_
  | A_RCVD_
-  | QCONT_
+  | A_QCONT_
  | QADD_
  | QKEY_
  | QUSE_
@@ -1033,7 +1036,7 @@ instance Encoding AMsgType where
    HELLO_ -> "H"
    A_MSG_ -> "M"
    A_RCVD_ -> "V"
-    QCONT_ -> "QC"
+    A_QCONT_ -> "QC"
    QADD_ -> "QA"
    QKEY_ -> "QK"
    QUSE_ -> "QU"
@@ -1046,7 +1049,7 @@ instance Encoding AMsgType where
      'V' -> pure A_RCVD_
      'Q' ->
        A.anyChar >>= \case
-          'C' -> pure QCONT_
+          'C' -> pure A_QCONT_
          'A' -> pure QADD_
          'K' -> pure QKEY_
          'U' -> pure QUSE_
@@ -1066,7 +1069,7 @@ data AMessage
  | -- | agent envelope for delivery receipt
    A_RCVD (NonEmpty AMessageReceipt)
  | -- | the message instructing the client to continue sending messages (after ERR QUOTA)
-    QCONT SndQAddr
+    A_QCONT SndQAddr
  | -- add queue to connection (sent by recipient), with optional address of the replaced queue
    QADD (NonEmpty (SMPQueueUri, Maybe SndQAddr))
  | -- key to secure the added queues and agree e2e encryption key (sent by sender)
@@ -1124,7 +1127,7 @@ instance Encoding AMessage where
    HELLO -> smpEncode HELLO_
    A_MSG body -> smpEncode (A_MSG_, Tail body)
    A_RCVD mrs -> smpEncode (A_RCVD_, mrs)
-    QCONT addr -> smpEncode (QCONT_, addr)
+    A_QCONT addr -> smpEncode (A_QCONT_, addr)
    QADD qs -> smpEncode (QADD_, qs)
    QKEY qs -> smpEncode (QKEY_, qs)
    QUSE qs -> smpEncode (QUSE_, qs)
@@ -1136,7 +1139,7 @@ instance Encoding AMessage where
        HELLO_ -> pure HELLO
        A_MSG_ -> A_MSG . unTail <$> smpP
        A_RCVD_ -> A_RCVD <$> smpP
-        QCONT_ -> QCONT <$> smpP
+        A_QCONT_ -> A_QCONT <$> smpP
        QADD_ -> QADD <$> smpP
        QKEY_ -> QKEY <$> smpP
        QUSE_ -> QUSE <$> smpP
@@ -1668,6 +1671,7 @@ instance StrEncoding ACmdTag where
      "MSGNTF" -> ct MSGNTF_
      "ACK" -> t ACK_
      "RCVD" -> ct RCVD_
+      "QCONT" -> ct QCONT_
      "SWCH" -> t SWCH_
      "OFF" -> t OFF_
      "DEL" -> t DEL_
@@ -1725,6 +1729,7 @@ instance (APartyI p, AEntityI e) => StrEncoding (ACommandTag p e) where
    MSGNTF_ -> "MSGNTF"
    ACK_ -> "ACK"
    RCVD_ -> "RCVD"
+    QCONT_ -> "QCONT"
    SWCH_ -> "SWCH"
    OFF_ -> "OFF"
    DEL_ -> "DEL"
@@ -1794,6 +1799,7 @@ commandP binaryP =
          MSG_ -> s (MSG <$> strP <* A.space <*> smpP <* A.space <*> binaryP)
          MSGNTF_ -> s (MSGNTF <$> strP)
          RCVD_ -> s (RCVD <$> strP <* A.space <*> strP)
+          QCONT_ -> pure QCONT
          DEL_RCVQ_ -> s (DEL_RCVQ <$> strP_ <*> strP_ <*> strP)
          DEL_CONN_ -> pure DEL_CONN
          DEL_USER_ -> s (DEL_USER <$> strP)
@@ -1857,6 +1863,7 @@ serializeCommand = \case
  MSGNTF smpMsgMeta -> s (MSGNTF_, smpMsgMeta)
  ACK mId rcptInfo_ -> s (ACK_, mId) <> maybe "" (B.cons ' ' . serializeBinary) rcptInfo_
  RCVD msgMeta rcpts -> s (RCVD_, msgMeta, rcpts)
+  QCONT -> s QCONT_
  SWCH -> s SWCH_
  OFF -> s OFF_
  DEL -> s DEL_
@@ -11,6 +11,7 @@ module Simplex.Messaging.Agent.RetryInterval
    withRetryIntervalCount,
    withRetryLock2,
    updateRetryInterval2,
+    nextRetryDelay,
  )
 where

@@ -60,7 +61,7 @@ withRetryIntervalCount ri action = callAction 0 0 $ initialInterval ri
        loop = do
          liftIO $ threadDelay' delay
          let elapsed' = elapsed + delay
-          callAction (n + 1) elapsed' $ nextDelay elapsed' delay ri
+          callAction (n + 1) elapsed' $ nextRetryDelay elapsed' delay ri

 -- This function allows action to toggle between slow and fast retry intervals.
 withRetryLock2 :: forall m. MonadIO m => RetryInterval2 -> TMVar () -> (RI2State -> (RetryIntervalMode -> m ()) -> m ()) -> m ()
@@ -76,7 +77,7 @@ withRetryLock2 RetryInterval2 {riSlow, riFast} lock action =
        run (elapsed, delay) ri call = do
          wait delay
          let elapsed' = elapsed + delay
-              delay' = nextDelay elapsed' delay ri
+              delay' = nextRetryDelay elapsed' delay ri
          call (elapsed', delay')
        wait delay = do
          waiting <- newTVarIO True
@@ -87,8 +88,8 @@ withRetryLock2 RetryInterval2 {riSlow, riFast} lock action =
            takeTMVar lock
            writeTVar waiting False

-nextDelay :: Int64 -> Int64 -> RetryInterval -> Int64
-nextDelay elapsed delay RetryInterval {increaseAfter, maxInterval} =
+nextRetryDelay :: Int64 -> Int64 -> RetryInterval -> Int64
+nextRetryDelay elapsed delay RetryInterval {increaseAfter, maxInterval} =
  if elapsed < increaseAfter || delay == maxInterval
    then delay
    else min (delay * 3 `div` 2) maxInterval
@@ -231,6 +231,7 @@ import Data.Bifunctor (first, second)
 import Data.ByteArray (ScrubbedBytes)
 import qualified Data.ByteArray as BA
 import Data.ByteString (ByteString)
+import qualified Data.ByteString.Base64.URL as U
 import qualified Data.ByteString.Char8 as B
 import Data.Char (toLower)
 import Data.Functor (($>))
@@ -270,7 +271,6 @@ import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..))
 import Simplex.Messaging.Crypto.Ratchet (RatchetX448, SkippedMsgDiff (..), SkippedMsgKeys, PQEncryption (..), PQSupport (..))
 import qualified Simplex.Messaging.Crypto.Ratchet as CR
 import Simplex.Messaging.Encoding
-import qualified Simplex.Messaging.Encoding.Base64.URL as U
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Notifications.Protocol (DeviceToken (..), NtfSubscriptionId, NtfTknStatus (..), NtfTokenId, SMPQueueNtf (..))
 import Simplex.Messaging.Notifications.Types
@@ -1214,7 +1214,7 @@ setRatchetX3dhKeys db connId x3dhPrivKey1 x3dhPrivKey2 pqPrivKem =
    db
    [sql|
      UPDATE ratchets
-      SET x3dh_priv_key_1 = ?, x3dh_priv_key_2 = ?, x3dh_pub_key_1 = ?, x3dh_pub_key_2 = ?, pq_priv_kem = ? 
+      SET x3dh_priv_key_1 = ?, x3dh_priv_key_2 = ?, x3dh_pub_key_1 = ?, x3dh_pub_key_2 = ?, pq_priv_kem = ?
      WHERE conn_id = ?
    |]
    (x3dhPrivKey1, x3dhPrivKey2, C.publicKey x3dhPrivKey1, C.publicKey x3dhPrivKey2, pqPrivKem, connId)
@@ -207,7 +207,7 @@ data NetworkConfig = NetworkConfig
    -- | timeout of protocol commands (microseconds)
    tcpTimeout :: Int,
    -- | additional timeout per kilobyte (1024 bytes) to be sent
-    tcpTimeoutPerKb :: Int,
+    tcpTimeoutPerKb :: Int64,
    -- | TCP keep-alive options, Nothing to skip enabling keep-alive
    tcpKeepAlive :: Maybe KeepAliveOpts,
    -- | period for SMP ping commands (microseconds, 0 to disable)
@@ -230,7 +230,7 @@ defaultNetworkConfig =
      sessionMode = TSMUser,
      tcpConnectTimeout = 20_000_000,
      tcpTimeout = 15_000_000,
-      tcpTimeoutPerKb = 45_000, -- 45ms, should be less than 130ms to avoid Int overflow on 32 bit systems
+      tcpTimeoutPerKb = 5_000,
      tcpKeepAlive = Just defaultKeepAliveOpts,
      smpPingInterval = 600_000_000, -- 10min
      smpPingCount = 3,
@@ -239,7 +239,7 @@ defaultNetworkConfig =

 transportClientConfig :: NetworkConfig -> TransportClientConfig
 transportClientConfig NetworkConfig {socksProxy, tcpKeepAlive, logTLSErrors} =
-  TransportClientConfig {socksProxy, tcpKeepAlive, logTLSErrors, clientCredentials = Nothing}
+  TransportClientConfig {socksProxy, tcpKeepAlive, logTLSErrors, clientCredentials = Nothing, alpn = Nothing}
 {-# INLINE transportClientConfig #-}

 -- | protocol client configuration.
@@ -211,6 +211,8 @@ import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.Bifunctor (bimap, first)
 import Data.ByteArray (ByteArrayAccess)
 import qualified Data.ByteArray as BA
+import Data.ByteString.Base64 (decode, encode)
+import qualified Data.ByteString.Base64.URL as U
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.ByteString.Lazy (fromStrict, toStrict)
@@ -228,8 +230,6 @@ import Database.SQLite.Simple.ToField (ToField (..))
 import GHC.TypeLits (ErrorMessage (..), KnownNat, Nat, TypeError, natVal, type (+))
 import Network.Transport.Internal (decodeWord16, encodeWord16)
 import Simplex.Messaging.Encoding
-import Simplex.Messaging.Encoding.Base64 (decode, encode)
-import qualified Simplex.Messaging.Encoding.Base64.URL as U
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (blobFieldDecoder, parseAll, parseString)
 import Simplex.Messaging.Util ((<$?>))
@@ -1,29 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-- | Compatibility wrappers for base64 package, Base64 (padded) variant.
-module Simplex.Messaging.Encoding.Base64 where
-
-import qualified Data.Attoparsec.ByteString.Char8 as A
-import Data.Base64.Types (extractBase64)
-import Data.Bifunctor (first)
-import Data.ByteString.Base64 (decodeBase64Untyped, encodeBase64')
-import Data.ByteString.Char8 (ByteString)
-import qualified Data.ByteString.Char8 as B
-import qualified Data.Text as T
-
-encode :: ByteString -> ByteString
-encode = extractBase64 . encodeBase64'
-{-# INLINE encode #-}
-
-decode :: ByteString -> Either String ByteString
-decode = first T.unpack . decodeBase64Untyped
-{-# INLINE decode #-}
-
-base64P :: A.Parser ByteString
-base64P = do
-  str <- A.takeWhile1 (`B.elem` base64Alphabet)
-  pad <- A.takeWhile (== '=') -- correct amount of padding can be derived from str length
-  either (fail . T.unpack) pure $ decodeBase64Untyped (str <> pad)
-
-base64Alphabet :: ByteString
-base64Alphabet = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
@@ -1,33 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-- | Compatibility wrappers for base64 package, Base64URL-padded variant.
-module Simplex.Messaging.Encoding.Base64.URL where
-
-import qualified Data.Attoparsec.ByteString.Char8 as A
-import Data.Base64.Types (extractBase64)
-import Data.Bifunctor (first)
-import Data.ByteString.Base64.URL (decodeBase64Lenient, decodeBase64UnpaddedUntyped, decodeBase64Untyped, encodeBase64')
-import Data.ByteString.Char8 (ByteString)
-import qualified Data.ByteString.Char8 as B
-import qualified Data.Text as T
-
-encode :: ByteString -> ByteString
-encode = extractBase64 . encodeBase64'
-{-# INLINE encode #-}
-
-decode :: ByteString -> Either String ByteString
-decode = first T.unpack . decodeBase64Untyped
-{-# INLINE decode #-}
-
-decodeLenient :: ByteString -> ByteString
-decodeLenient = decodeBase64Lenient
-{-# INLINE decodeLenient #-}
-
-base64urlP :: A.Parser ByteString
-base64urlP = do
-  str <- A.takeWhile1 (`B.elem` base64AlphabetURL)
-  _pad <- A.takeWhile (== '=') -- correct amount of padding can be derived from str length
-  either (fail . T.unpack) pure $ decodeBase64UnpaddedUntyped str
-
-base64AlphabetURL :: ByteString
-base64AlphabetURL = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_"
@@ -10,6 +10,7 @@ module Simplex.Messaging.Encoding.String
    strToJSON,
    strToJEncoding,
    strParseJSON,
+    base64urlP,
    strEncodeList,
    strListP,
  )
@@ -22,8 +23,10 @@ import qualified Data.Aeson.Encoding as JE
 import qualified Data.Aeson.Types as JT
 import Data.Attoparsec.ByteString.Char8 (Parser)
 import qualified Data.Attoparsec.ByteString.Char8 as A
+import qualified Data.ByteString.Base64.URL as U
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
+import Data.Char (isAlphaNum)
 import Data.Int (Int64)
 import qualified Data.List.NonEmpty as L
 import Data.Set (Set)
@@ -35,7 +38,6 @@ import Data.Time.Clock.System (SystemTime (..))
 import Data.Time.Format.ISO8601
 import Data.Word (Word16, Word32)
 import Simplex.Messaging.Encoding
-import qualified Simplex.Messaging.Encoding.Base64.URL as U
 import Simplex.Messaging.Parsers (parseAll)
 import Simplex.Messaging.Util ((<$?>))

@@ -52,16 +54,19 @@ class StrEncoding a where
  strDecode :: ByteString -> Either String a
  strDecode = parseAll strP
  strP :: Parser a
-  strP = strDecode <$?> U.base64urlP
+  strP = strDecode <$?> base64urlP

 -- base64url encoding/decoding of ByteStrings - the parser only allows non-empty strings
 instance StrEncoding ByteString where
  strEncode = U.encode
-  {-# INLINE strEncode #-}
  strDecode = U.decode
-  {-# INLINE strDecode #-}
-  strP = U.base64urlP
-  {-# INLINE strP #-}
+  strP = base64urlP
+
+base64urlP :: Parser ByteString
+base64urlP = do
+  str <- A.takeWhile1 (\c -> isAlphaNum c || c == '-' || c == '_')
+  pad <- A.takeWhile (== '=')
+  either fail pure $ U.decode (str <> pad)

 newtype Str = Str {unStr :: ByteString}
  deriving (Eq, Show)
@@ -11,12 +11,14 @@

 module Simplex.Messaging.Notifications.Protocol where

+import Control.Applicative ((<|>))
 import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.=))
 import qualified Data.Aeson as J
 import qualified Data.Aeson.Encoding as JE
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
+import Data.Functor (($>))
 import Data.Kind
 import Data.Maybe (isNothing)
 import Data.Text.Encoding (decodeLatin1, encodeUtf8)
@@ -406,10 +408,12 @@ instance Encoding DeviceToken where

 instance StrEncoding DeviceToken where
  strEncode (DeviceToken p t) = strEncode p <> " " <> t
-  strP = DeviceToken <$> strP <* A.space <*> hexStringP
+  strP = nullToken <|> hexToken
    where
+      nullToken = "apns_null test_ntf_token" $> DeviceToken PPApnsNull "test_ntf_token"
+      hexToken = DeviceToken <$> strP <* A.space <*> hexStringP
      hexStringP =
-        A.takeWhile (\c -> A.isDigit c || (c >= 'a' && c <= 'f')) >>= \s ->
+        A.takeWhile (`B.elem` "0123456789abcdef") >>= \s ->
          if even (B.length s) then pure s else fail "odd number of hex characters"

 instance ToJSON DeviceToken where
@@ -108,7 +108,7 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg} started = do
    logServerStats :: Int64 -> Int64 -> FilePath -> M ()
    logServerStats startAt logInterval statsFilePath = do
      initialDelay <- (startAt -) . fromIntegral . (`div` 1000000_000000) . diffTimeToPicoseconds . utctDayTime <$> liftIO getCurrentTime
-      liftIO $ putStrLn $ "server stats log enabled: " <> statsFilePath
+      logInfo $ "server stats log enabled: " <> T.pack statsFilePath
      liftIO $ threadDelay' $ 1000000 * (initialDelay + if initialDelay < 0 then 86400 else 0)
      NtfServerStats {fromTime, tknCreated, tknVerified, tknDeleted, subCreated, subDeleted, ntfReceived, ntfDelivered, activeTokens, activeSubs} <- asks serverStats
      let interval = 1000000 * logInterval
@@ -442,7 +442,7 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu
  where
    processCommand :: NtfRequest -> M (Transmission NtfResponse)
    processCommand = \case
-      NtfReqNew corrId (ANE SToken newTkn@(NewNtfTkn _ _ dhPubKey)) -> do
+      NtfReqNew corrId (ANE SToken newTkn@(NewNtfTkn token _ dhPubKey)) -> do
        logDebug "TNEW - new token"
        st <- asks store
        ks@(srvDhPubKey, srvDhPrivKey) <- atomically . C.generateKeyPair =<< asks random
@@ -453,9 +453,9 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu
        atomically $ addNtfToken st tknId tkn
        atomically $ writeTBQueue pushQ (tkn, PNVerification regCode)
        withNtfLog (`logCreateToken` tkn)
-        incNtfStat tknCreated
+        incNtfStatT token tknCreated
        pure (corrId, "", NRTknId tknId srvDhPubKey)
-      NtfReqCmd SToken (NtfTkn tkn@NtfTknData {ntfTknId, tknStatus, tknRegCode, tknDhSecret, tknDhKeys = (srvDhPubKey, srvDhPrivKey), tknCronInterval}) (corrId, tknId, cmd) -> do
+      NtfReqCmd SToken (NtfTkn tkn@NtfTknData {token, ntfTknId, tknStatus, tknRegCode, tknDhSecret, tknDhKeys = (srvDhPubKey, srvDhPrivKey), tknCronInterval}) (corrId, tknId, cmd) -> do
        status <- readTVarIO tknStatus
        (corrId,tknId,) <$> case cmd of
          TNEW (NewNtfTkn _ _ dhPubKey) -> do
@@ -474,7 +474,7 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu
                updateTknStatus tkn NTActive
                tIds <- atomically $ removeInactiveTokenRegistrations st tkn
                forM_ tIds cancelInvervalNotifications
-                incNtfStat tknVerified
+                incNtfStatT token tknVerified
                pure NROk
            | otherwise -> do
                logDebug "TVFY - incorrect code or token status"
@@ -493,8 +493,8 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu
              addNtfToken st tknId tkn'
              writeTBQueue pushQ (tkn', PNVerification regCode)
            withNtfLog $ \s -> logUpdateToken s tknId token' regCode
-            incNtfStat tknDeleted
-            incNtfStat tknCreated
+            incNtfStatT token tknDeleted
+            incNtfStatT token tknCreated
            pure NROk
          TDEL -> do
            logDebug "TDEL"
@@ -504,7 +504,7 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu
              atomically $ removeSubscription ca smpServer (SPNotifier, notifierId)
            cancelInvervalNotifications tknId
            withNtfLog (`logDeleteToken` tknId)
-            incNtfStat tknDeleted
+            incNtfStatT token tknDeleted
            pure NROk
          TCRN 0 -> do
            logDebug "TCRN 0"
@@ -583,6 +583,10 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu
 withNtfLog :: (StoreLog 'WriteMode -> IO a) -> M ()
 withNtfLog action = liftIO . mapM_ action =<< asks storeLog

+incNtfStatT :: DeviceToken -> (NtfServerStats -> TVar Int) -> M ()
+incNtfStatT (DeviceToken PPApnsNull _) _ = pure ()
+incNtfStatT _ statSel = incNtfStat statSel
+
 incNtfStat :: (NtfServerStats -> TVar Int) -> M ()
 incNtfStat statSel = do
  stats <- asks serverStats
@@ -27,9 +27,8 @@ import Data.Aeson (ToJSON, (.=))
 import qualified Data.Aeson as J
 import qualified Data.Aeson.Encoding as JE
 import qualified Data.Aeson.TH as JQ
-import Data.Base64.Types (extractBase64)
 import Data.Bifunctor (first)
-import qualified Data.ByteString.Base64.URL as UP
+import qualified Data.ByteString.Base64.URL as U
 import Data.ByteString.Builder (lazyByteString)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Lazy.Char8 as LB
@@ -47,7 +46,6 @@ import Network.HTTP2.Client (Request)
 import qualified Network.HTTP2.Client as H
 import Network.Socket (HostName, ServiceName)
 import qualified Simplex.Messaging.Crypto as C
-import qualified Simplex.Messaging.Encoding.Base64.URL as U
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Notifications.Protocol
 import Simplex.Messaging.Notifications.Server.Push.APNS.Internal
@@ -56,7 +54,7 @@ import Simplex.Messaging.Parsers (defaultJSON)
 import Simplex.Messaging.Protocol (EncNMsgMeta)
 import Simplex.Messaging.Transport.HTTP2 (HTTP2Body (..))
 import Simplex.Messaging.Transport.HTTP2.Client
-import Simplex.Messaging.Util (safeDecodeUtf8)
+import Simplex.Messaging.Util (safeDecodeUtf8, tshow)
 import System.Environment (getEnv)
 import UnliftIO.STM

@@ -93,8 +91,8 @@ signedJWTToken pk (JWTToken hdr claims) = do
  pure $ hc <> "." <> serialize sig
  where
    jwtEncode :: ToJSON a => a -> ByteString
-    jwtEncode = extractBase64 . UP.encodeBase64Unpadded' . LB.toStrict . J.encode
-    serialize sig = extractBase64 . UP.encodeBase64Unpadded' $ encodeASN1' DER [Start Sequence, IntVal (EC.sign_r sig), IntVal (EC.sign_s sig), End Sequence]
+    jwtEncode = U.encodeUnpadded . LB.toStrict . J.encode
+    serialize sig = U.encodeUnpadded $ encodeASN1' DER [Start Sequence, IntVal (EC.sign_r sig), IntVal (EC.sign_s sig), End Sequence]

 readECPrivateKey :: FilePath -> IO EC.PrivateKey
 readECPrivateKey f = do
@@ -260,11 +258,11 @@ mkApnsJWTToken appTeamId jwtHeader privateKey = do
 connectHTTPS2 :: HostName -> APNSPushClientConfig -> TVar (Maybe HTTP2Client) -> IO (Either HTTP2ClientError HTTP2Client)
 connectHTTPS2 apnsHost APNSPushClientConfig {apnsPort, http2cfg, caStoreFile} https2Client = do
  caStore_ <- XS.readCertificateStore caStoreFile
-  when (isNothing caStore_) $ putStrLn $ "Error loading CertificateStore from " <> caStoreFile
+  when (isNothing caStore_) $ logError $ "Error loading CertificateStore from " <> T.pack caStoreFile
  r <- getHTTP2Client apnsHost apnsPort caStore_ http2cfg disconnected
  case r of
    Right client -> atomically . writeTVar https2Client $ Just client
-    Left e -> putStrLn $ "Error connecting to APNS: " <> show e
+    Left e -> logError $ "Error connecting to APNS: " <> tshow e
  pure r
  where
    disconnected = atomically $ writeTVar https2Client Nothing
@@ -24,9 +24,12 @@ module Simplex.Messaging.Notifications.Server.StoreLog
 where

 import Control.Concurrent.STM
+import Control.Logger.Simple
 import Control.Monad
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import qualified Data.ByteString.Char8 as B
+import qualified Data.ByteString.Lazy.Char8 as LB
+import qualified Data.Text as T
 import Data.Word (Word16)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String
@@ -34,7 +37,7 @@ import Simplex.Messaging.Notifications.Protocol
 import Simplex.Messaging.Notifications.Server.Store
 import Simplex.Messaging.Protocol (NtfPrivateAuthKey)
 import Simplex.Messaging.Server.StoreLog
-import Simplex.Messaging.Util (whenM)
+import Simplex.Messaging.Util (safeDecodeUtf8, whenM)
 import System.Directory (doesFileExist, renameFile)
 import System.IO

@@ -189,10 +192,10 @@ readWriteNtfStore f st = do
  pure s

 readNtfStore :: FilePath -> NtfStore -> IO ()
-readNtfStore f st = mapM_ addNtfLogRecord . B.lines =<< B.readFile f
+readNtfStore f st = mapM_ (addNtfLogRecord . LB.toStrict) . LB.lines =<< LB.readFile f
  where
    addNtfLogRecord s = case strDecode s of
-      Left e -> B.putStrLn $ "Log parsing error (" <> B.pack e <> "): " <> B.take 100 s
+      Left e -> logError $ "Log parsing error (" <> T.pack e <> "): " <> safeDecodeUtf8 (B.take 100 s)
      Right lr -> atomically $ case lr of
        CreateToken r@NtfTknRec {ntfTknId} -> do
          tkn <- mkTknData r
@@ -10,9 +10,10 @@ import qualified Data.Aeson as J
 import Data.Attoparsec.ByteString.Char8 (Parser)
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.Bifunctor (first)
+import Data.ByteString.Base64
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
-import Data.Char (toLower)
+import Data.Char (isAlphaNum, toLower)
 import Data.String
 import Data.Text (Text)
 import qualified Data.Text as T
@@ -23,8 +24,23 @@ import Database.SQLite.Simple (ResultError (..), SQLData (..))
 import Database.SQLite.Simple.FromField (FieldParser, returnError)
 import Database.SQLite.Simple.Internal (Field (..))
 import Database.SQLite.Simple.Ok (Ok (Ok))
+import Simplex.Messaging.Util ((<$?>))
 import Text.Read (readMaybe)

+base64P :: Parser ByteString
+base64P = decode <$?> paddedBase64 rawBase64P
+
+paddedBase64 :: Parser ByteString -> Parser ByteString
+paddedBase64 raw = (<>) <$> raw <*> pad
+  where
+    pad = A.takeWhile (== '=')
+
+rawBase64P :: Parser ByteString
+rawBase64P = A.takeWhile1 (\c -> isAlphaNum c || c == '+' || c == '/')
+
+-- rawBase64UriP :: Parser ByteString
+-- rawBase64UriP = A.takeWhile1 (\c -> isAlphaNum c || c == '-' || c == '_')
+
 tsISO8601P :: Parser UTCTime
 tsISO8601P = maybe (fail "timestamp") pure . parseISO8601 . B.unpack =<< A.takeTill wordEnd

@@ -176,6 +176,7 @@ import qualified Data.Aeson.TH as J
 import Data.Attoparsec.ByteString.Char8 (Parser, (<?>))
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.Bifunctor (first)
+import qualified Data.ByteString.Base64 as B64
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Char (isPrint, isSpace)
@@ -193,7 +194,6 @@ import GHC.TypeLits (ErrorMessage (..), TypeError, type (+))
 import Network.Socket (ServiceName)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
-import qualified Simplex.Messaging.Encoding.Base64 as B64
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers
 import Simplex.Messaging.ServiceScheme
@@ -45,8 +45,10 @@ import Control.Monad.IO.Unlift
 import Control.Monad.Reader
 import Crypto.Random
 import Data.Bifunctor (first)
+import Data.ByteString.Base64 (encode)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
+import qualified Data.ByteString.Lazy.Char8 as LB
 import Data.Either (fromRight, partitionEithers)
 import Data.Functor (($>))
 import Data.Int (Int64)
@@ -67,7 +69,6 @@ import Network.Socket (ServiceName, Socket, socketToHandle)
 import Simplex.Messaging.Agent.Lock
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding (Encoding (smpEncode))
-import Simplex.Messaging.Encoding.Base64 (encode)
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol
 import Simplex.Messaging.Server.Control
@@ -983,7 +984,7 @@ restoreServerMessages = asks (storeMsgsFile . config) >>= \case
      ms <- asks msgStore
      quota <- asks $ msgQueueQuota . config
      old_ <- asks (messageExpiration . config) $>>= (liftIO . fmap Just . expireBeforeEpoch)
-      runExceptT (liftIO (B.readFile f) >>= foldM (\expired -> restoreMsg expired ms quota old_) 0 . B.lines) >>= \case
+      runExceptT (liftIO (LB.readFile f) >>= foldM (\expired -> restoreMsg expired ms quota old_) 0 . LB.lines) >>= \case
        Left e -> do
          logError . T.pack $ "error restoring messages: " <> e
          liftIO exitFailure
@@ -992,10 +993,11 @@ restoreServerMessages = asks (storeMsgsFile . config) >>= \case
          logInfo "messages restored"
          pure expired
      where
-        restoreMsg !expired ms quota old_ s = do
+        restoreMsg !expired ms quota old_ s' = do
          MLRv3 rId msg <- liftEither . first (msgErr "parsing") $ strDecode s
          addToMsgQueue rId msg
          where
+            s = LB.toStrict s'
            addToMsgQueue rId msg = do
              (isExpired, logFull) <- atomically $ do
                q <- getMsgQueue ms rId quota
@@ -25,8 +25,8 @@ where

 import Control.Applicative (optional, (<|>))
 import Control.Monad (foldM, unless, when)
-import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
+import qualified Data.ByteString.Lazy.Char8 as LB
 import Data.Functor (($>))
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
@@ -148,13 +148,14 @@ writeQueues s = mapM_ $ \q -> when (active q) $ logCreateQueue s q
    active QueueRec {status} = status == QueueActive

 readQueues :: FilePath -> IO (Map RecipientId QueueRec)
-readQueues f = foldM processLine M.empty . B.lines =<< B.readFile f
+readQueues f = foldM processLine M.empty . LB.lines =<< LB.readFile f
  where
-    processLine :: Map RecipientId QueueRec -> ByteString -> IO (Map RecipientId QueueRec)
-    processLine m s = case strDecode $ trimCR s of
+    processLine :: Map RecipientId QueueRec -> LB.ByteString -> IO (Map RecipientId QueueRec)
+    processLine m s' = case strDecode $ trimCR s of
      Right r -> pure $ procLogRecord r
      Left e -> printError e $> m
      where
+        s = LB.toStrict s'
        procLogRecord :: StoreLogRecord -> Map RecipientId QueueRec
        procLogRecord = \case
          CreateQueue q -> M.insert (recipientId q) q m
@@ -54,6 +54,7 @@ module Simplex.Messaging.Transport
    -- * TLS Transport
    TLS (..),
    SessionId,
+    ALPN,
    connectTLS,
    closeTLS,
    supportedParameters,
@@ -228,10 +229,13 @@ data TLS = TLS
    tlsPeer :: TransportPeer,
    tlsUniq :: ByteString,
    tlsBuffer :: TBuffer,
+    tlsALPN :: Maybe ALPN,
    tlsServerCerts :: X.CertificateChain,
    tlsTransportConfig :: TransportConfig
  }

+type ALPN = ByteString
+
 connectTLS :: T.TLSParams p => Maybe HostName -> TransportConfig -> p -> Socket -> IO T.Context
 connectTLS host_ TransportConfig {logTLSErrors} params sock =
  E.bracketOnError (T.contextNew sock params) closeTLS $ \ctx ->
@@ -246,7 +250,8 @@ getTLS tlsPeer cfg tlsServerCerts cxt = withTlsUnique tlsPeer cxt newTLS
  where
    newTLS tlsUniq = do
      tlsBuffer <- atomically newTBuffer
-      pure TLS {tlsContext = cxt, tlsTransportConfig = cfg, tlsServerCerts, tlsPeer, tlsUniq, tlsBuffer}
+      tlsALPN <- T.getNegotiatedProtocol cxt
+      pure TLS {tlsContext = cxt, tlsALPN, tlsTransportConfig = cfg, tlsServerCerts, tlsPeer, tlsUniq, tlsBuffer}

 withTlsUnique :: TransportPeer -> T.Context -> (ByteString -> IO c) -> IO c
 withTlsUnique peer cxt f =
@@ -17,6 +17,7 @@ module Simplex.Messaging.Transport.Client
    TransportHost (..),
    TransportHosts (..),
    TransportHosts_ (..),
+    validateCertificateChain
  )
 where

@@ -113,12 +114,13 @@ data TransportClientConfig = TransportClientConfig
  { socksProxy :: Maybe SocksProxy,
    tcpKeepAlive :: Maybe KeepAliveOpts,
    logTLSErrors :: Bool,
-    clientCredentials :: Maybe (X.CertificateChain, T.PrivKey)
+    clientCredentials :: Maybe (X.CertificateChain, T.PrivKey),
+    alpn :: Maybe [ALPN]
  }
  deriving (Eq, Show)

 defaultTransportClientConfig :: TransportClientConfig
-defaultTransportClientConfig = TransportClientConfig Nothing (Just defaultKeepAliveOpts) True Nothing
+defaultTransportClientConfig = TransportClientConfig Nothing (Just defaultKeepAliveOpts) True Nothing Nothing

 clientTransportConfig :: TransportClientConfig -> TransportConfig
 clientTransportConfig TransportClientConfig {logTLSErrors} =
@@ -129,10 +131,10 @@ runTransportClient :: Transport c => TransportClientConfig -> Maybe ByteString -
 runTransportClient = runTLSTransportClient supportedParameters Nothing

 runTLSTransportClient :: Transport c => T.Supported -> Maybe XS.CertificateStore -> TransportClientConfig -> Maybe ByteString -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (c -> IO a) -> IO a
-runTLSTransportClient tlsParams caStore_ cfg@TransportClientConfig {socksProxy, tcpKeepAlive, clientCredentials} proxyUsername host port keyHash client = do
+runTLSTransportClient tlsParams caStore_ cfg@TransportClientConfig {socksProxy, tcpKeepAlive, clientCredentials, alpn} proxyUsername host port keyHash client = do
  serverCert <- newEmptyTMVarIO
  let hostName = B.unpack $ strEncode host
-      clientParams = mkTLSClientParams tlsParams caStore_ hostName port keyHash clientCredentials serverCert
+      clientParams = mkTLSClientParams tlsParams caStore_ hostName port keyHash clientCredentials alpn serverCert
      connectTCP = case socksProxy of
        Just proxy -> connectSocksClient proxy proxyUsername $ hostAddr host
        _ -> connectTCPClient hostName
@@ -215,14 +217,15 @@ instance ToJSON SocksProxy where
 instance FromJSON SocksProxy where
  parseJSON = strParseJSON "SocksProxy"

-mkTLSClientParams :: T.Supported -> Maybe XS.CertificateStore -> HostName -> ServiceName -> Maybe C.KeyHash -> Maybe (X.CertificateChain, T.PrivKey) -> TMVar X.CertificateChain -> T.ClientParams
-mkTLSClientParams supported caStore_ host port cafp_ clientCreds_ serverCerts =
+mkTLSClientParams :: T.Supported -> Maybe XS.CertificateStore -> HostName -> ServiceName -> Maybe C.KeyHash -> Maybe (X.CertificateChain, T.PrivKey) -> Maybe [ALPN] -> TMVar X.CertificateChain -> T.ClientParams
+mkTLSClientParams supported caStore_ host port cafp_ clientCreds_ alpn_ serverCerts =
  (T.defaultParamsClient host p)
    { T.clientShared = def {T.sharedCAStore = fromMaybe (T.sharedCAStore def) caStore_},
      T.clientHooks =
        def
          { T.onServerCertificate = onServerCert,
-            T.onCertificateRequest = maybe def (const . pure . Just) clientCreds_
+            T.onCertificateRequest = maybe def (const . pure . Just) clientCreds_,
+            T.onSuggestALPN = pure alpn_
          },
      T.clientSupported = supported
    }
@@ -237,7 +240,7 @@ mkTLSClientParams supported caStore_ host port cafp_ clientCreds_ serverCerts =
 validateCertificateChain :: C.KeyHash -> HostName -> ByteString -> X.CertificateChain -> IO [XV.FailedReason]
 validateCertificateChain _ _ _ (X.CertificateChain []) = pure [XV.EmptyChain]
 validateCertificateChain _ _ _ (X.CertificateChain [_]) = pure [XV.EmptyChain]
-validateCertificateChain (C.KeyHash kh) host port cc@(X.CertificateChain sc@[_, caCert]) =
+validateCertificateChain (C.KeyHash kh) host port cc@(X.CertificateChain [_, caCert]) =
  if Fingerprint kh == XV.getFingerprint caCert X.HashSHA256
    then x509validate
    else pure [XV.UnknownCA]
@@ -247,7 +250,7 @@ validateCertificateChain (C.KeyHash kh) host port cc@(X.CertificateChain sc@[_,
      where
        hooks = XV.defaultHooks
        checks = XV.defaultChecks {XV.checkFQHN = False}
-        certStore = XS.makeCertificateStore sc
+        certStore = XS.makeCertificateStore [caCert]
        cache = XV.exceptionValidationCache [] -- we manually check fingerprint only of the identity certificate (ca.crt)
        serviceID = (host, port)
 validateCertificateChain _ _ _ _ = pure [XV.AuthorityTooDeep]
@@ -16,15 +16,15 @@ import qualified Network.HTTP2.Server as HS
 import Network.Socket (SockAddr (..))
 import qualified Network.TLS as T
 import qualified Network.TLS.Extra as TE
-import Simplex.Messaging.Transport (SessionId, TLS (tlsUniq), Transport (cGet, cPut))
+import Simplex.Messaging.Transport (TLS, Transport (cGet, cPut))
 import Simplex.Messaging.Transport.Buffer
 import qualified System.TimeManager as TI

 defaultHTTP2BufferSize :: BufferSize
 defaultHTTP2BufferSize = 32768

-withHTTP2 :: BufferSize -> (Config -> SessionId -> IO a) -> TLS -> IO a
-withHTTP2 sz run c = E.bracket (allocHTTP2Config c sz) freeSimpleConfig (`run` tlsUniq c)
+withHTTP2 :: BufferSize -> (Config -> IO a) -> IO () -> TLS -> IO a
+withHTTP2 sz run fin c = E.bracket (allocHTTP2Config c sz) (\cfg -> freeSimpleConfig cfg `E.finally` fin) run

 allocHTTP2Config :: TLS -> BufferSize -> IO Config
 allocHTTP2Config c sz = do
@@ -23,15 +23,20 @@ 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, TLS)
+import Simplex.Messaging.Transport (ALPN, SessionId, TLS (tlsALPN), getServerCerts, getServerVerifyKey, tlsUniq)
 import Simplex.Messaging.Transport.Client (TransportClientConfig (..), TransportHost (..), runTLSTransportClient)
 import Simplex.Messaging.Transport.HTTP2
+import Simplex.Messaging.Util (eitherToMaybe)
 import UnliftIO.STM
 import UnliftIO.Timeout
+import qualified Data.X509 as X

 data HTTP2Client = HTTP2Client
  { action :: Maybe (Async HTTP2Response),
    sessionId :: SessionId,
+    sessionALPN :: Maybe ALPN,
+    serverKey :: Maybe C.APublicVerifyKey, -- may not always be a key we control (i.e. APNS with apple-mandated key types)
+    serverCerts :: X.CertificateChain,
    sessionTs :: UTCTime,
    sendReq :: Request -> (Response -> IO HTTP2Response) -> IO HTTP2Response,
    client_ :: HClient
@@ -66,7 +71,7 @@ defaultHTTP2ClientConfig =
  HTTP2ClientConfig
    { qSize = 64,
      connTimeout = 10000000,
-      transportConfig = TransportClientConfig Nothing Nothing True Nothing,
+      transportConfig = TransportClientConfig Nothing Nothing True Nothing Nothing,
      bufferSize = defaultHTTP2BufferSize,
      bodyHeadSize = 16384,
      suportedTLSParams = http2TLSParams
@@ -86,9 +91,10 @@ getVerifiedHTTP2Client proxyUsername host port keyHash caStore config disconnect
 attachHTTP2Client :: HTTP2ClientConfig -> TransportHost -> ServiceName -> IO () -> Int -> TLS -> IO (Either HTTP2ClientError HTTP2Client)
 attachHTTP2Client config host port disconnected bufferSize tls = getVerifiedHTTP2ClientWith config host port disconnected setup
  where
+    setup :: (TLS -> H.Client HTTP2Response) -> IO HTTP2Response
    setup = runHTTP2ClientWith bufferSize host ($ tls)

-getVerifiedHTTP2ClientWith :: HTTP2ClientConfig -> TransportHost -> ServiceName -> IO () -> ((SessionId -> H.Client HTTP2Response) -> IO HTTP2Response) -> IO (Either HTTP2ClientError HTTP2Client)
+getVerifiedHTTP2ClientWith :: HTTP2ClientConfig -> TransportHost -> ServiceName -> IO () -> ((TLS -> H.Client HTTP2Response) -> IO HTTP2Response) -> IO (Either HTTP2ClientError HTTP2Client)
 getVerifiedHTTP2ClientWith config host port disconnected setup =
  (atomically mkHTTPS2Client >>= runClient)
    `E.catch` \(e :: IOException) -> pure . Left $ HCIOError e
@@ -104,15 +110,25 @@ getVerifiedHTTP2ClientWith config host port disconnected setup =
      cVar <- newEmptyTMVarIO
      action <- async $ setup (client c cVar) `E.finally` atomically (putTMVar cVar $ Left HCNetworkError)
      c_ <- connTimeout config `timeout` atomically (takeTMVar cVar)
-      pure $ case c_ of
-        Just (Right c') -> Right c' {action = Just action}
-        Just (Left e) -> Left e
-        Nothing -> Left HCNetworkError
+      case c_ of
+        Just (Right c') -> pure $ Right c' {action = Just action}
+        Just (Left e) -> pure $ Left e
+        Nothing -> cancel action $> Left HCNetworkError

-    client :: HClient -> TMVar (Either HTTP2ClientError HTTP2Client) -> SessionId -> H.Client HTTP2Response
-    client c cVar sessionId sendReq = do
+    client :: HClient -> TMVar (Either HTTP2ClientError HTTP2Client) -> TLS -> H.Client HTTP2Response
+    client c cVar tls sendReq = do
      sessionTs <- getCurrentTime
-      let c' = HTTP2Client {action = Nothing, client_ = c, sendReq, sessionId, sessionTs}
+      let c' =
+            HTTP2Client
+              { action = Nothing,
+                client_ = c,
+                serverKey = eitherToMaybe $ getServerVerifyKey tls,
+                serverCerts = getServerCerts tls,
+                sendReq,
+                sessionTs,
+                sessionId = tlsUniq tls,
+                sessionALPN = tlsALPN tls
+              }
      atomically $ do
        writeTVar (connected c) True
        putTMVar cVar (Right c')
@@ -154,13 +170,14 @@ sendRequestDirect HTTP2Client {client_ = HClient {config, disconnected}, sendReq
 http2RequestTimeout :: HTTP2ClientConfig -> Maybe Int -> Int
 http2RequestTimeout HTTP2ClientConfig {connTimeout} = maybe connTimeout (connTimeout +)

-runHTTP2Client :: forall a. T.Supported -> Maybe XS.CertificateStore -> TransportClientConfig -> BufferSize -> Maybe ByteString -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (SessionId -> H.Client a) -> IO a
+runHTTP2Client :: forall a. T.Supported -> Maybe XS.CertificateStore -> TransportClientConfig -> BufferSize -> Maybe ByteString -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (TLS -> H.Client a) -> IO a
 runHTTP2Client tlsParams caStore tcConfig bufferSize proxyUsername host port keyHash = runHTTP2ClientWith bufferSize host setup
  where
+    setup :: (TLS -> IO a) -> IO a
    setup = runTLSTransportClient tlsParams caStore tcConfig proxyUsername host port keyHash

-runHTTP2ClientWith :: forall a. BufferSize -> TransportHost -> ((TLS -> IO a) -> IO a) -> (SessionId -> H.Client a) -> IO a
-runHTTP2ClientWith bufferSize host setup client = setup $ withHTTP2 bufferSize run
+runHTTP2ClientWith :: forall a. BufferSize -> TransportHost -> ((TLS -> IO a) -> IO a) -> (TLS -> H.Client a) -> IO a
+runHTTP2ClientWith bufferSize host setup client = setup $ \tls -> withHTTP2 bufferSize (run tls) (pure ()) tls
  where
-    run :: H.Config -> SessionId -> IO a
-    run cfg sessId = H.run (ClientConfig "https" (strEncode host) 20) cfg $ client sessId
+    run :: TLS -> H.Config -> IO a
+    run tls cfg = H.run (ClientConfig "https" (strEncode host) 20) cfg $ client tls
@@ -13,14 +13,14 @@ import Network.Socket
 import qualified Network.TLS as T
 import Numeric.Natural (Natural)
 import Simplex.Messaging.Server.Expiration
-import Simplex.Messaging.Transport (SessionId, TLS, closeConnection)
+import Simplex.Messaging.Transport (ALPN, SessionId, TLS, closeConnection, tlsALPN, tlsUniq)
 import Simplex.Messaging.Transport.HTTP2
 import Simplex.Messaging.Transport.Server (TransportServerConfig (..), loadSupportedTLSServerParams, runTransportServer)
 import Simplex.Messaging.Util (threadDelay')
 import UnliftIO (finally)
 import UnliftIO.Concurrent (forkIO, killThread)

-type HTTP2ServerFunc = SessionId -> Request -> (Response -> IO ()) -> IO ()
+type HTTP2ServerFunc = SessionId -> Maybe ALPN -> Request -> (Response -> IO ()) -> IO ()

 data HTTP2ServerConfig = HTTP2ServerConfig
  { qSize :: Natural,
@@ -37,6 +37,7 @@ data HTTP2ServerConfig = HTTP2ServerConfig

 data HTTP2Request = HTTP2Request
  { sessionId :: SessionId,
+    sessionALPN :: Maybe ALPN,
    request :: Request,
    reqBody :: HTTP2Body,
    sendResponse :: Response -> IO ()
@@ -54,32 +55,32 @@ getHTTP2Server HTTP2ServerConfig {qSize, http2Port, bufferSize, bodyHeadSize, se
  started <- newEmptyTMVarIO
  reqQ <- newTBQueueIO qSize
  action <- async $
-    runHTTP2Server started http2Port bufferSize tlsServerParams transportConfig Nothing $ \sessionId r sendResponse -> do
+    runHTTP2Server started http2Port bufferSize tlsServerParams transportConfig Nothing (const $ pure ()) $ \sessionId sessionALPN r sendResponse -> do
      reqBody <- getHTTP2Body r bodyHeadSize
-      atomically $ writeTBQueue reqQ HTTP2Request {sessionId, request = r, reqBody, sendResponse}
+      atomically $ writeTBQueue reqQ HTTP2Request {sessionId, sessionALPN, request = r, reqBody, sendResponse}
  void . atomically $ takeTMVar started
  pure HTTP2Server {action, reqQ}

 closeHTTP2Server :: HTTP2Server -> IO ()
 closeHTTP2Server = uninterruptibleCancel . action

-runHTTP2Server :: TMVar Bool -> ServiceName -> BufferSize -> T.ServerParams -> TransportServerConfig -> Maybe ExpirationConfig -> HTTP2ServerFunc -> IO ()
-runHTTP2Server started port bufferSize serverParams transportConfig expCfg_ = runHTTP2ServerWith_ expCfg_ bufferSize setup
+runHTTP2Server :: TMVar Bool -> ServiceName -> BufferSize -> T.ServerParams -> TransportServerConfig -> Maybe ExpirationConfig -> (SessionId -> IO ()) -> HTTP2ServerFunc -> IO ()
+runHTTP2Server started port bufferSize serverParams transportConfig expCfg_ clientFinished = runHTTP2ServerWith_ expCfg_ clientFinished bufferSize setup
  where
    setup = runTransportServer started port serverParams transportConfig

 runHTTP2ServerWith :: BufferSize -> ((TLS -> IO ()) -> a) -> HTTP2ServerFunc -> a
-runHTTP2ServerWith = runHTTP2ServerWith_ Nothing
+runHTTP2ServerWith = runHTTP2ServerWith_ Nothing (\_sessId -> pure ())

-runHTTP2ServerWith_ :: Maybe ExpirationConfig -> BufferSize -> ((TLS -> IO ()) -> a) -> HTTP2ServerFunc -> a
-runHTTP2ServerWith_ expCfg_ bufferSize setup http2Server = setup $ \tls -> do
+runHTTP2ServerWith_ :: Maybe ExpirationConfig -> (SessionId -> IO ()) -> BufferSize -> ((TLS -> IO ()) -> a) -> HTTP2ServerFunc -> a
+runHTTP2ServerWith_ expCfg_ clientFinished bufferSize setup http2Server = setup $ \tls -> do
  activeAt <- newTVarIO =<< getSystemTime
  tid_ <- mapM (forkIO . expireInactiveClient tls activeAt) expCfg_
-  withHTTP2 bufferSize (run activeAt) tls `finally` mapM_ killThread tid_
+  withHTTP2 bufferSize (run tls activeAt) (clientFinished $ tlsUniq tls) tls `finally` mapM_ killThread tid_
  where
-    run activeAt cfg sessId = H.run cfg $ \req _aux sendResp -> do
+    run tls activeAt cfg = H.run cfg $ \req _aux sendResp -> do
      getSystemTime >>= atomically . writeTVar activeAt
-      http2Server sessId req (`sendResp` [])
+      http2Server (tlsUniq tls) (tlsALPN tls) req (`sendResp` [])
    expireInactiveClient tls activeAt expCfg = loop
      where
        loop = do
@@ -13,7 +13,7 @@ module AgentTests (agentTests) where

 import AgentTests.ConnectionRequestTests
 import AgentTests.DoubleRatchetTests (doubleRatchetTests)
-import AgentTests.FunctionalAPITests (functionalAPITests, pattern Msg, pattern Msg')
+import AgentTests.FunctionalAPITests (functionalAPITests, inAnyOrder, pattern Msg, pattern Msg')
 import AgentTests.MigrationTests (migrationTests)
 import AgentTests.NotificationTests (notificationTests)
 import AgentTests.SQLiteTests (storeTests)
@@ -194,8 +194,8 @@ pqMatrix2_ pqInv _ smpTest test = do

 pqMatrix3 ::
  HasCallStack =>
-  TProxy c -> 
-  (HasCallStack => (c -> c -> c -> IO ()) -> Expectation) -> 
+  TProxy c ->
+  (HasCallStack => (c -> c -> c -> IO ()) -> Expectation) ->
  (HasCallStack => (c, InitialKeys) -> (c, PQSupport) -> (c, PQSupport) -> IO ()) ->
  Spec
 pqMatrix3 _ smpTest test = do
@@ -452,7 +452,7 @@ testServerConnectionAfterError t _ = do
  where
    server = SMPServer "localhost" testPort2 testKeyHash
    withServer test' = withSmpServerStoreLogOn (ATransport t) testPort2 (const test') `shouldReturn` ()
-    withAgent1 = withAgent agentTestPort testDB 0 
+    withAgent1 = withAgent agentTestPort testDB 0
    withAgent2 = withAgent agentTestPort2 testDB2 10
    withAgent :: String -> FilePath -> Int -> (c -> IO a) -> IO a
    withAgent agentPort agentDB initClientId = withSmpAgentThreadOn_ (ATransport t) (agentPort, testPort2, agentDB) initClientId (pure ()) . const . testSMPAgentClientOn agentPort
@@ -554,7 +554,11 @@ testResumeDeliveryQuotaExceeded _ alice bob = do
  alice #:# "the last message not sent"
  bob <#= \case ("", "alice", Msg "message 4") -> True; _ -> False
  bob #: ("4", "alice", "ACK 7") #> ("4", "alice", OK)
-  alice <# ("", "bob", SENT 8)
+  inAnyOrder
+      (tGetAgent alice)
+      [ \case ("", c, Right (SENT 8)) -> c == "bob"; _ -> False,
+        \case ("", c, Right QCONT) -> c == "bob"; _ -> False
+      ]
  bob <#= \case ("", "alice", Msg "over quota") -> True; _ -> False
  -- message 8 is skipped because of alice agent sending "QCONT" message
  bob #: ("5", "alice", "ACK 9") #> ("5", "alice", OK)
@@ -17,7 +17,10 @@ import AgentTests.FunctionalAPITests
    createConnection,
    exchangeGreetingsMsgId,
    get,
-    getSMPAgentClient',
+    withAgent,
+    withAgentClients2,
+    withAgentClientsCfgServers2,
+    withAgentClients3,
    joinConnection,
    makeConnection,
    nGet,
@@ -42,15 +45,15 @@ import Control.Monad.Trans.Except
 import qualified Data.Aeson as J
 import qualified Data.Aeson.Types as JT
 import Data.Bifunctor (bimap, first)
+import qualified Data.ByteString.Base64.URL as U
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Text.Encoding (encodeUtf8)
 import NtfClient
-import SMPAgentClient (agentCfg, initAgentServers, initAgentServers2, testDB, testDB2, testDB3, testNtfServer, testNtfServer2)
+import SMPAgentClient (agentCfg, initAgentServers, initAgentServers2, testDB, testDB2, testNtfServer, testNtfServer2)
 import SMPClient (cfg, cfgV7, testPort, testPort2, testStoreLogFile2, withSmpServer, withSmpServerConfigOn, withSmpServerStoreLogOn)
 import Simplex.Messaging.Agent hiding (createConnection, joinConnection, sendMessage)
 import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..), withStore')
-import qualified Simplex.Messaging.Encoding.Base64.URL as U
 import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, Env (..), InitialAgentServers)
 import Simplex.Messaging.Agent.Protocol hiding (CON, CONF, INFO)
 import Simplex.Messaging.Agent.Store.SQLite (getSavedNtfToken)
@@ -165,8 +168,7 @@ runNtfTestCfg t smpCfg ntfCfg aCfg bCfg runTest =

 testNotificationToken :: APNSMockServer -> IO ()
 testNotificationToken APNSMockServer {apnsQ} = do
-  a <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
-  runRight_ $ do
+  withAgent 1 agentCfg initAgentServers testDB $ \a -> runRight_ $ do
    let tkn = DeviceToken PPApnsTest "abcd"
    NTRegistered <- registerNtfToken a tkn NMPeriodic
    APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
@@ -179,7 +181,7 @@ testNotificationToken APNSMockServer {apnsQ} = do
    deleteNtfToken a tkn
    -- agent deleted this token
    Left (CMD PROHIBITED) <- tryE $ checkNtfToken a tkn
-    liftIO $ disposeAgentClient a
+    pure ()

 (.->) :: J.Value -> J.Key -> ExceptT AgentErrorType IO ByteString
 v .-> key = do
@@ -193,8 +195,7 @@ testNtfTokenRepeatRegistration :: APNSMockServer -> IO ()
 testNtfTokenRepeatRegistration APNSMockServer {apnsQ} = do
  -- setLogLevel LogError -- LogDebug
  -- withGlobalLogging logCfg $ do
-  a <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
-  runRight_ $ do
+  withAgent 1 agentCfg initAgentServers testDB $ \a -> runRight_ $ do
    let tkn = DeviceToken PPApnsTest "abcd"
    NTRegistered <- registerNtfToken a tkn NMPeriodic
    APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
@@ -211,15 +212,13 @@ testNtfTokenRepeatRegistration APNSMockServer {apnsQ} = do
    -- can still use the first verification code, it is the same after decryption
    verifyNtfToken a tkn nonce verification
    NTActive <- checkNtfToken a tkn
-    liftIO $ disposeAgentClient a
+    pure ()

 testNtfTokenSecondRegistration :: APNSMockServer -> IO ()
-testNtfTokenSecondRegistration APNSMockServer {apnsQ} = do
+testNtfTokenSecondRegistration APNSMockServer {apnsQ} =
  -- setLogLevel LogError -- LogDebug
  -- withGlobalLogging logCfg $ do
-  a <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
-  a' <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
-  runRight_ $ do
+  withAgentClients2 $ \a a' -> runRight_ $ do
    let tkn = DeviceToken PPApnsTest "abcd"
    NTRegistered <- registerNtfToken a tkn NMPeriodic
    APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
@@ -248,37 +247,34 @@ testNtfTokenSecondRegistration APNSMockServer {apnsQ} = do
    -- and the second is active
    NTActive <- checkNtfToken a' tkn
    pure ()
-  disposeAgentClient a
-  disposeAgentClient a'

 testNtfTokenServerRestart :: ATransport -> APNSMockServer -> IO ()
 testNtfTokenServerRestart t APNSMockServer {apnsQ} = do
-  a <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
  let tkn = DeviceToken PPApnsTest "abcd"
-  ntfData <- withNtfServer t . runRight $ do
-    NTRegistered <- registerNtfToken a tkn NMPeriodic
-    APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
-      atomically $ readTBQueue apnsQ
-    liftIO $ sendApnsResponse APNSRespOk
-    pure ntfData
-  -- the new agent is created as otherwise when running the tests in CI the old agent was keeping the connection to the server
+  ntfData <- withAgent 1 agentCfg initAgentServers testDB $ \a ->
+    withNtfServer t . runRight $ do
+      NTRegistered <- registerNtfToken a tkn NMPeriodic
+      APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
+        atomically $ readTBQueue apnsQ
+      liftIO $ sendApnsResponse APNSRespOk
+      pure ntfData
+    -- the new agent is created as otherwise when running the tests in CI the old agent was keeping the connection to the server
  threadDelay 1000000
-  disposeAgentClient a
-  a' <- getSMPAgentClient' 2 agentCfg initAgentServers testDB
-  -- server stopped before token is verified, so now the attempt to verify it will return AUTH error but re-register token,
-  -- so that repeat verification happens without restarting the clients, when notification arrives
-  withNtfServer t . runRight_ $ do
-    verification <- ntfData .-> "verification"
-    nonce <- C.cbNonce <$> ntfData .-> "nonce"
-    Left (NTF AUTH) <- tryE $ verifyNtfToken a' tkn nonce verification
-    APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData'}, sendApnsResponse = sendApnsResponse'} <-
-      atomically $ readTBQueue apnsQ
-    verification' <- ntfData' .-> "verification"
-    nonce' <- C.cbNonce <$> ntfData' .-> "nonce"
-    liftIO $ sendApnsResponse' APNSRespOk
-    verifyNtfToken a' tkn nonce' verification'
-    NTActive <- checkNtfToken a' tkn
-    liftIO $ disposeAgentClient a'
+  withAgent 2 agentCfg initAgentServers testDB $ \a' ->
+    -- server stopped before token is verified, so now the attempt to verify it will return AUTH error but re-register token,
+    -- so that repeat verification happens without restarting the clients, when notification arrives
+    withNtfServer t . runRight_ $ do
+      verification <- ntfData .-> "verification"
+      nonce <- C.cbNonce <$> ntfData .-> "nonce"
+      Left (NTF AUTH) <- tryE $ verifyNtfToken a' tkn nonce verification
+      APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData'}, sendApnsResponse = sendApnsResponse'} <-
+        atomically $ readTBQueue apnsQ
+      verification' <- ntfData' .-> "verification"
+      nonce' <- C.cbNonce <$> ntfData' .-> "nonce"
+      liftIO $ sendApnsResponse' APNSRespOk
+      verifyNtfToken a' tkn nonce' verification'
+      NTActive <- checkNtfToken a' tkn
+      pure ()

 getTestNtfTokenPort :: AgentClient -> AE String
 getTestNtfTokenPort a =
@@ -289,66 +285,62 @@ getTestNtfTokenPort a =
 testNtfTokenMultipleServers :: ATransport -> APNSMockServer -> IO ()
 testNtfTokenMultipleServers t APNSMockServer {apnsQ} = do
  let tkn = DeviceToken PPApnsTest "abcd"
-  a <- getSMPAgentClient' 1 agentCfg initAgentServers2 testDB
-  withNtfServerThreadOn t ntfTestPort $ \ntf ->
-    withNtfServerThreadOn t ntfTestPort2 $ \ntf2 -> runRight_ $ do
-      -- register a new token, the agent picks a server and stores its choice
-      NTRegistered <- registerNtfToken a tkn NMPeriodic
-      APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
-        atomically $ readTBQueue apnsQ
-      verification <- ntfData .-> "verification"
-      nonce <- C.cbNonce <$> ntfData .-> "nonce"
-      liftIO $ sendApnsResponse APNSRespOk
-      verifyNtfToken a tkn nonce verification
-      NTActive <- checkNtfToken a tkn
-      -- shut down the "other" server
-      port <- getTestNtfTokenPort a
-      liftIO . killThread $ if port == ntfTestPort then ntf2 else ntf
-      -- still works
-      NTActive <- checkNtfToken a tkn
-      liftIO . killThread $ if port == ntfTestPort then ntf else ntf2
-      -- negative test, the correct server is now gone
-      Left _ <- tryError (checkNtfToken a tkn)
-      pure ()
+  withAgent 1 agentCfg initAgentServers2 testDB $ \a ->
+    withNtfServerThreadOn t ntfTestPort $ \ntf ->
+      withNtfServerThreadOn t ntfTestPort2 $ \ntf2 -> runRight_ $ do
+        -- register a new token, the agent picks a server and stores its choice
+        NTRegistered <- registerNtfToken a tkn NMPeriodic
+        APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}, sendApnsResponse} <-
+          atomically $ readTBQueue apnsQ
+        verification <- ntfData .-> "verification"
+        nonce <- C.cbNonce <$> ntfData .-> "nonce"
+        liftIO $ sendApnsResponse APNSRespOk
+        verifyNtfToken a tkn nonce verification
+        NTActive <- checkNtfToken a tkn
+        -- shut down the "other" server
+        port <- getTestNtfTokenPort a
+        liftIO . killThread $ if port == ntfTestPort then ntf2 else ntf
+        -- still works
+        NTActive <- checkNtfToken a tkn
+        liftIO . killThread $ if port == ntfTestPort then ntf else ntf2
+        -- negative test, the correct server is now gone
+        Left _ <- tryError (checkNtfToken a tkn)
+        pure ()

 testNtfTokenChangeServers :: ATransport -> APNSMockServer -> IO ()
 testNtfTokenChangeServers t APNSMockServer {apnsQ} =
  withNtfServerThreadOn t ntfTestPort $ \ntf -> do
-    tkn1 <- runRight $ do
-      a <- liftIO $ getSMPAgentClient' 1 agentCfg initAgentServers testDB
+    tkn1 <- withAgent 1 agentCfg initAgentServers testDB $ \a -> runRight $ do
      tkn <- registerTestToken a "abcd" NMInstant apnsQ
      NTActive <- checkNtfToken a tkn
      liftIO $ setNtfServers a [testNtfServer2]
      NTActive <- checkNtfToken a tkn -- still works on old server
-      liftIO $ disposeAgentClient a
      pure tkn

    threadDelay 1000000

-    a <- getSMPAgentClient' 2 agentCfg initAgentServers testDB
-    runRight_ $ do
-      getTestNtfTokenPort a >>= \port -> liftIO $ port `shouldBe` ntfTestPort
-      NTActive <- checkNtfToken a tkn1
-      liftIO $ setNtfServers a [testNtfServer2] -- just change configured server list
-      getTestNtfTokenPort a >>= \port -> liftIO $ port `shouldBe` ntfTestPort -- not yet changed
-      -- trigger token replace
-      tkn2 <- registerTestToken a "xyzw" NMInstant apnsQ
-      getTestNtfTokenPort a >>= \port -> liftIO $ port `shouldBe` ntfTestPort -- not yet changed
-      deleteNtfToken a tkn2 -- force server switch
-      Left BROKER {brokerErr = NETWORK} <- tryError $ registerTestToken a "qwer" NMInstant apnsQ -- ok, it's down for now
-      getTestNtfTokenPort a >>= \port2 -> liftIO $ port2 `shouldBe` ntfTestPort2 -- but the token got updated
-    killThread ntf
-    withNtfServerOn t ntfTestPort2 $ runRight_ $ do
-      tkn <- registerTestToken a "qwer" NMInstant apnsQ
-      checkNtfToken a tkn >>= \r -> liftIO $ r `shouldBe` NTActive
+    withAgent 2 agentCfg initAgentServers testDB $ \a -> do
+      runRight_ $ do
+        getTestNtfTokenPort a >>= \port -> liftIO $ port `shouldBe` ntfTestPort
+        NTActive <- checkNtfToken a tkn1
+        liftIO $ setNtfServers a [testNtfServer2] -- just change configured server list
+        getTestNtfTokenPort a >>= \port -> liftIO $ port `shouldBe` ntfTestPort -- not yet changed
+        -- trigger token replace
+        tkn2 <- registerTestToken a "xyzw" NMInstant apnsQ
+        getTestNtfTokenPort a >>= \port -> liftIO $ port `shouldBe` ntfTestPort -- not yet changed
+        deleteNtfToken a tkn2 -- force server switch
+        Left BROKER {brokerErr = NETWORK} <- tryError $ registerTestToken a "qwer" NMInstant apnsQ -- ok, it's down for now
+        getTestNtfTokenPort a >>= \port2 -> liftIO $ port2 `shouldBe` ntfTestPort2 -- but the token got updated
+      killThread ntf
+      withNtfServerOn t ntfTestPort2 $ runRight_ $ do
+        tkn <- registerTestToken a "qwer" NMInstant apnsQ
+        checkNtfToken a tkn >>= \r -> liftIO $ r `shouldBe` NTActive

 testRunNTFServerTests :: ATransport -> NtfServer -> IO (Maybe ProtocolTestFailure)
 testRunNTFServerTests t srv =
-  withNtfServerThreadOn t ntfTestPort $ \ntf -> do
-    a <- liftIO $ getSMPAgentClient' 1 agentCfg initAgentServers testDB
-    r <- testProtocolServer a 1 $ ProtoServerWithAuth srv Nothing
-    killThread ntf
-    pure r
+  withNtfServerOn t ntfTestPort $
+    withAgent 1 agentCfg initAgentServers testDB $ \a ->
+      testProtocolServer a 1 $ ProtoServerWithAuth srv Nothing

 testNotificationSubscriptionExistingConnection :: APNSMockServer -> AgentClient -> AgentClient -> IO ()
 testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} alice@AgentClient {agentEnv = Env {config = aliceCfg}} bob = do
@@ -383,11 +375,9 @@ testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} alice@Agen
  Left (CMD PROHIBITED) <- runExceptT $ getNotificationMessage alice nonce message

  -- aliceNtf client doesn't have subscription and is allowed to get notification message
-  aliceNtf <- getSMPAgentClient' 3 aliceCfg initAgentServers testDB
-  runRight_ $ do
+  withAgent 3 aliceCfg initAgentServers testDB $ \aliceNtf -> runRight_ $ do
    (_, [SMPMsgMeta {msgFlags = MsgFlags True}]) <- getNotificationMessage aliceNtf nonce message
    pure ()
-  disposeAgentClient aliceNtf

  runRight_ $ do
    get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
@@ -459,10 +449,8 @@ registerTestToken a token mode apnsQ = do
  pure tkn

 testChangeNotificationsMode :: APNSMockServer -> IO ()
-testChangeNotificationsMode APNSMockServer {apnsQ} = do
-  alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
-  bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
-  runRight_ $ do
+testChangeNotificationsMode APNSMockServer {apnsQ} =
+  withAgentClients2 $ \alice bob -> runRight_ $ do
    -- establish connection
    (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe
    aliceId <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe
@@ -518,17 +506,13 @@ testChangeNotificationsMode APNSMockServer {apnsQ} = do
    ackMessage alice bobId (baseId + 5) Nothing
    -- no notifications should follow
    noNotification apnsQ
-  disposeAgentClient alice
-  disposeAgentClient bob
  where
    baseId = 3
    msgId = subtract baseId

 testChangeToken :: APNSMockServer -> IO ()
-testChangeToken APNSMockServer {apnsQ} = do
-  alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
-  bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
-  (aliceId, bobId) <- runRight $ do
+testChangeToken APNSMockServer {apnsQ} = withAgent 1 agentCfg initAgentServers testDB2 $ \bob -> do
+  (aliceId, bobId) <- withAgent 2 agentCfg initAgentServers testDB $ \alice -> runRight $ do
    -- establish connection
    (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe
    aliceId <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe
@@ -547,10 +531,8 @@ testChangeToken APNSMockServer {apnsQ} = do
    get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
    ackMessage alice bobId (baseId + 1) Nothing
    pure (aliceId, bobId)
-  disposeAgentClient alice

-  alice1 <- getSMPAgentClient' 3 agentCfg initAgentServers testDB
-  runRight_ $ do
+  withAgent 3 agentCfg initAgentServers testDB $ \alice1 -> runRight_ $ do
    subscribeConnection alice1 bobId
    -- change notification token
    void $ registerTestToken alice1 "bcde" NMInstant apnsQ
@@ -563,16 +545,12 @@ testChangeToken APNSMockServer {apnsQ} = do
    ackMessage alice1 bobId (baseId + 2) Nothing
    -- no notifications should follow
    noNotification apnsQ
-  disposeAgentClient alice1
-  disposeAgentClient bob
  where
    baseId = 3
    msgId = subtract baseId

 testNotificationsStoreLog :: ATransport -> APNSMockServer -> IO ()
-testNotificationsStoreLog t APNSMockServer {apnsQ} = do
-  alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
-  bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
+testNotificationsStoreLog t APNSMockServer {apnsQ} = withAgentClients2 $ \alice bob -> do
  (aliceId, bobId) <- withNtfServerStoreLog t $ \threadId -> runRight $ do
    (aliceId, bobId) <- makeConnection alice bob
    _ <- registerTestToken alice "abcd" NMInstant apnsQ
@@ -594,13 +572,9 @@ testNotificationsStoreLog t APNSMockServer {apnsQ} = do
    void $ messageNotificationData alice apnsQ
    get alice =##> \case ("", c, Msg "hello again") -> c == bobId; _ -> False
    liftIO $ killThread threadId
-  disposeAgentClient alice
-  disposeAgentClient bob

 testNotificationsSMPRestart :: ATransport -> APNSMockServer -> IO ()
-testNotificationsSMPRestart t APNSMockServer {apnsQ} = do
-  alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
-  bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
+testNotificationsSMPRestart t APNSMockServer {apnsQ} = withAgentClients2 $ \alice bob -> do
  (aliceId, bobId) <- withSmpServerStoreLogOn t testPort $ \threadId -> runRight $ do
    (aliceId, bobId) <- makeConnection alice bob
    _ <- registerTestToken alice "abcd" NMInstant apnsQ
@@ -626,49 +600,44 @@ testNotificationsSMPRestart t APNSMockServer {apnsQ} = do
    _ <- messageNotificationData alice apnsQ
    get alice =##> \case ("", c, Msg "hello again") -> c == bobId; _ -> False
    liftIO $ killThread threadId
-  disposeAgentClient alice
-  disposeAgentClient bob

 testNotificationsSMPRestartBatch :: Int -> ATransport -> APNSMockServer -> IO ()
-testNotificationsSMPRestartBatch n t APNSMockServer {apnsQ} = do
-  a <- getSMPAgentClient' 1 agentCfg initAgentServers2 testDB
-  b <- getSMPAgentClient' 2 agentCfg initAgentServers2 testDB2
-  threadDelay 1000000
-  conns <- runServers $ do
-    conns <- replicateM (n :: Int) $ makeConnection a b
-    _ <- registerTestToken a "abcd" NMInstant apnsQ
-    liftIO $ threadDelay 5000000
-    forM_ conns $ \(aliceId, bobId) -> do
-      msgId <- sendMessage b aliceId (SMP.MsgFlags True) "hello"
-      get b ##> ("", aliceId, SENT msgId)
-      void $ messageNotificationData a apnsQ
-      get a =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
-      ackMessage a bobId msgId Nothing
-    pure conns
+testNotificationsSMPRestartBatch n t APNSMockServer {apnsQ} =
+  withAgentClientsCfgServers2 agentCfg agentCfg initAgentServers2 $ \a b -> do
+    threadDelay 1000000
+    conns <- runServers $ do
+      conns <- replicateM (n :: Int) $ makeConnection a b
+      _ <- registerTestToken a "abcd" NMInstant apnsQ
+      liftIO $ threadDelay 5000000
+      forM_ conns $ \(aliceId, bobId) -> do
+        msgId <- sendMessage b aliceId (SMP.MsgFlags True) "hello"
+        get b ##> ("", aliceId, SENT msgId)
+        void $ messageNotificationData a apnsQ
+        get a =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
+        ackMessage a bobId msgId Nothing
+      pure conns

-  runRight_ @AgentErrorType $ do
-    ("", "", DOWN _ bcs1) <- nGet a
-    ("", "", DOWN _ bcs2) <- nGet a
-    liftIO $ length (bcs1 <> bcs2) `shouldBe` length conns
-    ("", "", DOWN _ acs1) <- nGet b
-    ("", "", DOWN _ acs2) <- nGet b
-    liftIO $ length (acs1 <> acs2) `shouldBe` length conns
+    runRight_ @AgentErrorType $ do
+      ("", "", DOWN _ bcs1) <- nGet a
+      ("", "", DOWN _ bcs2) <- nGet a
+      liftIO $ length (bcs1 <> bcs2) `shouldBe` length conns
+      ("", "", DOWN _ acs1) <- nGet b
+      ("", "", DOWN _ acs2) <- nGet b
+      liftIO $ length (acs1 <> acs2) `shouldBe` length conns

-  runServers $ do
-    ("", "", UP _ bcs1) <- nGet a
-    ("", "", UP _ bcs2) <- nGet a
-    liftIO $ length (bcs1 <> bcs2) `shouldBe` length conns
-    ("", "", UP _ acs1) <- nGet b
-    ("", "", UP _ acs2) <- nGet b
-    liftIO $ length (acs1 <> acs2) `shouldBe` length conns
-    liftIO $ threadDelay 1500000
-    forM_ conns $ \(aliceId, bobId) -> do
-      msgId <- sendMessage b aliceId (SMP.MsgFlags True) "hello again"
-      get b ##> ("", aliceId, SENT msgId)
-      _ <- messageNotificationData a apnsQ
-      get a =##> \case ("", c, Msg "hello again") -> c == bobId; _ -> False
-  disposeAgentClient a
-  disposeAgentClient b
+    runServers $ do
+      ("", "", UP _ bcs1) <- nGet a
+      ("", "", UP _ bcs2) <- nGet a
+      liftIO $ length (bcs1 <> bcs2) `shouldBe` length conns
+      ("", "", UP _ acs1) <- nGet b
+      ("", "", UP _ acs2) <- nGet b
+      liftIO $ length (acs1 <> acs2) `shouldBe` length conns
+      liftIO $ threadDelay 1500000
+      forM_ conns $ \(aliceId, bobId) -> do
+        msgId <- sendMessage b aliceId (SMP.MsgFlags True) "hello again"
+        get b ##> ("", aliceId, SENT msgId)
+        _ <- messageNotificationData a apnsQ
+        get a =##> \case ("", c, Msg "hello again") -> c == bobId; _ -> False
  where
    runServers :: ExceptT AgentErrorType IO a -> IO a
    runServers a = do
@@ -679,10 +648,8 @@ testNotificationsSMPRestartBatch n t APNSMockServer {apnsQ} = do
        pure res

 testSwitchNotifications :: InitialAgentServers -> APNSMockServer -> IO ()
-testSwitchNotifications servers APNSMockServer {apnsQ} = do
-  a <- getSMPAgentClient' 1 agentCfg servers testDB
-  b <- getSMPAgentClient' 2 agentCfg servers testDB2
-  runRight_ $ do
+testSwitchNotifications servers APNSMockServer {apnsQ} =
+  withAgentClientsCfgServers2 agentCfg agentCfg servers $ \a b -> runRight_ $ do
    (aId, bId) <- makeConnection a b
    exchangeGreetingsMsgId 4 a bId b aId
    _ <- registerTestToken a "abcd" NMInstant apnsQ
@@ -698,15 +665,10 @@ testSwitchNotifications servers APNSMockServer {apnsQ} = do
    switchComplete a bId b aId
    liftIO $ threadDelay 500000
    testMessage "hello again"
-  disposeAgentClient a
-  disposeAgentClient b

 testNotificationsOldToken :: APNSMockServer -> IO ()
-testNotificationsOldToken APNSMockServer {apnsQ} = do
-  a <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
-  b <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
-  c <- getSMPAgentClient' 3 agentCfg initAgentServers testDB3
-  runRight_ $ do
+testNotificationsOldToken APNSMockServer {apnsQ} =
+  withAgentClients3 $ \a b c -> runRight_ $ do
    (abId, baId) <- makeConnection a b
    let testMessageAB = testMessage_ apnsQ a abId b baId
    _ <- registerTestToken a "abcd" NMInstant apnsQ
@@ -722,16 +684,10 @@ testNotificationsOldToken APNSMockServer {apnsQ} = do
    (acId, caId) <- makeConnection a c
    let testMessageAC = testMessage_ apnsQ a acId c caId
    testMessageAC "greetings"
-  disposeAgentClient a
-  disposeAgentClient b
-  disposeAgentClient c

 testNotificationsNewToken :: APNSMockServer -> ThreadId -> IO ()
-testNotificationsNewToken APNSMockServer {apnsQ} oldNtf = do
-  a <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
-  b <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
-  c <- getSMPAgentClient' 3 agentCfg initAgentServers testDB3
-  runRight_ $ do
+testNotificationsNewToken APNSMockServer {apnsQ} oldNtf =
+  withAgentClients3 $ \a b c -> runRight_ $ do
    (abId, baId) <- makeConnection a b
    let testMessageAB = testMessage_ apnsQ a abId b baId
    tkn <- registerTestToken a "abcd" NMInstant apnsQ
@@ -750,9 +706,6 @@ testNotificationsNewToken APNSMockServer {apnsQ} oldNtf = do
    (acId, caId) <- makeConnection a c
    let testMessageAC = testMessage_ apnsQ a acId c caId
    testMessageAC "greetings"
-  disposeAgentClient a
-  disposeAgentClient b
-  disposeAgentClient c

 testMessage_ :: HasCallStack => TBQueue APNSMockRequest -> AgentClient -> ConnId -> AgentClient -> ConnId -> SMP.MsgBody -> ExceptT AgentErrorType IO ()
 testMessage_ apnsQ a aId b bId msg = do
@@ -16,9 +16,14 @@ import Data.Text.Encoding (encodeUtf8)
 import qualified Data.Text.Lazy as LT
 import qualified Data.Text.Lazy.Encoding as LE
 import Data.Type.Equality
+import qualified Data.X509 as X
+import qualified Data.X509.CertificateStore as XS
+import qualified Data.X509.Validation as XV
+import qualified SMPClient
 import qualified Simplex.Messaging.Crypto as C
 import qualified Simplex.Messaging.Crypto.Lazy as LC
 import Simplex.Messaging.Crypto.SNTRUP761.Bindings
+import Simplex.Messaging.Transport.Client
 import Test.Hspec
 import Test.Hspec.QuickCheck (modifyMaxSuccess)
 import Test.QuickCheck
@@ -91,6 +96,8 @@ cryptoTests = do
    describe "Ed448" $ testEncoding C.SEd448
    describe "X25519" $ testEncoding C.SX25519
    describe "X448" $ testEncoding C.SX448
+  describe "X509 chains" $ do
+    it "should validate certificates" testValidateX509
  describe "sntrup761" $
    it "should enc/dec key" testSNTRUP761

@@ -223,6 +230,39 @@ testEncoding alg = it "should encode / decode key" . ioProperty $ do
    C.decodePubKey (C.encodePubKey k) == Right k
      && C.decodePrivKey (C.encodePrivKey pk) == Right pk

+testValidateX509 :: IO ()
+testValidateX509 = do
+  let checkChain = validateCertificateChain SMPClient.testKeyHash "localhost" "5223" . X.CertificateChain
+  checkChain [] `shouldReturn` [XV.EmptyChain]
+
+  caCreds <- XS.readCertificates "tests/fixtures/ca.crt"
+  caCreds `shouldNotBe` []
+  let ca = head caCreds
+
+  serverCreds <- XS.readCertificates "tests/fixtures/server.crt"
+  serverCreds `shouldNotBe` []
+  let server = head serverCreds
+  checkChain [server, ca] `shouldReturn` []
+
+  ca2Creds <- XS.readCertificates "tests/fixtures/ca2.crt"
+  ca2Creds `shouldNotBe` []
+  let ca2 = head ca2Creds
+
+  -- signed by another CA
+  server2Creds <- XS.readCertificates "tests/fixtures/server2.crt"
+  server2Creds `shouldNotBe` []
+  let server2 = head server2Creds
+  checkChain [server2, ca2] `shouldReturn` [XV.UnknownCA]
+
+  -- messed up key rotation or other configuration problems
+  checkChain [server2, ca] `shouldReturn` [XV.InvalidSignature XV.SignatureInvalid]
+
+  -- self-signed, unrelated to CA
+  ssCreds <- XS.readCertificates "tests/fixtures/ss.crt"
+  ssCreds `shouldNotBe` []
+  let ss = head ssCreds
+  checkChain [ss, ca] `shouldReturn` [XV.SelfSigned]
+
 testSNTRUP761 :: IO ()
 testSNTRUP761 = do
  drg <- C.newRandom
@@ -15,6 +15,7 @@ import Control.Concurrent (threadDelay)
 import qualified Data.Aeson as J
 import qualified Data.Aeson.Types as JT
 import Data.Bifunctor (first)
+import qualified Data.ByteString.Base64.URL as U
 import Data.ByteString.Char8 (ByteString)
 import Data.Text.Encoding (encodeUtf8)
 import NtfClient
@@ -34,7 +35,6 @@ import ServerTests
 import qualified Simplex.Messaging.Agent.Protocol as AP
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
-import qualified Simplex.Messaging.Encoding.Base64.URL as U
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Notifications.Protocol
 import Simplex.Messaging.Notifications.Server.Push.APNS
@@ -123,7 +123,7 @@ withSmpServerConfigOn :: HasCallStack => ATransport -> ServerConfig -> ServiceNa
 withSmpServerConfigOn t cfg' port' =
  serverBracket
    (\started -> runSMPServerBlocking started cfg' {transports = [(port', t)]})
-    (pure ())
+    (threadDelay 10000)

 withSmpServerThreadOn :: HasCallStack => ATransport -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a
 withSmpServerThreadOn t = withSmpServerConfigOn t cfg
@@ -22,6 +22,7 @@ import Control.Exception (SomeException, try)
 import Control.Monad
 import Control.Monad.IO.Class
 import Data.Bifunctor (first)
+import Data.ByteString.Base64
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import qualified Data.Set as S
@@ -30,7 +31,6 @@ import GHC.Stack (withFrozenCallStack)
 import SMPClient
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
-import Simplex.Messaging.Encoding.Base64 (encode)
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (parseAll)
 import Simplex.Messaging.Protocol
@@ -769,7 +769,7 @@ testTiming (ATransport t) =
        (C.AuthAlg C.SX25519, C.AuthAlg C.SX25519, 200) -- correct key type
      ]
    timeRepeat n = fmap fst . timeItT . forM_ (replicate n ()) . const
-    similarTime t1 t2 = abs (t2 / t1 - 1) < 0.15 -- normally the difference between "no queue" and "wrong key" is less than 5%
+    similarTime t1 t2 = abs (t2 / t1 - 1) < 0.2 -- normally the difference between "no queue" and "wrong key" is less than 5%
    testSameTiming :: forall c. Transport c => THandleSMP c -> THandleSMP c -> (C.AuthAlg, C.AuthAlg, Int) -> Expectation
    testSameTiming rh sh (C.AuthAlg goodKeyAlg, C.AuthAlg badKeyAlg, n) = do
      g <- C.newRandom
@@ -8,7 +8,7 @@

 module XFTPAgent where

-import AgentTests.FunctionalAPITests (get, getSMPAgentClient', rfGet, runRight, runRight_, sfGet)
+import AgentTests.FunctionalAPITests (get, rfGet, runRight, runRight_, sfGet, withAgent)

 import Control.Logger.Simple
 import Control.Monad
@@ -20,11 +20,11 @@ import Data.Int (Int64)
 import Data.List (find, isSuffixOf)
 import Data.Maybe (fromJust)
 import SMPAgentClient (agentCfg, initAgentServers, testDB, testDB2, testDB3)
-import Simplex.FileTransfer.Description (FileDescription (..), FileDescriptionURI (..), ValidFileDescription, fileDescriptionURI, mb, qrSizeLimit, pattern ValidFileDescription)
+import Simplex.FileTransfer.Description (FileChunk (..), FileDescription (..), FileDescriptionURI (..), ValidFileDescription, fileDescriptionURI, mb, qrSizeLimit, pattern ValidFileDescription)
 import Simplex.FileTransfer.Protocol (FileParty (..))
-import Simplex.FileTransfer.Transport (XFTPErrorType (AUTH))
 import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..))
-import Simplex.Messaging.Agent (AgentClient, disposeAgentClient, testProtocolServer, xftpDeleteRcvFile, xftpDeleteSndFileInternal, xftpDeleteSndFileRemote, xftpReceiveFile, xftpSendDescription, xftpSendFile, xftpStartWorkers)
+import Simplex.FileTransfer.Transport (XFTPErrorType (AUTH))
+import Simplex.Messaging.Agent (AgentClient, testProtocolServer, xftpDeleteRcvFile, xftpDeleteSndFileInternal, xftpDeleteSndFileRemote, xftpReceiveFile, xftpSendDescription, xftpSendFile, xftpStartWorkers)
 import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..))
 import Simplex.Messaging.Agent.Protocol (ACommand (..), AgentErrorType (..), BrokerErrorType (..), RcvFileId, SndFileId, noAuthSrv)
 import qualified Simplex.Messaging.Crypto as C
@@ -100,21 +100,18 @@ testXFTPAgentSendReceive :: HasCallStack => IO ()
 testXFTPAgentSendReceive = withXFTPServer $ do
  filePath <- createRandomFile
  -- send file, delete snd file internally
-  sndr <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
-  (rfd1, rfd2) <- runRight $ do
+  (rfd1, rfd2) <- withAgent 1 agentCfg initAgentServers testDB $ \sndr -> runRight $ do
    (sfId, _, rfd1, rfd2) <- testSend sndr filePath
    liftIO $ xftpDeleteSndFileInternal sndr sfId
    pure (rfd1, rfd2)
-
  -- receive file, delete rcv file
  testReceiveDelete 2 rfd1 filePath
  testReceiveDelete 3 rfd2 filePath
  where
-    testReceiveDelete clientId rfd originalFilePath = do
-      rcp <- getSMPAgentClient' clientId agentCfg initAgentServers testDB2
-      rfId <- runRight $ testReceive rcp rfd originalFilePath
-      xftpDeleteRcvFile rcp rfId
-      disposeAgentClient rcp
+    testReceiveDelete clientId rfd originalFilePath =
+      withAgent clientId agentCfg initAgentServers testDB2 $ \rcp -> do
+        rfId <- runRight $ testReceive rcp rfd originalFilePath
+        xftpDeleteRcvFile rcp rfId

 testXFTPAgentSendReceiveEncrypted :: HasCallStack => IO ()
 testXFTPAgentSendReceiveEncrypted = withXFTPServer $ do
@@ -123,8 +120,7 @@ testXFTPAgentSendReceiveEncrypted = withXFTPServer $ do
  s <- LB.readFile filePath
  file <- atomically $ CryptoFile (senderFiles </> "encrypted_testfile") . Just <$> CF.randomArgs g
  runRight_ $ CF.writeFile file s
-  sndr <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
-  (rfd1, rfd2) <- runRight $ do
+  (rfd1, rfd2) <- withAgent 1 agentCfg initAgentServers testDB $ \sndr -> runRight $ do
    (sfId, _, rfd1, rfd2) <- testSendCF sndr file
    liftIO $ xftpDeleteSndFileInternal sndr sfId
    pure (rfd1, rfd2)
@@ -132,12 +128,11 @@ testXFTPAgentSendReceiveEncrypted = withXFTPServer $ do
  testReceiveDelete 2 rfd1 filePath g
  testReceiveDelete 3 rfd2 filePath g
  where
-    testReceiveDelete clientId rfd originalFilePath g = do
-      rcp <- getSMPAgentClient' clientId agentCfg initAgentServers testDB2
-      cfArgs <- atomically $ Just <$> CF.randomArgs g
-      rfId <- runRight $ testReceiveCF rcp rfd cfArgs originalFilePath
-      xftpDeleteRcvFile rcp rfId
-      disposeAgentClient rcp
+    testReceiveDelete clientId rfd originalFilePath g =
+      withAgent clientId agentCfg initAgentServers testDB2 $ \rcp -> do
+        cfArgs <- atomically $ Just <$> CF.randomArgs g
+        rfId <- runRight $ testReceiveCF rcp rfd cfArgs originalFilePath
+        xftpDeleteRcvFile rcp rfId

 testXFTPAgentSendReceiveRedirect :: HasCallStack => IO ()
 testXFTPAgentSendReceiveRedirect = withXFTPServer $ do
@@ -145,93 +140,98 @@ testXFTPAgentSendReceiveRedirect = withXFTPServer $ do
  filePathIn <- createRandomFile
  let fileSize = mb 17
      totalSize = fileSize + mb 1
-  sndr <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
-  directFileId <- runRight $ xftpSendFile sndr 1 (CryptoFile filePathIn Nothing) 1
-  sfGet sndr `shouldReturn` ("", directFileId, SFPROG 4194304 totalSize)
-  sfGet sndr `shouldReturn` ("", directFileId, SFPROG 8388608 totalSize)
-  sfGet sndr `shouldReturn` ("", directFileId, SFPROG 12582912 totalSize)
-  sfGet sndr `shouldReturn` ("", directFileId, SFPROG 16777216 totalSize)
-  sfGet sndr `shouldReturn` ("", directFileId, SFPROG 17825792 totalSize)
-  sfGet sndr `shouldReturn` ("", directFileId, SFPROG totalSize totalSize)
-  vfdDirect <-
-    sfGet sndr >>= \case
-      (_, _, SFDONE _snd (vfd : _)) -> pure vfd
-      r -> error $ "Expected SFDONE, got " <> show r
-  redirectFileId <- runRight $ xftpSendDescription sndr 1 vfdDirect 1
-  logInfo $ "File sent, sending redirect: " <> tshow redirectFileId
-  sfGet sndr `shouldReturn` ("", redirectFileId, SFPROG 65536 65536)
-  vfdRedirect@(ValidFileDescription fdRedirect) <-
-    sfGet sndr >>= \case
-      (_, _, SFDONE _snd (vfd : _)) -> pure vfd
-      r -> error $ "Expected SFDONE, got " <> show r
-  case fdRedirect of
-    FileDescription {redirect = Just _} -> pure ()
-    _ -> error "missing RedirectFileInfo"
-  let uri = strEncode $ fileDescriptionURI vfdRedirect
-  case strDecode uri of
-    Left err -> fail err
-    Right ok -> ok `shouldBe` fileDescriptionURI vfdRedirect
-  disposeAgentClient sndr
-  --- recipient
-  rcp <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
-  FileDescriptionURI {description} <- either fail pure $ strDecode uri
+  withAgent 1 agentCfg initAgentServers testDB $ \sndr -> do
+    directFileId <- runRight $ xftpSendFile sndr 1 (CryptoFile filePathIn Nothing) 1
+    sfGet sndr `shouldReturn` ("", directFileId, SFPROG 4194304 totalSize)
+    sfGet sndr `shouldReturn` ("", directFileId, SFPROG 8388608 totalSize)
+    sfGet sndr `shouldReturn` ("", directFileId, SFPROG 12582912 totalSize)
+    sfGet sndr `shouldReturn` ("", directFileId, SFPROG 16777216 totalSize)
+    sfGet sndr `shouldReturn` ("", directFileId, SFPROG 17825792 totalSize)
+    sfGet sndr `shouldReturn` ("", directFileId, SFPROG totalSize totalSize)
+    vfdDirect <-
+      sfGet sndr >>= \case
+        (_, _, SFDONE _snd (vfd : _)) -> pure vfd
+        r -> error $ "Expected SFDONE, got " <> show r

-  rcvFileId <- runRight $ xftpReceiveFile rcp 1 description Nothing
-  rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 65536 totalSize) -- extra RFPROG before switching to real file
-  rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 4194304 totalSize)
-  rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 8388608 totalSize)
-  rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 12582912 totalSize)
-  rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 16777216 totalSize)
-  rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 17825792 totalSize)
-  rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG totalSize totalSize)
-  out <-
-    rfGet rcp >>= \case
-      (_, _, RFDONE out) -> pure out
-      r -> error $ "Expected RFDONE, got " <> show r
-  disposeAgentClient rcp
+    testNoRedundancy vfdDirect

-  inBytes <- B.readFile filePathIn
-  B.readFile out `shouldReturn` inBytes
+    redirectFileId <- runRight $ xftpSendDescription sndr 1 vfdDirect 1
+    logInfo $ "File sent, sending redirect: " <> tshow redirectFileId
+    sfGet sndr `shouldReturn` ("", redirectFileId, SFPROG 65536 65536)
+    vfdRedirect@(ValidFileDescription fdRedirect) <-
+      sfGet sndr >>= \case
+        (_, _, SFDONE _snd (vfd : _)) -> pure vfd
+        r -> error $ "Expected SFDONE, got " <> show r
+
+    testNoRedundancy vfdRedirect
+
+    case fdRedirect of
+      FileDescription {redirect = Just _} -> pure ()
+      _ -> error "missing RedirectFileInfo"
+    let uri = strEncode $ fileDescriptionURI vfdRedirect
+    case strDecode uri of
+      Left err -> fail err
+      Right ok -> ok `shouldBe` fileDescriptionURI vfdRedirect
+    --- recipient
+    withAgent 2 agentCfg initAgentServers testDB2 $ \rcp -> do
+      FileDescriptionURI {description} <- either fail pure $ strDecode uri
+
+      rcvFileId <- runRight $ xftpReceiveFile rcp 1 description Nothing
+      rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 65536 totalSize) -- extra RFPROG before switching to real file
+      rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 4194304 totalSize)
+      rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 8388608 totalSize)
+      rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 12582912 totalSize)
+      rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 16777216 totalSize)
+      rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 17825792 totalSize)
+      rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG totalSize totalSize)
+      out <-
+        rfGet rcp >>= \case
+          (_, _, RFDONE out) -> pure out
+          r -> error $ "Expected RFDONE, got " <> show r
+
+      inBytes <- B.readFile filePathIn
+      B.readFile out `shouldReturn` inBytes

 testXFTPAgentSendReceiveNoRedirect :: HasCallStack => IO ()
 testXFTPAgentSendReceiveNoRedirect = withXFTPServer $ do
  --- sender
  let fileSize = mb 5
  filePathIn <- createRandomFile_ fileSize "testfile"
-  sndr <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
-  directFileId <- runRight $ xftpSendFile sndr 1 (CryptoFile filePathIn Nothing) 1
-  let totalSize = fileSize + mb 1
-  sfGet sndr `shouldReturn` ("", directFileId, SFPROG 4194304 totalSize)
-  sfGet sndr `shouldReturn` ("", directFileId, SFPROG 5242880 totalSize)
-  sfGet sndr `shouldReturn` ("", directFileId, SFPROG totalSize totalSize)
-  vfdDirect <-
-    sfGet sndr >>= \case
-      (_, _, SFDONE _snd (vfd : _)) -> pure vfd
-      r -> error $ "Expected SFDONE, got " <> show r
-  let uri = strEncode $ fileDescriptionURI vfdDirect
-  B.length uri `shouldSatisfy` (< qrSizeLimit)
-  case strDecode uri of
-    Left err -> fail err
-    Right ok -> ok `shouldBe` fileDescriptionURI vfdDirect
-  disposeAgentClient sndr
-  --- recipient
-  rcp <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
-  FileDescriptionURI {description} <- either fail pure $ strDecode uri
-  let ValidFileDescription FileDescription {redirect} = description
-  redirect `shouldBe` Nothing
-  rcvFileId <- runRight $ xftpReceiveFile rcp 1 description Nothing
-  -- NO extra "RFPROG 65k 65k" before switching to real file
-  rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 4194304 totalSize)
-  rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 5242880 totalSize)
-  rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG totalSize totalSize)
-  out <-
-    rfGet rcp >>= \case
-      (_, _, RFDONE out) -> pure out
-      r -> error $ "Expected RFDONE, got " <> show r
-  disposeAgentClient rcp
+  withAgent 1 agentCfg initAgentServers testDB $ \sndr -> do
+    directFileId <- runRight $ xftpSendFile sndr 1 (CryptoFile filePathIn Nothing) 1
+    let totalSize = fileSize + mb 1
+    sfGet sndr `shouldReturn` ("", directFileId, SFPROG 4194304 totalSize)
+    sfGet sndr `shouldReturn` ("", directFileId, SFPROG 5242880 totalSize)
+    sfGet sndr `shouldReturn` ("", directFileId, SFPROG totalSize totalSize)
+    vfdDirect <-
+      sfGet sndr >>= \case
+        (_, _, SFDONE _snd (vfd : _)) -> pure vfd
+        r -> error $ "Expected SFDONE, got " <> show r

-  inBytes <- B.readFile filePathIn
-  B.readFile out `shouldReturn` inBytes
+    testNoRedundancy vfdDirect
+
+    let uri = strEncode $ fileDescriptionURI vfdDirect
+    B.length uri `shouldSatisfy` (< qrSizeLimit)
+    case strDecode uri of
+      Left err -> fail err
+      Right ok -> ok `shouldBe` fileDescriptionURI vfdDirect
+    --- recipient
+    withAgent 2 agentCfg initAgentServers testDB2 $ \rcp -> do
+      FileDescriptionURI {description} <- either fail pure $ strDecode uri
+      let ValidFileDescription FileDescription {redirect} = description
+      redirect `shouldBe` Nothing
+      rcvFileId <- runRight $ xftpReceiveFile rcp 1 description Nothing
+      -- NO extra "RFPROG 65k 65k" before switching to real file
+      rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 4194304 totalSize)
+      rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 5242880 totalSize)
+      rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG totalSize totalSize)
+      out <-
+        rfGet rcp >>= \case
+          (_, _, RFDONE out) -> pure out
+          r -> error $ "Expected RFDONE, got " <> show r
+
+      inBytes <- B.readFile filePathIn
+      B.readFile out `shouldReturn` inBytes

 createRandomFile :: HasCallStack => IO FilePath
 createRandomFile = createRandomFile' "testfile"
@@ -255,9 +255,15 @@ testSendCF sndr file = do
  sfId <- xftpSendFile sndr 1 file 2
  sfProgress sndr $ mb 18
  ("", sfId', SFDONE sndDescr [rfd1, rfd2]) <- sfGet sndr
+  liftIO $ testNoRedundancy rfd1
+  liftIO $ testNoRedundancy rfd2
  liftIO $ sfId' `shouldBe` sfId
  pure (sfId, sndDescr, rfd1, rfd2)

+testNoRedundancy :: HasCallStack => ValidFileDescription 'FRecipient -> IO ()
+testNoRedundancy (ValidFileDescription FileDescription {chunks}) =
+  all (\FileChunk {replicas} -> length replicas == 1) chunks `shouldBe` True
+
 testReceive :: HasCallStack => AgentClient -> ValidFileDescription 'FRecipient -> FilePath -> ExceptT AgentErrorType IO RcvFileId
 testReceive rcp rfd = testReceiveCF rcp rfd Nothing

@@ -284,52 +290,48 @@ logCfgNoLogs :: LogConfig
 logCfgNoLogs = LogConfig {lc_file = Nothing, lc_stderr = False}

 testXFTPAgentReceiveRestore :: HasCallStack => IO ()
-testXFTPAgentReceiveRestore = withGlobalLogging logCfgNoLogs $ do
+testXFTPAgentReceiveRestore = do
  filePath <- createRandomFile

-  rfd <- withXFTPServerStoreLogOn $ \_ -> do
+  rfd <- withXFTPServerStoreLogOn $ \_ ->
    -- send file
-    sndr <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
-    runRight $ do
+    withAgent 1 agentCfg initAgentServers testDB $ \sndr -> runRight $ do
      (_, _, rfd, _) <- testSend sndr filePath
      pure rfd

  -- receive file - should not succeed with server down
-  rcp <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
-  rfId <- runRight $ do
+  rfId <- withAgent 2 agentCfg initAgentServers testDB2 $ \rcp -> runRight $ do
    xftpStartWorkers rcp (Just recipientFiles)
    rfId <- xftpReceiveFile rcp 1 rfd Nothing
    liftIO $ timeout 300000 (get rcp) `shouldReturn` Nothing -- wait for worker attempt
    pure rfId
-  disposeAgentClient rcp

  [prefixDir] <- listDirectory recipientFiles
  let tmpPath = recipientFiles </> prefixDir </> "xftp.encrypted"
  doesDirectoryExist tmpPath `shouldReturn` True

-  withXFTPServerStoreLogOn $ \_ -> do
+  withXFTPServerStoreLogOn $ \_ ->
    -- receive file - should start downloading with server up
-    rcp' <- getSMPAgentClient' 3 agentCfg initAgentServers testDB2
-    runRight_ $ xftpStartWorkers rcp' (Just recipientFiles)
-    ("", rfId', RFPROG _ _) <- rfGet rcp'
-    liftIO $ rfId' `shouldBe` rfId
-    disposeAgentClient rcp'
-
+    withAgent 3 agentCfg initAgentServers testDB2 $ \rcp' -> do
+      runRight_ $ xftpStartWorkers rcp' (Just recipientFiles)
+      ("", rfId', RFPROG _ _) <- rfGet rcp'
+      liftIO $ rfId' `shouldBe` rfId
  threadDelay 100000

-  withXFTPServerStoreLogOn $ \_ -> do
+  withXFTPServerStoreLogOn $ \_ ->
    -- receive file - should continue downloading with server up
-    rcp' <- getSMPAgentClient' 4 agentCfg initAgentServers testDB2
-    runRight_ $ xftpStartWorkers rcp' (Just recipientFiles)
-    rfProgress rcp' $ mb 18
-    ("", rfId', RFDONE path) <- rfGet rcp'
-    liftIO $ do
-      rfId' `shouldBe` rfId
-      file <- B.readFile filePath
-      B.readFile path `shouldReturn` file
+    withAgent 4 agentCfg initAgentServers testDB2 $ \rcp' -> do
+      runRight_ $ xftpStartWorkers rcp' (Just recipientFiles)
+      rfProgress rcp' $ mb 18
+      ("", rfId', RFDONE path) <- rfGet rcp'
+      liftIO $ do
+        rfId' `shouldBe` rfId
+        file <- B.readFile filePath
+        B.readFile path `shouldReturn` file

-  -- tmp path should be removed after receiving file
-  doesDirectoryExist tmpPath `shouldReturn` False
+      threadDelay 100000
+      -- tmp path should be removed after receiving file
+      doesDirectoryExist tmpPath `shouldReturn` False

 testXFTPAgentReceiveCleanup :: HasCallStack => IO ()
 testXFTPAgentReceiveCleanup = withGlobalLogging logCfgNoLogs $ do
@@ -337,30 +339,27 @@ testXFTPAgentReceiveCleanup = withGlobalLogging logCfgNoLogs $ do

  rfd <- withXFTPServerStoreLogOn $ \_ -> do
    -- send file
-    sndr <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
-    runRight $ do
+    withAgent 1 agentCfg initAgentServers testDB $ \sndr -> runRight $ do
      (_, _, rfd, _) <- testSend sndr filePath
      pure rfd

  -- receive file - should not succeed with server down
-  rcp <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
-  rfId <- runRight $ do
+  rfId <- withAgent 2 agentCfg initAgentServers testDB2 $ \rcp -> runRight $ do
    xftpStartWorkers rcp (Just recipientFiles)
    rfId <- xftpReceiveFile rcp 1 rfd Nothing
    liftIO $ timeout 300000 (get rcp) `shouldReturn` Nothing -- wait for worker attempt
    pure rfId
-  disposeAgentClient rcp

  [prefixDir] <- listDirectory recipientFiles
  let tmpPath = recipientFiles </> prefixDir </> "xftp.encrypted"
  doesDirectoryExist tmpPath `shouldReturn` True

-  withXFTPServerThreadOn $ \_ -> do
+  withXFTPServerThreadOn $ \_ ->
    -- receive file - should fail with AUTH error
-    rcp' <- getSMPAgentClient' 3 agentCfg initAgentServers testDB2
-    runRight_ $ xftpStartWorkers rcp' (Just recipientFiles)
-    ("", rfId', RFERR (INTERNAL "XFTP {xftpErr = AUTH}")) <- rfGet rcp'
-    rfId' `shouldBe` rfId
+    withAgent 3 agentCfg initAgentServers testDB2 $ \rcp' -> do
+      runRight_ $ xftpStartWorkers rcp' (Just recipientFiles)
+      ("", rfId', RFERR (INTERNAL "XFTP {xftpErr = AUTH}")) <- rfGet rcp'
+      rfId' `shouldBe` rfId

  -- tmp path should be removed after permanent error
  doesDirectoryExist tmpPath `shouldReturn` False
@@ -370,13 +369,11 @@ testXFTPAgentSendRestore = withGlobalLogging logCfgNoLogs $ do
  filePath <- createRandomFile

  -- send file - should not succeed with server down
-  sndr <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
-  sfId <- runRight $ do
+  sfId <- withAgent 1 agentCfg initAgentServers testDB $ \sndr -> runRight $ do
    xftpStartWorkers sndr (Just senderFiles)
    sfId <- xftpSendFile sndr 1 (CF.plain filePath) 2
    liftIO $ timeout 1000000 (get sndr) `shouldReturn` Nothing -- wait for worker to encrypt and attempt to create file
    pure sfId
-  disposeAgentClient sndr

  dirEntries <- listDirectory senderFiles
  let prefixDir = fromJust $ find (isSuffixOf "_snd.xftp") dirEntries
@@ -385,23 +382,25 @@ testXFTPAgentSendRestore = withGlobalLogging logCfgNoLogs $ do
  doesDirectoryExist prefixPath `shouldReturn` True
  doesFileExist encPath `shouldReturn` True

-  withXFTPServerStoreLogOn $ \_ -> do
+  withXFTPServerStoreLogOn $ \_ ->
    -- send file - should start uploading with server up
-    sndr' <- getSMPAgentClient' 2 agentCfg initAgentServers testDB
-    runRight_ $ xftpStartWorkers sndr' (Just senderFiles)
-    ("", sfId', SFPROG _ _) <- sfGet sndr'
-    liftIO $ sfId' `shouldBe` sfId
-    disposeAgentClient sndr'
+    withAgent 2 agentCfg initAgentServers testDB $ \sndr' -> do
+      runRight_ $ xftpStartWorkers sndr' (Just senderFiles)
+      ("", sfId', SFPROG _ _) <- sfGet sndr'
+      liftIO $ sfId' `shouldBe` sfId

  threadDelay 100000

  withXFTPServerStoreLogOn $ \_ -> do
    -- send file - should continue uploading with server up
-    sndr' <- getSMPAgentClient' 3 agentCfg initAgentServers testDB
-    runRight_ $ xftpStartWorkers sndr' (Just senderFiles)
-    sfProgress sndr' $ mb 18
-    ("", sfId', SFDONE _sndDescr [rfd1, _rfd2]) <- sfGet sndr'
-    liftIO $ sfId' `shouldBe` sfId
+    rfd1 <- withAgent 3 agentCfg initAgentServers testDB $ \sndr' -> do
+      runRight_ $ xftpStartWorkers sndr' (Just senderFiles)
+      sfProgress sndr' $ mb 18
+      ("", sfId', SFDONE _sndDescr [rfd1, rfd2]) <- sfGet sndr'
+      liftIO $ testNoRedundancy rfd1
+      liftIO $ testNoRedundancy rfd2
+      liftIO $ sfId' `shouldBe` sfId
+      pure rfd1

    -- prefix path should be removed after sending file
    threadDelay 100000
@@ -409,18 +408,16 @@ testXFTPAgentSendRestore = withGlobalLogging logCfgNoLogs $ do
    doesFileExist encPath `shouldReturn` False

    -- receive file
-    rcp <- getSMPAgentClient' 4 agentCfg initAgentServers testDB2
-    runRight_ . void $
-      testReceive rcp rfd1 filePath
+    withAgent 4 agentCfg initAgentServers testDB2 $ \rcp ->
+      runRight_ . void $ testReceive rcp rfd1 filePath

 testXFTPAgentSendCleanup :: HasCallStack => IO ()
 testXFTPAgentSendCleanup = withGlobalLogging logCfgNoLogs $ do
  filePath <- createRandomFile

-  sfId <- withXFTPServerStoreLogOn $ \_ -> do
+  sfId <- withXFTPServerStoreLogOn $ \_ ->
    -- send file
-    sndr <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
-    sfId <- runRight $ do
+    withAgent 1 agentCfg initAgentServers testDB $ \sndr -> runRight $ do
      xftpStartWorkers sndr (Just senderFiles)
      sfId <- xftpSendFile sndr 1 (CF.plain filePath) 2
      -- wait for progress events for 5 out of 6 chunks - at this point all chunks should be created on the server
@@ -428,8 +425,6 @@ testXFTPAgentSendCleanup = withGlobalLogging logCfgNoLogs $ do
        (_, _, SFPROG _ _) <- sfGet sndr
        pure ()
      pure sfId
-    disposeAgentClient sndr
-    pure sfId

  dirEntries <- listDirectory senderFiles
  let prefixDir = fromJust $ find (isSuffixOf "_snd.xftp") dirEntries
@@ -438,16 +433,16 @@ testXFTPAgentSendCleanup = withGlobalLogging logCfgNoLogs $ do
  doesDirectoryExist prefixPath `shouldReturn` True
  doesFileExist encPath `shouldReturn` True

-  withXFTPServerThreadOn $ \_ -> do
+  withXFTPServerThreadOn $ \_ ->
    -- send file - should fail with AUTH error
-    sndr' <- getSMPAgentClient' 2 agentCfg initAgentServers testDB
-    runRight_ $ xftpStartWorkers sndr' (Just senderFiles)
-    ("", sfId', SFERR (INTERNAL "XFTP {xftpErr = AUTH}")) <- sfGet sndr'
-    sfId' `shouldBe` sfId
+    withAgent 2 agentCfg initAgentServers testDB $ \sndr' -> do
+      runRight_ $ xftpStartWorkers sndr' (Just senderFiles)
+      ("", sfId', SFERR (INTERNAL "XFTP {xftpErr = AUTH}")) <- sfGet sndr'
+      sfId' `shouldBe` sfId

-    -- prefix path should be removed after permanent error
-    doesDirectoryExist prefixPath `shouldReturn` False
-    doesFileExist encPath `shouldReturn` False
+  -- prefix path should be removed after permanent error
+  doesDirectoryExist prefixPath `shouldReturn` False
+  doesFileExist encPath `shouldReturn` False

 testXFTPAgentDelete :: HasCallStack => IO ()
 testXFTPAgentDelete = withGlobalLogging logCfgNoLogs $
@@ -455,32 +450,30 @@ testXFTPAgentDelete = withGlobalLogging logCfgNoLogs $
    filePath <- createRandomFile

    -- send file
-    sndr <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
-    (sfId, sndDescr, rfd1, rfd2) <- runRight $ testSend sndr filePath
+    withAgent 1 agentCfg initAgentServers testDB $ \sndr -> do
+      (sfId, sndDescr, rfd1, rfd2) <- runRight $ testSend sndr filePath

-    -- receive file
-    rcp1 <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
-    runRight_ . void $
-      testReceive rcp1 rfd1 filePath
+      -- receive file
+      withAgent 2 agentCfg initAgentServers testDB2 $ \rcp1 -> do
+        runRight_ . void $ testReceive rcp1 rfd1 filePath

-    length <$> listDirectory xftpServerFiles `shouldReturn` 6
+        length <$> listDirectory xftpServerFiles `shouldReturn` 6

-    -- delete file
-    runRight_ $ xftpStartWorkers sndr (Just senderFiles)
-    xftpDeleteSndFileRemote sndr 1 sfId sndDescr
-    Nothing <- 100000 `timeout` sfGet sndr
-    disposeAgentClient rcp1
+        -- delete file
+        runRight_ $ xftpStartWorkers sndr (Just senderFiles)
+        xftpDeleteSndFileRemote sndr 1 sfId sndDescr
+        Nothing <- 100000 `timeout` sfGet sndr
+        pure ()

-    threadDelay 1000000
-    length <$> listDirectory xftpServerFiles `shouldReturn` 0
+      threadDelay 1000000
+      length <$> listDirectory xftpServerFiles `shouldReturn` 0

-    -- receive file - should fail with AUTH error
-    rcp2 <- getSMPAgentClient' 3 agentCfg initAgentServers testDB2
-    runRight $ do
-      xftpStartWorkers rcp2 (Just recipientFiles)
-      rfId <- xftpReceiveFile rcp2 1 rfd2 Nothing
-      ("", rfId', RFERR (INTERNAL "XFTP {xftpErr = AUTH}")) <- rfGet rcp2
-      liftIO $ rfId' `shouldBe` rfId
+      -- receive file - should fail with AUTH error
+      withAgent 3 agentCfg initAgentServers testDB2 $ \rcp2 -> runRight $ do
+        xftpStartWorkers rcp2 (Just recipientFiles)
+        rfId <- xftpReceiveFile rcp2 1 rfd2 Nothing
+        ("", rfId', RFERR (INTERNAL "XFTP {xftpErr = AUTH}")) <- rfGet rcp2
+        liftIO $ rfId' `shouldBe` rfId

 testXFTPAgentDeleteRestore :: HasCallStack => IO ()
 testXFTPAgentDeleteRestore = withGlobalLogging logCfgNoLogs $ do
@@ -488,42 +481,37 @@ testXFTPAgentDeleteRestore = withGlobalLogging logCfgNoLogs $ do

  (sfId, sndDescr, rfd2) <- withXFTPServerStoreLogOn $ \_ -> do
    -- send file
-    sndr <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
-    (sfId, sndDescr, rfd1, rfd2) <- runRight $ testSend sndr filePath
+    withAgent 1 agentCfg initAgentServers testDB $ \sndr -> do
+      (sfId, sndDescr, rfd1, rfd2) <- runRight $ testSend sndr filePath

-    -- receive file
-    rcp1 <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
-    runRight_ . void $
-      testReceive rcp1 rfd1 filePath
-    disposeAgentClient rcp1
-    disposeAgentClient sndr
-    pure (sfId, sndDescr, rfd2)
+      -- receive file
+      withAgent 2 agentCfg initAgentServers testDB2 $ \rcp1 ->
+        runRight_ . void $ testReceive rcp1 rfd1 filePath
+      pure (sfId, sndDescr, rfd2)

  -- delete file - should not succeed with server down
-  sndr <- getSMPAgentClient' 3 agentCfg initAgentServers testDB
-  runRight_ $ xftpStartWorkers sndr (Just senderFiles)
-  xftpDeleteSndFileRemote sndr 1 sfId sndDescr
-  timeout 300000 (get sndr) `shouldReturn` Nothing -- wait for worker attempt
-  disposeAgentClient sndr
+  withAgent 3 agentCfg initAgentServers testDB $ \sndr -> do
+    runRight_ $ xftpStartWorkers sndr (Just senderFiles)
+    xftpDeleteSndFileRemote sndr 1 sfId sndDescr
+    timeout 300000 (get sndr) `shouldReturn` Nothing -- wait for worker attempt

  threadDelay 300000
  length <$> listDirectory xftpServerFiles `shouldReturn` 6

  withXFTPServerStoreLogOn $ \_ -> do
    -- delete file - should succeed with server up
-    sndr' <- getSMPAgentClient' 4 agentCfg initAgentServers testDB
-    runRight_ $ xftpStartWorkers sndr' (Just senderFiles)
+    withAgent 4 agentCfg initAgentServers testDB $ \sndr' -> do
+      runRight_ $ xftpStartWorkers sndr' (Just senderFiles)

-    threadDelay 1000000
-    length <$> listDirectory xftpServerFiles `shouldReturn` 0
+      threadDelay 1000000
+      length <$> listDirectory xftpServerFiles `shouldReturn` 0

-    -- receive file - should fail with AUTH error
-    rcp2 <- getSMPAgentClient' 5 agentCfg initAgentServers testDB3
-    runRight $ do
-      xftpStartWorkers rcp2 (Just recipientFiles)
-      rfId <- xftpReceiveFile rcp2 1 rfd2 Nothing
-      ("", rfId', RFERR (INTERNAL "XFTP {xftpErr = AUTH}")) <- rfGet rcp2
-      liftIO $ rfId' `shouldBe` rfId
+      -- receive file - should fail with AUTH error
+      withAgent 5 agentCfg initAgentServers testDB3 $ \rcp2 -> runRight $ do
+        xftpStartWorkers rcp2 (Just recipientFiles)
+        rfId <- xftpReceiveFile rcp2 1 rfd2 Nothing
+        ("", rfId', RFERR (INTERNAL "XFTP {xftpErr = AUTH}")) <- rfGet rcp2
+        liftIO $ rfId' `shouldBe` rfId

 testXFTPAgentDeleteOnServer :: HasCallStack => IO ()
 testXFTPAgentDeleteOnServer = withGlobalLogging logCfgNoLogs $
@@ -531,36 +519,36 @@ testXFTPAgentDeleteOnServer = withGlobalLogging logCfgNoLogs $
    filePath1 <- createRandomFile' "testfile1"

    -- send file 1
-    sndr <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
-    (_, _, rfd1_1, rfd1_2) <- runRight $ testSend sndr filePath1
+    withAgent 1 agentCfg initAgentServers testDB $ \sndr -> do
+      (_, _, rfd1_1, rfd1_2) <- runRight $ testSend sndr filePath1

-    -- receive file 1 successfully
-    rcp <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
-    runRight_ . void $
-      testReceive rcp rfd1_1 filePath1
+      -- receive file 1 successfully
+      withAgent 2 agentCfg initAgentServers testDB2 $ \rcp -> do
+        runRight_ . void $ testReceive rcp rfd1_1 filePath1

-    serverFiles <- listDirectory xftpServerFiles
-    length serverFiles `shouldBe` 6
+        serverFiles <- listDirectory xftpServerFiles
+        length serverFiles `shouldBe` 6

-    -- delete file 1 on server from file system
-    forM_ serverFiles (\file -> removeFile (xftpServerFiles </> file))
+        -- delete file 1 on server from file system
+        forM_ serverFiles (\file -> removeFile (xftpServerFiles </> file))

-    threadDelay 1000000
-    length <$> listDirectory xftpServerFiles `shouldReturn` 0
+        threadDelay 1000000
+        length <$> listDirectory xftpServerFiles `shouldReturn` 0

-    -- create and send file 2
-    filePath2 <- createRandomFile' "testfile2"
-    (_, _, rfd2, _) <- runRight $ testSend sndr filePath2
+        -- create and send file 2
+        filePath2 <- createRandomFile' "testfile2"
+        (_, _, rfd2, _) <- runRight $ testSend sndr filePath2

-    length <$> listDirectory xftpServerFiles `shouldReturn` 6
+        length <$> listDirectory xftpServerFiles `shouldReturn` 6

-    runRight_ . void $ do
-      -- receive file 1 again
-      -- TODO should fail with AUTH error
-      _rfId1 <- xftpReceiveFile rcp 1 rfd1_2 Nothing
+        runRight_ . void $ do
+          -- receive file 1 again
+          rfId1 <- xftpReceiveFile rcp 1 rfd1_2 Nothing
+          ("", rfId1', RFERR (INTERNAL "XFTP {xftpErr = AUTH}")) <- rfGet rcp
+          liftIO $ rfId1 `shouldBe`  rfId1'

-      -- receive file 2
-      testReceive' rcp rfd2 filePath2
+          -- receive file 2
+          testReceive' rcp rfd2 filePath2

 testXFTPAgentExpiredOnServer :: HasCallStack => IO ()
 testXFTPAgentExpiredOnServer = withGlobalLogging logCfgNoLogs $ do
@@ -569,46 +557,43 @@ testXFTPAgentExpiredOnServer = withGlobalLogging logCfgNoLogs $ do
    filePath1 <- createRandomFile' "testfile1"

    -- send file 1
-    sndr <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
-    (_, _, rfd1_1, rfd1_2) <- runRight $ testSend sndr filePath1
+    withAgent 1 agentCfg initAgentServers testDB $ \sndr -> do
+      (_, _, rfd1_1, rfd1_2) <- runRight $ testSend sndr filePath1

-    -- receive file 1 successfully
-    rcp <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
-    runRight_ . void $
-      testReceive rcp rfd1_1 filePath1
+      -- receive file 1 successfully
+      withAgent 2 agentCfg initAgentServers testDB2 $ \rcp -> do
+        runRight_ . void $ testReceive rcp rfd1_1 filePath1

-    serverFiles <- listDirectory xftpServerFiles
-    length serverFiles `shouldBe` 6
+        serverFiles <- listDirectory xftpServerFiles
+        length serverFiles `shouldBe` 6

-    -- wait until file 1 expires on server
-    forM_ serverFiles (\file -> removeFile (xftpServerFiles </> file))
+        -- wait until file 1 expires on server
+        forM_ serverFiles (\file -> removeFile (xftpServerFiles </> file))

-    threadDelay 3500000
-    length <$> listDirectory xftpServerFiles `shouldReturn` 0
+        threadDelay 3500000
+        length <$> listDirectory xftpServerFiles `shouldReturn` 0

-    -- receive file 1 again - should fail with AUTH error
-    runRight $ do
-      rfId <- xftpReceiveFile rcp 1 rfd1_2 Nothing
-      ("", rfId', RFERR (INTERNAL "XFTP {xftpErr = AUTH}")) <- rfGet rcp
-      liftIO $ rfId' `shouldBe` rfId
+        -- receive file 1 again - should fail with AUTH error
+        runRight $ do
+          rfId <- xftpReceiveFile rcp 1 rfd1_2 Nothing
+          ("", rfId', RFERR (INTERNAL "XFTP {xftpErr = AUTH}")) <- rfGet rcp
+          liftIO $ rfId' `shouldBe` rfId

-    -- create and send file 2
-    filePath2 <- createRandomFile' "testfile2"
-    (_, _, rfd2, _) <- runRight $ testSend sndr filePath2
+        -- create and send file 2
+        filePath2 <- createRandomFile' "testfile2"
+        (_, _, rfd2, _) <- runRight $ testSend sndr filePath2

-    length <$> listDirectory xftpServerFiles `shouldReturn` 6
+        length <$> listDirectory xftpServerFiles `shouldReturn` 6

-    -- receive file 2 successfully
-    runRight_ . void $
-      testReceive' rcp rfd2 filePath2
+        -- receive file 2 successfully
+        runRight_ . void $ testReceive' rcp rfd2 filePath2

 testXFTPAgentRequestAdditionalRecipientIDs :: HasCallStack => IO ()
 testXFTPAgentRequestAdditionalRecipientIDs = withXFTPServer $ do
  filePath <- createRandomFile

  -- send file
-  sndr <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
-  rfds <- runRight $ do
+  rfds <- withAgent 1 agentCfg initAgentServers testDB $ \sndr -> runRight $ do
    xftpStartWorkers sndr (Just senderFiles)
    sfId <- xftpSendFile sndr 1 (CF.plain filePath) 500
    sfProgress sndr $ mb 18
@@ -618,10 +603,11 @@ testXFTPAgentRequestAdditionalRecipientIDs = withXFTPServer $ do
      length rfds `shouldBe` 500
    pure rfds

+  forM_ rfds testNoRedundancy
+
  -- receive file using different descriptions
  -- ! revise number of recipients and indexes if xftpMaxRecipientsPerRequest is changed
-  rcp <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
-  runRight_ $ do
+  withAgent 2 agentCfg initAgentServers testDB2 $ \rcp -> runRight_ $ do
    void $ testReceive rcp (head rfds) filePath
    void $ testReceive rcp (rfds !! 99) filePath
    void $ testReceive rcp (rfds !! 299) filePath
@@ -629,6 +615,7 @@ testXFTPAgentRequestAdditionalRecipientIDs = withXFTPServer $ do

 testXFTPServerTest :: HasCallStack => Maybe BasicAuth -> XFTPServerWithAuth -> IO (Maybe ProtocolTestFailure)
 testXFTPServerTest newFileBasicAuth srv =
-  withXFTPServerCfg testXFTPServerConfig {newFileBasicAuth, xftpPort = xftpTestPort2} $ \_ -> do
-    a <- getSMPAgentClient' 1 agentCfg initAgentServers testDB -- initially passed server is not running
-    testProtocolServer a 1 srv
+  withXFTPServerCfg testXFTPServerConfig {newFileBasicAuth, xftpPort = xftpTestPort2} $ \_ ->
+    -- initially passed server is not running
+    withAgent 1 agentCfg initAgentServers testDB $ \a ->
+      testProtocolServer a 1 srv
@@ -5,7 +5,7 @@

 module XFTPClient where

-import Control.Concurrent (ThreadId)
+import Control.Concurrent (ThreadId, threadDelay)
 import Data.String (fromString)
 import Network.Socket (ServiceName)
 import SMPClient (serverBracket)
@@ -13,6 +13,7 @@ import Simplex.FileTransfer.Client
 import Simplex.FileTransfer.Description
 import Simplex.FileTransfer.Server (runXFTPServerBlocking)
 import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..), defaultFileExpiration, defaultInactiveClientExpiration)
+import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Protocol (XFTPServer)
 import Simplex.Messaging.Transport.Server
 import Test.Hspec
@@ -52,7 +53,7 @@ withXFTPServerCfg :: HasCallStack => XFTPServerConfig -> (HasCallStack => Thread
 withXFTPServerCfg cfg =
  serverBracket
    (`runXFTPServerBlocking` cfg)
-    (pure ())
+    (threadDelay 10000)

 withXFTPServerThreadOn :: HasCallStack => (HasCallStack => ThreadId -> IO a) -> IO a
 withXFTPServerThreadOn = withXFTPServerCfg testXFTPServerConfig
@@ -124,7 +125,8 @@ testXFTPClientConfig :: XFTPClientConfig
 testXFTPClientConfig = defaultXFTPClientConfig

 testXFTPClient :: HasCallStack => (HasCallStack => XFTPClient -> IO a) -> IO a
-testXFTPClient client =
-  getXFTPClient (1, testXFTPServer, Nothing) testXFTPClientConfig (\_ -> pure ()) >>= \case
+testXFTPClient client = do
+  g <- C.newRandom
+  getXFTPClient g (1, testXFTPServer, Nothing) testXFTPClientConfig (\_ -> pure ()) >>= \case
    Right c -> client c
    Left e -> error $ show e
@@ -12,6 +12,7 @@ import Control.Exception (SomeException)
 import Control.Monad
 import Control.Monad.Except
 import Control.Monad.IO.Unlift
+import qualified Data.ByteString.Base64.URL as B64
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy.Char8 as LB
@@ -21,11 +22,10 @@ import Simplex.FileTransfer.Client
 import Simplex.FileTransfer.Description (kb)
 import Simplex.FileTransfer.Protocol (FileInfo (..))
 import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..))
-import Simplex.FileTransfer.Transport (XFTPRcvChunkSpec (..), XFTPErrorType (..))
+import Simplex.FileTransfer.Transport (XFTPErrorType (..), XFTPRcvChunkSpec (..))
 import Simplex.Messaging.Client (ProtocolClientError (..))
 import qualified Simplex.Messaging.Crypto as C
 import qualified Simplex.Messaging.Crypto.Lazy as LC
-import qualified Simplex.Messaging.Encoding.Base64.URL as U
 import Simplex.Messaging.Protocol (BasicAuth, SenderId)
 import Simplex.Messaging.Server.Expiration (ExpirationConfig (..))
 import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive, removeFile)
@@ -75,7 +75,7 @@ createTestChunk fp = do
  pure bytes

 readChunk :: SenderId -> IO ByteString
-readChunk sId = B.readFile (xftpServerFiles </> B.unpack (U.encode sId))
+readChunk sId = B.readFile (xftpServerFiles </> B.unpack (B64.encode sId))

 testFileChunkDelivery :: Expectation
 testFileChunkDelivery = xftpTest $ \c -> runRight_ $ runTestFileChunkDelivery c c
@@ -219,7 +219,8 @@ testFileChunkExpiration = withXFTPServerCfg testXFTPServerConfig {fileExpiration
 testInactiveClientExpiration :: Expectation
 testInactiveClientExpiration = withXFTPServerCfg testXFTPServerConfig {inactiveClientExpiration} $ \_ -> runRight_ $ do
  disconnected <- newEmptyTMVarIO
-  c <- ExceptT $ getXFTPClient (1, testXFTPServer, Nothing) testXFTPClientConfig (\_ -> atomically $ putTMVar disconnected ())
+  g <- liftIO C.newRandom
+  c <- ExceptT $ getXFTPClient g (1, testXFTPServer, Nothing) testXFTPClientConfig (\_ -> atomically $ putTMVar disconnected ())
  pingXFTP c
  liftIO $ do
    threadDelay 100000
@@ -0,0 +1,12 @@
+-----BEGIN CERTIFICATE-----
+MIIBtjCCATagAwIBAgIUDJc0ixVBYPdcL5W7zE8dhm0UMpswBQYDK2VxMCoxFjAU
+BgNVBAMMDVNNUCBzZXJ2ZXIgQ0ExEDAOBgNVBAoMB1NpbXBsZVgwIBcNMjQwNDA4
+MTg0ODIwWhgPNDc2MjAzMDUxODQ4MjBaMCoxFjAUBgNVBAMMDVNNUCBzZXJ2ZXIg
+Q0ExEDAOBgNVBAoMB1NpbXBsZVgwQzAFBgMrZXEDOgAST4assVdIwL/kbtWmbyJm
+X/CNGUQFkArvgvcRTZOwJPu9ypmv0mSz2I6acsw6gr8LHq8mlv7iPICjUzBRMB0G
+A1UdDgQWBBTBsA6VVhkO61ixwlel+g7D08shnjAfBgNVHSMEGDAWgBTBsA6VVhkO
+61ixwlel+g7D08shnjAPBgNVHRMBAf8EBTADAQH/MAUGAytlcQNzAKAfQ0EEQtnR
+HvNiKBajo77prZX680apmxBxSZuLNORQMvKBLDm2qaGv5S/c9gmvLjLz2Avrspow
+ANBF71DKcvgb25D2LLDp0CQOBt/dP41Cgd/ZigyHyOq2/Oj15Skbu0TdXYuIxf/k
+MZ0XUvYwG6IKAA==
+-----END CERTIFICATE-----
@@ -0,0 +1,4 @@
+-----BEGIN PRIVATE KEY-----
+MEcCAQAwBQYDK2VxBDsEOcBpozc2TnAf6lQaxN5bA6JdbKWuxUecsW9P2dzncCnB
+/alBtYXqW6SprBj1DqzeZyU4rQ7OqFrgBw==
+-----END PRIVATE KEY-----
@@ -0,0 +1,12 @@
+-----BEGIN CERTIFICATE-----
+MIIBvDCCATygAwIBAgIUbx6kKw7PGGxhTPutroJFZbOcVk0wBQYDK2VxMCoxFjAU
+BgNVBAMMDVNNUCBzZXJ2ZXIgQ0ExEDAOBgNVBAoMB1NpbXBsZVgwIBcNMjQwNDA4
+MTg0ODI2WhgPNDc2MjAzMDUxODQ4MjZaMBQxEjAQBgNVBAMMCWxvY2FsaG9zdDBD
+MAUGAytlcQM6ACKox7DzkUjK6ZN0pCzABv5vcqk5Tu+zaLWEWlHFnpIN/f/AcBI1
+GbZCmD/zb6OG49vsAKPnMAyIgKNvMG0wCQYDVR0TBAIwADALBgNVHQ8EBAMCA8gw
+EwYDVR0lBAwwCgYIKwYBBQUHAwEwHQYDVR0OBBYEFGFx/ISB2xEW2tGhVYVncWTd
+lwkrMB8GA1UdIwQYMBaAFMGwDpVWGQ7rWLHCV6X6DsPTyyGeMAUGAytlcQNzAMp9
+EL+22OkeGG6s7LxpXJgVG6dxbcNn6aTgTX2pDYt8n+cRQTeTZ1MLDYVIe289pIQK
+tbKmI+HIgHExuNurJw6f6FknVmEeJpOXLV5lybL4f/fZGKrAE5rbhtNnQAp1mw0c
+ngt8dhyISxv/zoQLSkIcAA==
+-----END CERTIFICATE-----
@@ -0,0 +1,4 @@
+-----BEGIN PRIVATE KEY-----
+MEcCAQAwBQYDK2VxBDsEObrN+1gIRcwmahmitb6ltVoZjjnVoHj0/1waYkjmMtQl
+PiGhWP5/B6Y1fLH/YiO/tfX2YPGCOJJSJQ==
+-----END PRIVATE KEY-----
@@ -0,0 +1,13 @@
+-----BEGIN CERTIFICATE-----
+MIIB6zCCAXKgAwIBAgIUbLI6PjnyP24ukjmIE3LsjFqn/LYwCgYIKoZIzj0EAwIw
+FjEUMBIGA1UEAwwLZXhhbXBsZS5jb20wHhcNMjQwNDA4MTg1OTA2WhcNMzQwNDA2
+MTg1OTA2WjAWMRQwEgYDVQQDDAtleGFtcGxlLmNvbTB2MBAGByqGSM49AgEGBSuB
+BAAiA2IABMIrmyP4FDY+P8Tulv8Bcp5U7QlHigoOW6JPRPTETTFBl2e7t9UApa/E
+AYl805mkaIdrDJzdtAqkttHmPm4vXdCCualxVRZ/thtpvdNocxyJOD9BVv3QKqiu
+SGuCGHp+m6OBgDB+MB0GA1UdDgQWBBR5D79SM77XfY/bii0NJ1OllAWw1TAfBgNV
+HSMEGDAWgBR5D79SM77XfY/bii0NJ1OllAWw1TAPBgNVHRMBAf8EBTADAQH/MCsG
+A1UdEQQkMCKCC2V4YW1wbGUuY29tgg0qLmV4YW1wbGUuY29thwQKAAABMAoGCCqG
+SM49BAMCA2cAMGQCMDuIOZBcKI/OXOWx75o5xgwIDio4P7zK9kJt7D4YJMxPvTV6
+vVajYSuJwiIF3/GwoQIwPUbNndNNnf1tYJdPhEJ3e8bA2a3bDbb2dgfiUfj6amaS
+RcSkYms1WDLMFP0LHo/Z
+-----END CERTIFICATE-----
@@ -0,0 +1,6 @@
+-----BEGIN PRIVATE KEY-----
+MIG2AgEAMBAGByqGSM49AgEGBSuBBAAiBIGeMIGbAgEBBDBH/6IpMqcKFrXNU8Nb
+QFvdzQOJtfoAEEDRBmMqbihPrCgbtCJ3FIVnxqGlFIXADaqhZANiAATCK5sj+BQ2
+Pj/E7pb/AXKeVO0JR4oKDluiT0T0xE0xQZdnu7fVAKWvxAGJfNOZpGiHawyc3bQK
+pLbR5j5uL13QgrmpcVUWf7Ybab3TaHMciTg/QVb90Cqorkhrghh6fps=
+-----END PRIVATE KEY-----