Merge branch 'stable' into ep/optimize

6.5.4.0
crypto: BBS scheme for anonymous credentials with multiple presentations (#1794 )
2026-08-30 16:18:24 +00:00 · 2026-06-16 21:57:18 +01:00 · 2026-06-15 22:26:45 +01:00 · 2026-06-15 09:44:11 +01:00 · 2026-06-09 15:38:58 +00:00 · 2026-06-01 13:17:47 +01:00
20 changed files with 896 additions and 85 deletions
@@ -24,6 +24,8 @@ jobs:
      - name: Clone project
        if: startsWith(github.ref, 'refs/tags/v')
        uses: actions/checkout@v3
+        with:
+          submodules: recursive

      - name: Build changelog
        id: build_changelog
@@ -114,6 +116,8 @@ jobs:
      - name: Clone project
        if: matrix.should_run == true
        uses: actions/checkout@v3
+        with:
+          submodules: recursive

      - name: Set up Docker Buildx
        if: matrix.should_run == true
@@ -180,7 +184,7 @@ jobs:
          chmod -fR 777 ~/.cabal ./dist-newstyle || :; git config --global --add safe.directory '*'
          cabal clean
          cabal update
-          cabal build --jobs=$(nproc) --enable-tests -fserver_postgres
+          cabal build --jobs=$(nproc) --enable-tests -fserver_postgres ${{ github.event_name != 'pull_request' && '-foptimize' || '' }}
          mkdir -p /out
          for i in smp-server xftp-server simplexmq-test; do
            bin=$(find /project/dist-newstyle -name "$i" -type f -executable)
@@ -223,7 +227,7 @@ jobs:
        if: matrix.should_run == true
        shell: docker exec -t builder sh -eu {0}
        run: |
-          cabal build --jobs=$(nproc)
+          cabal build --jobs=$(nproc) ${{ github.event_name != 'pull_request' && '-foptimize' || '' }}
          mkdir -p /out
          for i in ${{ env.apps }}; do
            bin=$(find /project/dist-newstyle -name "$i" -type f -executable)
@@ -20,6 +20,8 @@ jobs:
    steps:
      - name: Clone project
        uses: actions/checkout@v4
+        with:
+          submodules: recursive

      - name: Log in to Docker Hub
        uses: simplex-chat/docker-login-action@v3
@@ -11,6 +11,8 @@ jobs:
    steps:
      - name: Checkout code
        uses: actions/checkout@v3
+        with:
+          submodules: recursive

      - name: Get latest release
        shell: bash
@@ -0,0 +1,6 @@
+[submodule "cbits/libbbs"]
+	path = cbits/libbbs
+	url = https://github.com/simplex-chat/libbbs.git
+[submodule "cbits/blst"]
+	path = cbits/blst
+	url = https://github.com/supranational/blst.git
@@ -1,3 +1,10 @@
+# 6.5.1
+
+Version 6.5.1.0
+
+XFTP client:
+- backwards compatible file header decoding.
+
 # 6.5.0

 Version 6.5.0.17
@@ -45,9 +45,9 @@ WORKDIR /project
 ARG APP
 RUN if [ -z "$APP" ]; then printf "Please spcify \$APP build-arg.\n"; exit 1; fi

-# Compile app
+# Compile app (optimized for release images)
 RUN cabal update
-RUN cabal build exe:$APP
+RUN cabal build exe:$APP -foptimize

 # Copy scripts
 COPY scripts /project/scripts/
@@ -31,8 +31,8 @@ xftpWebContent = $(embedDir "apps/xftp-server/static/xftp-web-bundle/")
 xftpMediaContent :: [(FilePath, ByteString)]
 xftpMediaContent = $(embedDir "apps/xftp-server/static/media/")

-- xftpFilePageHtml :: ByteString
-- xftpFilePageHtml = $(embedFile "apps/xftp-server/static/file.html")
+xftpFilePageHtml :: ByteString
+xftpFilePageHtml = $(embedFile "apps/xftp-server/static/file.html")

 xftpGenerateSite :: XFTPServerConfig s -> Maybe ServerPublicInfo -> Maybe TransportHost -> FilePath -> IO ()
 xftpGenerateSite cfg info onionHost path = do
@@ -44,7 +44,7 @@ xftpGenerateSite cfg info onionHost path = do
  filePage xftpDir xftpWebContent
  filePage mediaDir xftpMediaContent
  createDirectoryIfMissing True fileDir
-  -- B.writeFile (fileDir </> "index.html") $ render xftpFilePageHtml substs
+  B.writeFile (fileDir </> "index.html") $ render xftpFilePageHtml substs
  where
    filePage dir content_ = do
      createDirectoryIfMissing True dir
@@ -0,0 +1,126 @@
+# BBS+ Bindings for simplexmq
+
+Haskell FFI bindings to libbbs for BBS+ signatures. General-purpose - the module knows nothing about specific applications.
+
+## How BBS+ works
+
+BBS+ signs a fixed list of N messages. Each message is an arbitrary byte array. The signer signs all N messages at once with one signature.
+
+The holder of the signature can then generate a proof that selectively discloses some messages and hides others. The verifier learns the disclosed messages and confirms they were signed by the signer, but learns nothing about the hidden messages. Different proofs from the same signature are unlinkable.
+
+Key constraint: the total number of messages N is fixed at signing time. The verifier must know N. A proof generated from a 3-message signature cannot be verified as a 2-message proof.
+
+## Types
+
+```haskell
+newtype BBSSecretKey = BBSSecretKey ByteString  -- 32 bytes
+newtype BBSPublicKey = BBSPublicKey ByteString  -- 96 bytes (BLS12-381 G2 point)
+newtype BBSSignature = BBSSignature ByteString  -- 80 bytes
+newtype BBSProof = BBSProof ByteString          -- 272 + 32 * numUndisclosed bytes
+newtype BBSHeader = BBSHeader ByteString        -- always-disclosed context (e.g. protocol identifier)
+newtype BBSPresHeader = BBSPresHeader ByteString -- random nonce for proof unlinkability
+```
+
+All newtypes get StrEncoding (base64url), ToJSON/FromJSON (via strToJSON/strParseJSON), Eq, Show.
+
+## Functions
+
+```haskell
+bbsKeyGen :: IO (Either String BBSKeyPair)  -- BBSKeyPair = (BBSPublicKey, BBSSecretKey)
+
+-- pk is derived from sk internally, so it is not a parameter
+bbsSign
+  :: BBSSecretKey
+  -> BBSHeader            -- always-disclosed context
+  -> [ByteString]         -- all N messages
+  -> IO (Either String BBSSignature)
+
+-- C order: pk, signature, header, presentation_header, disclosed_indexes, messages
+bbsProofGen
+  :: BBSPublicKey
+  -> BBSSignature
+  -> BBSHeader            -- must match what was signed
+  -> BBSPresHeader        -- random nonce bound into the proof
+  -> [Int]                -- disclosed indexes (0-based)
+  -> [ByteString]         -- all N messages (needed internally, hidden ones not revealed in proof)
+  -> IO (Either String BBSProof)
+
+-- C order: pk, proof, header, presentation_header, disclosed_indexes, n, messages
+bbsProofVerify
+  :: BBSPublicKey
+  -> BBSProof
+  -> BBSHeader            -- must match what was signed
+  -> BBSPresHeader        -- must match what was used in bbsProofGen
+  -> [Int]                -- disclosed indexes
+  -> Int                  -- total message count N
+  -> [ByteString]         -- disclosed messages only
+  -> IO Bool
+```
+
+## How applications use it
+
+An application defines:
+- A message layout: which index means what
+- Which indexes are disclosed vs hidden
+- How to encode application values as ByteString messages
+
+### Badge example (in simplex-chat, not in this module)
+
+Message layout (always 3 messages):
+- Index 0: master secret (32 random bytes) - HIDDEN
+- Index 1: expiry (UTF-8 encoded timestamp string) - DISCLOSED
+- Index 2: badge type (UTF-8 encoded, e.g. "supporter") - DISCLOSED
+
+Signing (v2, on the server):
+```
+bbsSign sk header [ms, encodeUtf8 "2026-07-31", encodeUtf8 "supporter"]
+```
+
+Proof generation (v2, on the client):
+```
+bbsProofGen pk sig header presHeader [1, 2] [ms, encodeUtf8 "2026-07-31", encodeUtf8 "supporter"]
+```
+
+Proof verification (v1, on the recipient):
+```
+bbsProofVerify pk proof header presHeader 3 [1, 2] [encodeUtf8 "2026-07-31", encodeUtf8 "supporter"]
+```
+
+The recipient only sees the proof, presentationHeader, expiry string, and badge type string. They verify these were signed by the server (pk is hardcoded). They never see the master secret.
+
+Expiry is always present as a string. Monthly badges use a date like `"2026-07-31"`, lifetime badges use `"lifetime"`. BBS+ doesn't interpret the bytes - expiry semantics are the application's responsibility. This keeps the message count fixed at 3 for all badge types.
+
+## libbbs C API mapping
+
+```c
+int bbs_keygen_full(ciphersuite, sk, pk)
+int bbs_sign(ciphersuite, sk, pk, signature, header, header_len, n, messages, message_lens)
+int bbs_proof_gen(ciphersuite, pk, signature, proof, header, header_len, presentation_header, presentation_header_len, disclosed_indexes, disclosed_indexes_len, n, messages, message_lens)
+int bbs_proof_verify(ciphersuite, pk, proof, proof_len, header, header_len, presentation_header, presentation_header_len, disclosed_indexes, disclosed_indexes_len, n, messages, message_lens)
+```
+
+We use `bbs_sha256_ciphersuite`. The header parameter is exposed in all Haskell functions - the application decides what to put there. Tests use `"SimpleX"` as header.
+
+The `presentation_header` parameter is what we call `presentationHeader`.
+
+In `bbs_proof_verify`, the `n` parameter is the total number of messages (not the number of disclosed messages). The `messages` array contains only the disclosed messages, and `disclosed_indexes` maps each to its position in the original message list.
+
+## Build
+
+Submodules in cbits/:
+- `cbits/libbbs` - https://github.com/Fraunhofer-AISEC/libbbs
+- `cbits/blst` - https://github.com/supranational/blst (libbbs dependency)
+
+C sources in cabal: `cbits/blst/src/server.c`, `cbits/blst/build/assembly.S`, libbbs source files.
+Include dirs: `cbits/blst/bindings/`, `cbits/blst/src/`, `cbits/libbbs/include/`, `cbits/libbbs/src/`.
+C flags: `-D__BLST_PORTABLE__` for cross-CPU-generation compatibility.
+
+## Tests
+
+- Keygen produces keys of correct size
+- Sign + proofGen + proofVerify roundtrip succeeds
+- Tampered proof fails verification
+- Tampered disclosed message fails verification
+- Wrong public key fails verification
+- Two proofs from same credential with different nonces both verify
+- Proof size matches expected (272 + 32 * numUndisclosed)
@@ -47,7 +47,7 @@ for os in 22.04 24.04; do
 	docker exec \
 		-t \
 		builder \
-		sh -c 'git config --global --add safe.directory \*; cabal update && cabal build --jobs=$(nproc) --enable-tests -fserver_postgres && mkdir -p /out && for i in smp-server simplexmq-test; do bin=$(find /project/dist-newstyle -name "$i" -type f -executable) && chmod +x "$bin" && mv "$bin" /out/; done && strip /out/smp-server'
+		sh -c 'git config --global --add safe.directory \*; cabal update && cabal build --jobs=$(nproc) --enable-tests -fserver_postgres -foptimize && mkdir -p /out && for i in smp-server simplexmq-test; do bin=$(find /project/dist-newstyle -name "$i" -type f -executable) && chmod +x "$bin" && mv "$bin" /out/; done && strip /out/smp-server'

 	# Copy smp-server postgresql binary and prepare it
 	docker cp \
@@ -67,7 +67,7 @@ for os in 22.04 24.04; do
 		-t \
 		-e apps="$apps" \
 		builder \
-		sh -c 'cabal build --jobs=$(nproc) && mkdir -p /out && for i in $apps; do bin=$(find /project/dist-newstyle -name "$i" -type f -executable) && strip "$bin" && chmod +x "$bin" && mv "$bin" /out/; done'
+		sh -c 'cabal build --jobs=$(nproc) -foptimize && mkdir -p /out && for i in $apps; do bin=$(find /project/dist-newstyle -name "$i" -type f -executable) && strip "$bin" && chmod +x "$bin" && mv "$bin" /out/; done'

 	# Copy regular binaries
 	docker cp \
@@ -1,7 +1,7 @@
-cabal-version: 1.12
+cabal-version: 3.0

 name:           simplexmq
-version:        6.5.0.17
+version:        6.5.4.0
 synopsis:       SimpleXMQ message broker
 description:    This package includes <./docs/Simplex-Messaging-Server.html server>,
                <./docs/Simplex-Messaging-Client.html client> and
@@ -16,7 +16,7 @@ homepage:       https://github.com/simplex-chat/simplexmq#readme
 author:         simplex.chat
 maintainer:     chat@simplex.chat
 copyright:      2020-2022 simplex.chat
-license:        AGPL-3
+license:        AGPL-3.0-only
 license-file:   LICENSE
 build-type:     Simple
 extra-source-files:
@@ -24,6 +24,13 @@ extra-source-files:
    CHANGELOG.md
    cbits/sha512.h
    cbits/sntrup761.h
+    cbits/blst/**/*.c
+    cbits/blst/**/*.h
+    cbits/blst/**/*.s
+    cbits/blst/**/*.S
+    cbits/blst/**/*.asm
+    cbits/libbbs/**/*.c
+    cbits/libbbs/**/*.h
    apps/common/Web/static/index.html
    apps/common/Web/static/link.html
    apps/common/Web/static/media/apk_icon.png
@@ -82,6 +89,16 @@ flag server_postgres
  manual: True
  default: False

+flag commoncrypto
+  description: On Apple platforms, use SecRandomCopyBytes (Security.framework) for libbbs randomness. getentropy is a non-public symbol on iOS and triggers App Store rejection (ITMS-90338).
+  manual: True
+  default: False
+
+flag optimize
+  description: Build with -O2 optimization. Enabled for releases, master/stable and Docker builds; disabled by default for faster local and PR builds (-O0).
+  manual: True
+  default: False
+
 library
  exposed-modules:
      Simplex.FileTransfer.Agent
@@ -122,6 +139,7 @@ library
      Simplex.Messaging.Crypto.File
      Simplex.Messaging.Crypto.Lazy
      Simplex.Messaging.Crypto.Ratchet
+      Simplex.Messaging.Crypto.BBS
      Simplex.Messaging.Crypto.SNTRUP761
      Simplex.Messaging.Crypto.SNTRUP761.Bindings
      Simplex.Messaging.Crypto.SNTRUP761.Bindings.Defines
@@ -295,12 +313,33 @@ library
      src
  default-extensions:
      StrictData
-  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=incomplete-uni-patterns -Werror=missing-home-modules -Werror=missing-methods -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -O2
+  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=incomplete-uni-patterns -Werror=missing-home-modules -Werror=missing-methods -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns
+  if flag(optimize)
+    ghc-options: -O2
+  else
+    ghc-options: -O0
  include-dirs:
      cbits
+      cbits/blst/bindings
+      cbits/blst/src
+      cbits/libbbs/include
+      cbits/libbbs/src
+  cc-options: -D__BLST_PORTABLE__
+  if flag(commoncrypto)
+    cc-options: -DBBS_CRYPTO_CC
+    frameworks: Security
  c-sources:
      cbits/sha512.c
      cbits/sntrup761.c
+      cbits/blst/src/server.c
+      cbits/libbbs/src/bbs.c
+      cbits/libbbs/src/bbs_ciphersuites.c
+      cbits/libbbs/src/bbs_util.c
+      cbits/libbbs/src/compat-string.c
+      cbits/libbbs/src/sha256.c
+      cbits/libbbs/src/shake256.c
+  asm-sources:
+      cbits/blst/build/assembly.S
  extra-libraries:
      crypto
  build-depends:
@@ -403,7 +442,11 @@ executable ntf-server
      apps/ntf-server
  default-extensions:
      StrictData
-  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=incomplete-uni-patterns -Werror=missing-methods -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -O2 -threaded -rtsopts
+  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=incomplete-uni-patterns -Werror=missing-methods -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -threaded -rtsopts
+  if flag(optimize)
+    ghc-options: -O2
+  else
+    ghc-options: -O0
  build-depends:
      base
    , simple-logger
@@ -425,7 +468,11 @@ executable smp-server
      apps/common
  default-extensions:
      StrictData
-  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=incomplete-uni-patterns -Werror=missing-methods -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -O2 -threaded -rtsopts
+  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=incomplete-uni-patterns -Werror=missing-methods -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -threaded -rtsopts
+  if flag(optimize)
+    ghc-options: -O2
+  else
+    ghc-options: -O0
  build-depends:
      base
    , bytestring
@@ -445,7 +492,11 @@ executable xftp
      apps/xftp
  default-extensions:
      StrictData
-  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=incomplete-uni-patterns -Werror=missing-methods -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -O2 -threaded -rtsopts
+  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=incomplete-uni-patterns -Werror=missing-methods -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -threaded -rtsopts
+  if flag(optimize)
+    ghc-options: -O2
+  else
+    ghc-options: -O0
  build-depends:
      base
    , simplexmq
@@ -464,7 +515,11 @@ executable xftp-server
      apps/common
  default-extensions:
      StrictData
-  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=incomplete-uni-patterns -Werror=missing-methods -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -O2 -threaded -rtsopts
+  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=incomplete-uni-patterns -Werror=missing-methods -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -threaded -rtsopts
+  if flag(optimize)
+    ghc-options: -O2
+  else
+    ghc-options: -O0
  build-depends:
      base
    , bytestring
@@ -540,7 +595,11 @@ test-suite simplexmq-test
  default-extensions:
      StrictData
  -- add -fhpc to ghc-options to run tests with coverage
-  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=incomplete-uni-patterns -Werror=missing-methods -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -O2 -threaded -rtsopts -with-rtsopts=-A64M -with-rtsopts=-N1
+  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=incomplete-uni-patterns -Werror=missing-methods -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -threaded -rtsopts -with-rtsopts=-A64M -with-rtsopts=-N1
+  if flag(optimize)
+    ghc-options: -O2
+  else
+    ghc-options: -O0
  build-depends:
      base
    , aeson
@@ -46,6 +46,7 @@ import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers
 import Simplex.Messaging.Protocol (XFTPServer)
+import Simplex.Messaging.Util (safeDecodeUtf8, (<$$>))
 import System.FilePath ((</>))

 type RcvFileId = ByteString -- Agent entity ID
@@ -65,7 +66,8 @@ data FileHeader = FileHeader
 instance Encoding FileHeader where
  smpEncode FileHeader {fileName, fileExtra} = smpEncode (fileName, fileExtra)
  smpP = do
-    (fileName, fileExtra) <- smpP
+    fileName <- safeDecodeUtf8 <$> smpP
+    fileExtra <- safeDecodeUtf8 <$$> smpP
    pure FileHeader {fileName, fileExtra}

 type DBRcvFileId = Int64
@@ -122,6 +122,10 @@ module Simplex.Messaging.Agent.Protocol
    OwnerId,
    ConnectionLink (..),
    AConnectionLink (..),
+    SimplexNameInfo (..),
+    SimplexNameDomain (..),
+    SimplexTLD (..),
+    SimplexNameType (..),
    ConnShortLink (..),
    AConnShortLink (..),
    CreatedConnLink (..),
@@ -141,6 +145,8 @@ module Simplex.Messaging.Agent.Protocol
    connReqUriP',
    simplexConnReqUri,
    simplexShortLink,
+    fullDomainName,
+    shortNameInfoStr,
    AgentErrorType (..),
    CommandErrorType (..),
    ConnectionErrorType (..),
@@ -192,10 +198,11 @@ import qualified Data.Aeson.TH as J
 import qualified Data.Aeson.Types as JT
 import Data.Attoparsec.ByteString.Char8 (Parser)
 import qualified Data.Attoparsec.ByteString.Char8 as A
+import qualified Data.Attoparsec.Text as AT
 import qualified Data.ByteString.Base64.URL as B64
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
-import Data.Char (toLower, toUpper)
+import Data.Char (isAlpha, isDigit, toLower, toUpper)
 import Data.Foldable (find)
 import Data.Functor (($>))
 import Data.Int (Int64)
@@ -1514,6 +1521,75 @@ instance (Typeable c, ConnectionModeI c) => FromField (ConnShortLink c) where fr

 data ContactConnType = CCTContact | CCTChannel | CCTGroup | CCTRelay deriving (Eq, Show)

+data SimplexNameInfo = SimplexNameInfo
+  { nameType :: SimplexNameType,
+    nameDomain :: SimplexNameDomain
+  }
+  deriving (Eq, Show)
+
+data SimplexNameDomain = SimplexNameDomain
+  { nameTLD :: SimplexTLD,
+    domain :: Text,
+    subDomain :: [Text] -- parent to child: ["b", "a"] for a.b.domain.simplex
+  }
+  deriving (Eq, Show)
+
+data SimplexTLD = TLDSimplex | TLDTesting | TLDWeb
+  deriving (Eq, Show)
+
+data SimplexNameType = NTPublicGroup | NTContact
+  deriving (Eq, Show)
+
+instance StrEncoding SimplexNameType where
+  strEncode = \case
+    NTPublicGroup -> "#"
+    NTContact -> "@"
+  strP = A.char '#' $> NTPublicGroup <|> A.char '@' $> NTContact
+
+nameLabelP :: AT.Parser Text
+nameLabelP = T.intercalate "-" <$> AT.takeWhile1 (\c -> isNameLetter c || isDigit c) `AT.sepBy1` AT.char '-'
+  where
+    isNameLetter c = isAlpha c && not (c >= '\x00c0' && c <= '\x024f')
+
+instance StrEncoding SimplexNameInfo where
+  strEncode SimplexNameInfo {nameType, nameDomain} =
+    "simplex:/name" <> strEncode nameType <> strEncode nameDomain
+  strP = optional "simplex:/name" *> ((strP >>= infoP) <|> infoP NTPublicGroup)
+    where
+      infoP NTPublicGroup = SimplexNameInfo NTPublicGroup <$> (strP <|> bareName)
+      infoP NTContact = SimplexNameInfo NTContact <$> strP
+      bareName = parseBare . safeDecodeUtf8 <$?> A.takeWhile1 (not . A.isSpace)
+      parseBare s = (\name -> SimplexNameDomain TLDSimplex name []) <$> AT.parseOnly (nameLabelP <* AT.endOfInput) s
+
+instance StrEncoding SimplexNameDomain where
+  strEncode = encodeUtf8 . fullDomainName
+  strP = parseDomain . safeDecodeUtf8 <$?> A.takeWhile1 (not . A.isSpace)
+    where
+      parseDomain s = AT.parseOnly (nameLabelP `AT.sepBy1` AT.char '.' <* AT.endOfInput) s >>= mkDomain
+      mkDomain labels = case reverse labels of
+        [] -> Left "empty name"
+        [_] -> Left "domain requires TLD"
+        "simplex" : name : sub -> Right $ SimplexNameDomain TLDSimplex name sub
+        "testing" : name : sub -> Right $ SimplexNameDomain TLDTesting name sub
+        _ -> Right $ SimplexNameDomain TLDWeb (T.intercalate "." labels) []
+
+fullDomainName :: SimplexNameDomain -> Text
+fullDomainName SimplexNameDomain {nameTLD, domain, subDomain} = T.intercalate "." (reverse subDomain ++ [domain] ++ tld')
+  where
+    tld' = case nameTLD of
+      TLDSimplex -> ["simplex"]
+      TLDTesting -> ["testing"]
+      TLDWeb -> []
+
+shortNameInfoStr :: SimplexNameInfo -> Text
+shortNameInfoStr = \case
+  SimplexNameInfo {nameType = NTPublicGroup, nameDomain = SimplexNameDomain {nameTLD = TLDSimplex, domain, subDomain = []}} -> "#" <> domain
+  info -> pfx <> fullDomainName (nameDomain info)
+    where
+      pfx = case nameType info of
+        NTPublicGroup -> "#"
+        NTContact -> "@"
+
 data AConnShortLink = forall m. ConnectionModeI m => ACSL (SConnectionMode m) (ConnShortLink m)

 instance Eq AConnShortLink where
@@ -2201,3 +2277,11 @@ instance FromJSON ACreatedConnLink where
 instance ToJSON ACreatedConnLink where
  toEncoding (ACCL _ ccLink) = toEncoding ccLink
  toJSON (ACCL _ ccLink) = toJSON ccLink
+
+$(J.deriveJSON (enumJSON $ dropPrefix "TLD") ''SimplexTLD)
+
+$(J.deriveJSON (enumJSON $ dropPrefix "NT") ''SimplexNameType)
+
+$(J.deriveJSON defaultJSON ''SimplexNameDomain)
+
+$(J.deriveJSON defaultJSON ''SimplexNameInfo)
@@ -0,0 +1,300 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+-- | FFI bindings to libbbs (BBS+ signatures over BLS12-381, SHA-256 suite).
+-- Values parsed from untrusted input are length-validated; see FixedBS and the
+-- BBSProof StrEncoding instance.
+module Simplex.Messaging.Crypto.BBS
+  ( BBSSecretKey (..),
+    BBSPublicKey (..),
+    BBSKeyPair,
+    BBSSignature (..),
+    BBSProof (..),
+    BBSHeader (..),
+    BBSPresHeader (..),
+    bbsKeyGen,
+    bbsPublicKey,
+    bbsSign,
+    bbsVerify,
+    bbsProofGen,
+    bbsProofVerify,
+  ) where
+
+import Data.Aeson (FromJSON, ToJSON)
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Unsafe as BU
+import Data.Proxy (Proxy (..))
+import Foreign
+import Foreign.C
+import GHC.TypeLits (KnownNat, KnownSymbol, Nat, Symbol, natVal, symbolVal)
+import Simplex.Messaging.Encoding.String
+import System.IO.Unsafe (unsafePerformIO)
+
+-- Note: the data constructors below are unchecked escape hatches for trusted,
+-- internally-produced values (e.g. keygen output). Any value parsed from
+-- untrusted input (StrEncoding / FromJSON) is length-validated — see FixedBS
+-- and the BBSProof StrEncoding instance.
+
+newtype BBSSecretKey = BBSSecretKey ByteString
+  deriving newtype (Eq, Show)
+  deriving (StrEncoding) via (FixedBS "BBSSecretKey" 32)
+  deriving (ToJSON, FromJSON) via (StrJSON "BBSSecretKey" BBSSecretKey)
+
+newtype BBSPublicKey = BBSPublicKey ByteString
+  deriving newtype (Eq, Show)
+  deriving (StrEncoding) via (FixedBS "BBSPublicKey" 96)
+  deriving (ToJSON, FromJSON) via (StrJSON "BBSPublicKey" BBSPublicKey)
+
+type BBSKeyPair = (BBSPublicKey, BBSSecretKey)
+
+newtype BBSSignature = BBSSignature ByteString
+  deriving newtype (Eq, Show)
+  deriving (StrEncoding) via (FixedBS "BBSSignature" 80)
+  deriving (ToJSON, FromJSON) via (StrJSON "BBSSignature" BBSSignature)
+
+newtype BBSProof = BBSProof ByteString
+  deriving newtype (Eq, Show)
+  deriving (ToJSON, FromJSON) via (StrJSON "BBSProof" BBSProof)
+
+newtype BBSHeader = BBSHeader ByteString
+  deriving newtype (Eq, Show, StrEncoding)
+  deriving (ToJSON, FromJSON) via (StrJSON "BBSHeader" BBSHeader)
+
+newtype BBSPresHeader = BBSPresHeader ByteString
+  deriving newtype (Eq, Show, StrEncoding)
+  deriving (ToJSON, FromJSON) via (StrJSON "BBSPresHeader" BBSPresHeader)
+
+-- | A ByteString validated to be exactly @n@ bytes when parsed via StrEncoding
+-- (and the JSON derived from it). Local to BBS, where every key/signature is a
+-- fixed size; @name@ appears in the decode error only.
+newtype FixedBS (name :: Symbol) (n :: Nat) = FixedBS ByteString
+
+instance forall name n. (KnownSymbol name, KnownNat n) => StrEncoding (FixedBS name n) where
+  strEncode (FixedBS bs) = strEncode bs
+  strP = do
+    bs <- base64urlP
+    let n = fromIntegral (natVal (Proxy :: Proxy n))
+    if B.length bs == n
+      then pure (FixedBS bs)
+      else fail $ symbolVal (Proxy :: Proxy name) <> ": expected " <> show n <> " bytes, got " <> show (B.length bs)
+
+-- Constants
+
+bbsSkLen, bbsPkLen, bbsSigLen, bbsProofBaseLen, bbsProofUdElemLen :: Int
+bbsSkLen = 32
+bbsPkLen = 96
+bbsSigLen = 80
+bbsProofBaseLen = 272
+bbsProofUdElemLen = 32
+
+bbsProofLen :: Int -> Int
+bbsProofLen numUndisclosed = bbsProofBaseLen + numUndisclosed * bbsProofUdElemLen
+
+-- | A proof is @bbsProofBaseLen + 32 * numUndisclosed@ bytes; reject anything else.
+instance StrEncoding BBSProof where
+  strEncode (BBSProof bs) = strEncode bs
+  strP = do
+    bs <- base64urlP
+    let len = B.length bs
+    if len >= bbsProofBaseLen && (len - bbsProofBaseLen) `mod` bbsProofUdElemLen == 0
+      then pure (BBSProof bs)
+      else fail $ "BBS: invalid proof length " <> show len
+
+-- FFI
+
+data BBS_Ciphersuite
+
+foreign import ccall "bbs_keygen_full"
+  c_bbs_keygen_full :: Ptr BBS_Ciphersuite -> Ptr Word8 -> Ptr Word8 -> IO CInt
+
+foreign import ccall "bbs_sk_to_pk"
+  c_bbs_sk_to_pk :: Ptr BBS_Ciphersuite -> Ptr Word8 -> Ptr Word8 -> IO CInt
+
+foreign import ccall "bbs_sign"
+  c_bbs_sign ::
+    Ptr BBS_Ciphersuite ->
+    Ptr Word8 -> Ptr Word8 -> Ptr Word8 ->
+    Ptr Word8 -> CSize ->
+    CSize -> Ptr (Ptr Word8) -> Ptr CSize ->
+    IO CInt
+
+foreign import ccall "bbs_verify"
+  c_bbs_verify ::
+    Ptr BBS_Ciphersuite ->
+    Ptr Word8 -> Ptr Word8 ->
+    Ptr Word8 -> CSize ->
+    CSize -> Ptr (Ptr Word8) -> Ptr CSize ->
+    IO CInt
+
+foreign import ccall "bbs_proof_gen"
+  c_bbs_proof_gen ::
+    Ptr BBS_Ciphersuite ->
+    Ptr Word8 -> Ptr Word8 -> Ptr Word8 ->
+    Ptr Word8 -> CSize ->
+    Ptr Word8 -> CSize ->
+    Ptr CSize -> CSize ->
+    CSize -> Ptr (Ptr Word8) -> Ptr CSize ->
+    IO CInt
+
+foreign import ccall "bbs_proof_verify"
+  c_bbs_proof_verify ::
+    Ptr BBS_Ciphersuite ->
+    Ptr Word8 ->
+    Ptr Word8 -> CSize ->
+    Ptr Word8 -> CSize ->
+    Ptr Word8 -> CSize ->
+    Ptr CSize -> CSize ->
+    CSize -> Ptr (Ptr Word8) -> Ptr CSize ->
+    IO CInt
+
+foreign import ccall "&bbs_sha256_ciphersuite"
+  c_bbs_sha256_ciphersuite :: Ptr (Ptr BBS_Ciphersuite)
+
+-- The ciphersuite is a static const pointer in libbbs; read it once.
+ciphersuite :: Ptr BBS_Ciphersuite
+ciphersuite = unsafePerformIO $ peek c_bbs_sha256_ciphersuite
+{-# NOINLINE ciphersuite #-}
+
+-- Helpers
+
+withBS :: ByteString -> (Ptr Word8 -> CSize -> IO a) -> IO a
+withBS bs f = BU.unsafeUseAsCStringLen bs $ \(p, l) -> f (castPtr p) (fromIntegral l)
+
+packPtr :: Ptr Word8 -> Int -> IO ByteString
+packPtr ptr len = B.packCStringLen (castPtr ptr, len)
+
+-- Marshals a list of messages into parallel pointer/length arrays. Each
+-- ByteString is held alive (via nested unsafeUseAsCStringLen) until @f@ returns,
+-- so the C callee never sees a pointer to freed memory.
+withMessages :: [ByteString] -> (Ptr (Ptr Word8) -> Ptr CSize -> CSize -> IO a) -> IO a
+withMessages msgs f = go msgs []
+  where
+    go [] acc =
+      let cstrs = reverse acc
+       in withArray (map fst cstrs) $ \msgsPtr ->
+            withArray (map snd cstrs) $ \lensPtr ->
+              f msgsPtr lensPtr (fromIntegral $ length cstrs)
+    go (m : ms) acc =
+      BU.unsafeUseAsCStringLen m $ \(p, l) ->
+        go ms ((castPtr p :: Ptr Word8, fromIntegral l :: CSize) : acc)
+
+withIndexes :: [Int] -> (Ptr CSize -> CSize -> IO a) -> IO a
+withIndexes idxs f =
+  withArrayLen (map fromIntegral idxs :: [CSize]) $ \n ptr -> f ptr (fromIntegral n)
+
+-- libbbs expects disclosed indexes strictly ascending and in [0, total). This
+-- both matches the spec and guarantees the output-buffer size we compute matches
+-- what libbbs writes (no out-of-bounds write from a bad index list).
+ascendingInRange :: [Int] -> Int -> Bool
+ascendingInRange idxs total =
+  all (\i -> i >= 0 && i < total) idxs && and (zipWith (<) idxs (drop 1 idxs))
+
+-- Public API
+
+bbsKeyGen :: IO (Either String BBSKeyPair)
+bbsKeyGen =
+  allocaBytes bbsSkLen $ \skPtr ->
+    allocaBytes bbsPkLen $ \pkPtr -> do
+      rc <- c_bbs_keygen_full ciphersuite skPtr pkPtr
+      if rc /= 0
+        then pure $ Left "bbsKeyGen failed"
+        else do
+          sk <- packPtr skPtr bbsSkLen
+          pk <- packPtr pkPtr bbsPkLen
+          pure $ Right (BBSPublicKey pk, BBSSecretKey sk)
+
+bbsPublicKey :: BBSSecretKey -> IO (Either String BBSPublicKey)
+bbsPublicKey (BBSSecretKey sk) =
+  allocaBytes bbsPkLen $ \pkPtr ->
+    withBS sk $ \skPtr _ -> do
+      rc <- c_bbs_sk_to_pk ciphersuite skPtr pkPtr
+      if rc /= 0
+        then pure $ Left "bbsPublicKey failed"
+        else Right . BBSPublicKey <$> packPtr pkPtr bbsPkLen
+
+bbsSign ::
+  BBSSecretKey ->
+  BBSHeader ->
+  [ByteString] ->
+  IO (Either String BBSSignature)
+bbsSign secret@(BBSSecretKey sk) (BBSHeader header) msgs =
+  bbsPublicKey secret >>= either (pure . Left) sign'
+  where
+    sign' (BBSPublicKey pk) =
+      allocaBytes bbsSigLen $ \sigPtr ->
+        withBS sk $ \skPtr _ ->
+          withBS pk $ \pkPtr _ ->
+            withBS header $ \hdrPtr hdrLen ->
+              withMessages msgs $ \msgsPtr lensPtr n -> do
+                rc <- c_bbs_sign ciphersuite skPtr pkPtr sigPtr hdrPtr hdrLen n msgsPtr lensPtr
+                if rc /= 0
+                  then pure $ Left "bbsSign failed"
+                  else Right . BBSSignature <$> packPtr sigPtr bbsSigLen
+
+bbsVerify ::
+  BBSPublicKey ->
+  BBSSignature ->
+  BBSHeader ->
+  [ByteString] ->
+  IO Bool
+bbsVerify (BBSPublicKey pk) (BBSSignature sig) (BBSHeader header) msgs =
+  withBS pk $ \pkPtr _ ->
+    withBS sig $ \sigPtr _ ->
+      withBS header $ \hdrPtr hdrLen ->
+        withMessages msgs $ \msgsPtr lensPtr n -> do
+          rc <- c_bbs_verify ciphersuite pkPtr sigPtr hdrPtr hdrLen n msgsPtr lensPtr
+          pure (rc == 0)
+
+bbsProofGen ::
+  BBSPublicKey ->
+  BBSSignature ->
+  BBSHeader ->
+  BBSPresHeader ->
+  [Int] ->
+  [ByteString] ->
+  IO (Either String BBSProof)
+bbsProofGen (BBSPublicKey pk) (BBSSignature sig) (BBSHeader header) (BBSPresHeader ph) disclosedIdxs msgs
+  | not (ascendingInRange disclosedIdxs (length msgs)) = pure $ Left "bbsProofGen: invalid disclosed indexes"
+  | otherwise =
+  allocaBytes proofSz $ \proofPtr ->
+    withBS pk $ \pkPtr _ ->
+      withBS sig $ \sigPtr _ ->
+        withBS header $ \hdrPtr hdrLen ->
+          withBS ph $ \phPtr phLen ->
+            withIndexes disclosedIdxs $ \idxsPtr idxsLen ->
+              withMessages msgs $ \msgsPtr lensPtr n -> do
+                rc <- c_bbs_proof_gen ciphersuite pkPtr sigPtr proofPtr hdrPtr hdrLen phPtr phLen idxsPtr idxsLen n msgsPtr lensPtr
+                if rc /= 0
+                  then pure $ Left "bbsProofGen failed"
+                  else Right . BBSProof <$> packPtr proofPtr proofSz
+  where
+    numUndisclosed = length msgs - length disclosedIdxs
+    proofSz = bbsProofLen numUndisclosed
+
+bbsProofVerify ::
+  BBSPublicKey ->
+  BBSProof ->
+  BBSHeader ->
+  BBSPresHeader ->
+  [Int] ->
+  Int ->
+  [ByteString] ->
+  IO Bool
+bbsProofVerify (BBSPublicKey pk) (BBSProof proof) (BBSHeader header) (BBSPresHeader ph) disclosedIdxs numMessages disclosedMsgs
+  | length disclosedIdxs /= length disclosedMsgs = pure False
+  | not (ascendingInRange disclosedIdxs numMessages) = pure False
+  | otherwise =
+  withBS pk $ \pkPtr _ ->
+    withBS proof $ \proofPtr proofLen ->
+      withBS header $ \hdrPtr hdrLen ->
+        withBS ph $ \phPtr phLen ->
+          withIndexes disclosedIdxs $ \idxsPtr idxsLen ->
+            withMessages disclosedMsgs $ \msgsPtr lensPtr _ -> do
+              rc <- c_bbs_proof_verify ciphersuite pkPtr proofPtr proofLen hdrPtr hdrLen phPtr phLen idxsPtr idxsLen (fromIntegral numMessages) msgsPtr lensPtr
+              pure (rc == 0)
@@ -1,10 +1,14 @@
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}

 module Simplex.Messaging.Encoding.String
  ( TextEncoding (..),
    StrEncoding (..),
    Str (..),
+    StrJSON (..),
    strP_,
    _strP,
    strToJSON,
@@ -34,6 +38,7 @@ import Data.Int (Int64)
 import Data.IntSet (IntSet)
 import qualified Data.IntSet as IS
 import qualified Data.List.NonEmpty as L
+import Data.Proxy (Proxy (..))
 import Data.Set (Set)
 import qualified Data.Set as S
 import Data.Text (Text)
@@ -44,6 +49,7 @@ import Data.Time.Format.ISO8601
 import Data.Word (Word16, Word32)
 import qualified Data.X509 as X
 import qualified Data.X509.Validation as XV
+import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Parsers (parseAll)
 import Simplex.Messaging.Util (bshow, safeDecodeUtf8, (<$?>))
@@ -247,3 +253,20 @@ textToEncoding = JE.text . textEncode

 textParseJSON :: TextEncoding a => String -> J.Value -> JT.Parser a
 textParseJSON name = J.withText name $ maybe (fail name) pure . textDecode
+
+-- | Derives ToJSON/FromJSON from the wrapped type's own StrEncoding (a base64url
+-- string), so any validation that StrEncoding performs (e.g. length) also applies
+-- to JSON parsing. The @name@ symbol is the parse error label. The type parameter
+-- @a@ is essential: it makes parseJSON resolve at the wrapped type rather than at
+-- ByteString. Use via DerivingVia, e.g.:
+--
+-- > newtype Key = Key ByteString
+-- >   deriving (ToJSON, FromJSON) via (StrJSON "Key" Key)
+newtype StrJSON (name :: Symbol) a = StrJSON a
+
+instance StrEncoding a => ToJSON (StrJSON name a) where
+  toJSON (StrJSON a) = strToJSON a
+  toEncoding (StrJSON a) = strToJEncoding a
+
+instance forall name a. (KnownSymbol name, StrEncoding a) => FromJSON (StrJSON name a) where
+  parseJSON = fmap StrJSON . strParseJSON (symbolVal (Proxy :: Proxy name))
@@ -53,6 +53,7 @@ import Data.Time.Format.ISO8601 (iso8601Show)
 import GHC.IORef (atomicSwapIORef)
 import GHC.Stats (getRTSStats)
 import Network.Socket (ServiceName, Socket, socketToHandle)
+import Numeric.Natural (Natural)
 import Simplex.Messaging.Client (ProtocolClientError (..), SMPClientError, ServerTransmission (..))
 import Simplex.Messaging.Client.Agent
 import qualified Simplex.Messaging.Crypto as C
@@ -85,7 +86,7 @@ import System.Exit (exitFailure, exitSuccess)
 import System.IO (BufferMode (..), hClose, hPrint, hPutStrLn, hSetBuffering, hSetNewlineMode, universalNewlineMode)
 import System.Mem.Weak (deRefWeak)
 import System.Timeout (timeout)
-import UnliftIO (IOMode (..), UnliftIO, askUnliftIO, race_, unliftIO, withFile)
+import UnliftIO (IOMode (..), UnliftIO (..), askUnliftIO, race_, unliftIO, withFile)
 import UnliftIO.Concurrent (forkIO, killThread, mkWeakThreadId)
 import UnliftIO.Directory (doesFileExist, renameFile)
 import UnliftIO.Exception
@@ -116,7 +117,6 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg, startOptions}
  void $ forkIO $ resubscribe s
  raceAny_
    ( ntfSubscriber s
-        : ntfPush ps
        : periodicNtfsThread ps
        : map runServer transports
          <> serverStatsThread_ cfg
@@ -147,12 +147,17 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg, startOptions}
      saveServer
      NtfSubscriber {smpSubscribers, smpAgent} <- asks subscriber
      liftIO $ readTVarIO smpSubscribers >>= mapM_ stopSubscriber
+      NtfPushServer {pushWorkers} <- asks pushServer
+      liftIO $ readTVarIO pushWorkers >>= mapM_ stopPushWorker
      liftIO $ closeSMPClientAgent smpAgent
      logNote "Server stopped"
      where
        stopSubscriber v =
          atomically (tryReadTMVar $ sessionVar v)
            >>= mapM (deRefWeak . subThreadId >=> mapM_ killThread)
+        stopPushWorker v =
+          atomically (tryReadTMVar $ sessionVar v)
+            >>= mapM (deRefWeak . workerThreadId >=> mapM_ killThread)

    saveServer :: M ()
    saveServer = asks store >>= liftIO . closeNtfDbStore >> saveServerStats
@@ -257,7 +262,7 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg, startOptions}
      let threadsCount = 0
 #endif
      let NtfSubscriber {smpSubscribers, smpAgent = a} = subscriber
-          NtfPushServer {pushQ} = pushServer
+          NtfPushServer {pushWorkers} = pushServer
          SMPClientAgent {smpClients, smpSessions, smpSubWorkers} = a
      srvSubscribers <- getSMPWorkerMetrics a smpSubscribers
      srvClients <- getSMPWorkerMetrics a smpClients
@@ -267,7 +272,7 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg, startOptions}
      ntfPendingServiceSubs <- getSMPServiceSubMetrics a pendingServiceSubs snd
      ntfPendingQueueSubs <- getSMPSubMetrics a pendingQueueSubs
      smpSessionCount <- M.size <$> readTVarIO smpSessions
-      apnsPushQLength <- atomically $ lengthTBQueue pushQ
+      apnsPushQLength <- pushWorkersQLength pushWorkers
      pure
        NtfRealTimeMetrics
          { threadsCount,
@@ -526,35 +531,36 @@ ntfSubscriber NtfSubscriber {smpAgent = ca@SMPClientAgent {msgQ, agentQ}} =
  where
    receiveSMP = do
      st <- asks store
-      NtfPushServer {pushQ} <- asks pushServer
+      ps <- asks pushServer
      stats <- asks serverStats
-      liftIO $ forever $ do
+      forever $ do
        ((_, srv@(SMPServer (h :| _) _ _), _), _thVersion, sessionId, ts) <- atomically $ readTBQueue msgQ
-        forM ts $ \(ntfId, t) -> case t of
+        forM_ ts $ \(ntfId, t) -> case t of
          STUnexpectedError e -> logError $ "SMP client unexpected error: " <> tshow e -- uncorrelated response, should not happen
          STResponse {} -> pure () -- it was already reported as timeout error
          STEvent msgOrErr -> do
            let smpQueue = SMPQueueNtf srv ntfId
            case msgOrErr of
              Right (SMP.NMSG nmsgNonce encNMsgMeta) -> do
-                ntfTs <- getSystemTime
-                updatePeriodStats (activeSubs stats) ntfId
+                ntfTs <- liftIO getSystemTime
+                liftIO $ updatePeriodStats (activeSubs stats) ntfId
                let newNtf = PNMessageData {smpQueue, ntfTs, nmsgNonce, encNMsgMeta}
-                    srvHost_ = if isOwnServer ca srv then Just (safeDecodeUtf8 $ strEncode h) else Nothing
-                addTokenLastNtf st newNtf >>= \case
+                    srvHost = safeDecodeUtf8 $ strEncode h
+                    isOwn = isOwnServer ca srv
+                liftIO (addTokenLastNtf st newNtf) >>= \case
                  Right (tkn, lastNtfs) -> do
-                    atomically $ writeTBQueue pushQ (srvHost_, tkn, PNMessage lastNtfs)
-                    incNtfStat_ stats ntfReceived
-                    mapM_ (`incServerStat` ntfReceivedOwn stats) srvHost_
-                  Left AUTH -> do
+                    pushNotification ps (Just srvHost) isOwn tkn $ PNMessage lastNtfs
+                    liftIO $ incNtfStat_ stats ntfReceived
+                    when isOwn $ liftIO $ incServerStat srvHost (ntfReceivedOwn stats)
+                  Left AUTH -> liftIO $ do
                    incNtfStat_ stats ntfReceivedAuth
-                    mapM_ (`incServerStat` ntfReceivedAuthOwn stats) srvHost_
+                    when isOwn $ incServerStat srvHost (ntfReceivedAuthOwn stats)
                  Left _ -> pure ()
              Right SMP.END ->
                whenM (atomically $ activeClientSession' ca sessionId srv) $
-                  void $ updateSrvSubStatus st smpQueue NSEnd
+                  void $ liftIO $ updateSrvSubStatus st smpQueue NSEnd
              Right SMP.DELD ->
-                void $ updateSrvSubStatus st smpQueue NSDeleted
+                void $ liftIO $ updateSrvSubStatus st smpQueue NSDeleted
              Right (SMP.ERR e) -> logError $ "SMP server error: " <> tshow e
              Right _ -> logError "SMP server unexpected response"
              Left e -> logError $ "SMP client error: " <> tshow e
@@ -632,9 +638,25 @@ logSubStatus srv event n updated =
 showServer' :: SMPServer -> Text
 showServer' = decodeLatin1 . strEncode . host

-ntfPush :: NtfPushServer -> M ()
-ntfPush s@NtfPushServer {pushQ} = forever $ do
-  (srvHost_, tkn@NtfTknRec {ntfTknId, token = t@(DeviceToken pp _), tknStatus}, ntf) <- atomically (readTBQueue pushQ)
+pushNotification :: NtfPushServer -> Maybe T.Text -> OwnServer -> NtfTknRec -> PushNotification -> M ()
+pushNotification s srvHost_ isOwn tkn@NtfTknRec {token = DeviceToken pp _} ntf = do
+  q <- getOrCreatePushWorker s (srvHost_, pp) isOwn
+  atomically $ writeTBQueue q (tkn, ntf)
+
+getOrCreatePushWorker :: NtfPushServer -> (Maybe T.Text, PushProvider) -> OwnServer -> M (TBQueue (NtfTknRec, PushNotification))
+getOrCreatePushWorker s@NtfPushServer {pushWorkers, pushWorkerSeq, pushQSize} key@(srvHost_, _) isOwn = do
+  ts <- liftIO getCurrentTime
+  atomically (getSessVar pushWorkerSeq key pushWorkers ts) >>= \case
+    Left v -> do
+      q <- liftIO $ newTBQueueIO pushQSize
+      tId <- mkWeakThreadId =<< forkIO (runPushWorker s srvHost_ isOwn q)
+      atomically $ putTMVar (sessionVar v) PushWorker {workerQ = q, workerThreadId = tId}
+      pure q
+    Right v -> workerQ <$> atomically (readTMVar $ sessionVar v)
+
+runPushWorker :: NtfPushServer -> Maybe T.Text -> OwnServer -> TBQueue (NtfTknRec, PushNotification) -> M ()
+runPushWorker s srvHost_ isOwn q = forever $ do
+  (tkn@NtfTknRec {ntfTknId, token = t@(DeviceToken pp _), tknStatus}, ntf) <- atomically (readTBQueue q)
  liftIO $ logDebug $ "sending push notification to " <> T.pack (show pp)
  st <- asks store
  case ntf of
@@ -644,7 +666,7 @@ ntfPush s@NtfPushServer {pushQ} = forever $ do
          void $ liftIO $ setTknStatusConfirmed st tkn
          incNtfStatT t ntfVrfDelivered
        Left _ -> incNtfStatT t ntfVrfFailed
-    PNCheckMessages -> do
+    PNCheckMessages ->
      liftIO (deliverNotification st pp tkn ntf) >>= \case
        Right _ -> do
          void $ liftIO $ updateTokenCronSentAt st ntfTknId . systemSeconds =<< getSystemTime
@@ -656,24 +678,23 @@ ntfPush s@NtfPushServer {pushQ} = forever $ do
      liftIO (deliverNotification st pp tkn ntf) >>= \case
        Left _ -> do
          incNtfStatT t ntfFailed
-          liftIO $ mapM_ (`incServerStat` ntfFailedOwn stats) srvHost_
+          when isOwn $ liftIO $ mapM_ (`incServerStat` ntfFailedOwn stats) srvHost_
        Right () -> do
          incNtfStatT t ntfDelivered
-          liftIO $ mapM_ (`incServerStat` ntfDeliveredOwn stats) srvHost_
-
+          when isOwn $ liftIO $ mapM_ (`incServerStat` ntfDeliveredOwn stats) srvHost_
  where
    checkActiveTkn :: NtfTknStatus -> M () -> M ()
    checkActiveTkn status action
      | status == NTActive = action
      | otherwise = liftIO $ logError "bad notification token status"
    deliverNotification :: NtfPostgresStore -> PushProvider -> NtfTknRec -> PushNotification -> IO (Either PushProviderError ())
-    deliverNotification st pp tkn@NtfTknRec {ntfTknId} ntf = do
-      deliver <- getPushClient s pp
-      runExceptT (deliver tkn ntf) >>= \case
+    deliverNotification st pp tkn@NtfTknRec {ntfTknId} ntf' = do
+      (deliver, clientVar) <- getPushClient s pp
+      runExceptT (deliver tkn ntf') >>= \case
        Right _ -> pure $ Right ()
        Left e -> case e of
-          PPConnection _ -> retryDeliver
-          PPRetryLater -> retryDeliver
+          PPConnection ce -> retryDeliver clientVar $ "connection " <> tshow ce
+          PPRetryLater r -> retryDeliver clientVar r
          PPCryptoError _ -> err e
          PPResponseError {} -> err e
          PPTokenInvalid r -> do
@@ -681,10 +702,12 @@ ntfPush s@NtfPushServer {pushQ} = forever $ do
            err e
          PPPermanentError -> err e
      where
-        retryDeliver :: IO (Either PushProviderError ())
-        retryDeliver = do
-          deliver <- newPushClient s pp
-          runExceptT (deliver tkn ntf) >>= \case
+        retryDeliver :: PushClientVar -> Text -> IO (Either PushProviderError ())
+        retryDeliver oldVar reason = do
+          logWarn $ "retrying push (" <> tshow pp <> ", " <> tshow ntfTknId <> "): " <> reason
+          atomically $ removeSessVar oldVar pp (pushClients s)
+          (deliver, _) <- getPushClient s pp
+          runExceptT (deliver tkn ntf') >>= \case
            Right _ -> pure $ Right ()
            Left e -> case e of
              PPTokenInvalid r -> do
@@ -693,15 +716,26 @@ ntfPush s@NtfPushServer {pushQ} = forever $ do
              _ -> err e
        err e = logError ("Push provider error (" <> tshow pp <> ", " <> tshow ntfTknId <> "): " <> tshow e) $> Left e

+pushWorkersQLength :: TMap (Maybe T.Text, PushProvider) PushWorkerVar -> IO Natural
+pushWorkersQLength workers = do
+  ws <- readTVarIO workers
+  foldM addQLength 0 ws
+  where
+    addQLength acc v =
+      atomically (tryReadTMVar $ sessionVar v) >>= \case
+        Just PushWorker {workerQ} -> (acc +) <$> atomically (lengthTBQueue workerQ)
+        Nothing -> pure acc
+
 periodicNtfsThread :: NtfPushServer -> M ()
-periodicNtfsThread NtfPushServer {pushQ} = do
+periodicNtfsThread s = do
  st <- asks store
  ntfsInterval <- asks $ periodicNtfsInterval . config
  let interval = 1000000 * ntfsInterval
+  UnliftIO unlift <- askUnliftIO
  liftIO $ forever $ do
    threadDelay interval
    now <- systemSeconds <$> getSystemTime
-    cnt <- withPeriodicNtfTokens st now $ \tkn -> atomically $ writeTBQueue pushQ (Nothing, tkn, PNCheckMessages)
+    cnt <- withPeriodicNtfTokens st now $ \tkn -> unlift $ pushNotification s Nothing False tkn PNCheckMessages
    logNote $ "Scheduled periodic notifications: " <> tshow cnt

 runNtfClientTransport :: Transport c => THandleNTF c 'TServer -> M ()
@@ -791,7 +825,7 @@ verifyNtfTransmission st thAuth (tAuth, authorized, (corrId, entId, cmd)) = case
      e -> VRFailed e

 client :: NtfServerClient -> NtfSubscriber -> NtfPushServer -> M ()
-client NtfServerClient {rcvQ, sndQ} ns@NtfSubscriber {smpAgent = ca} NtfPushServer {pushQ} =
+client NtfServerClient {rcvQ, sndQ} ns@NtfSubscriber {smpAgent = ca} ps =
  forever $
    atomically (readTBQueue rcvQ)
      >>= mapM processCommand
@@ -808,7 +842,7 @@ client NtfServerClient {rcvQ, sndQ} ns@NtfSubscriber {smpAgent = ca} NtfPushServ
        ts <- liftIO $ getSystemDate
        let tkn = mkNtfTknRec tknId newTkn srvDhPrivKey dhSecret regCode ts
        withNtfStore (`addNtfToken` tkn) $ \_ -> do
-          atomically $ writeTBQueue pushQ (Nothing, tkn, PNVerification regCode)
+          pushNotification ps Nothing False tkn $ PNVerification regCode
          incNtfStatT token ntfVrfQueued
          incNtfStatT token tknCreated
          pure $ NRTknId tknId srvDhPubKey
@@ -824,7 +858,7 @@ client NtfServerClient {rcvQ, sndQ} ns@NtfSubscriber {smpAgent = ca} NtfPushServ
              | otherwise -> withNtfStore (\st -> updateTknStatus st tkn NTRegistered) $ \_ -> sendVerification
            where
              sendVerification = do
-                atomically $ writeTBQueue pushQ (Nothing, tkn, PNVerification tknRegCode)
+                pushNotification ps Nothing False tkn $ PNVerification tknRegCode
                incNtfStatT token ntfVrfQueued
                pure $ NRTknId ntfTknId $ C.publicKey tknDhPrivKey
          TVFY code -- this allows repeated verification for cases when client connection dropped before server response
@@ -842,7 +876,7 @@ client NtfServerClient {rcvQ, sndQ} ns@NtfSubscriber {smpAgent = ca} NtfPushServ
            regCode <- getRegCode
            let tkn' = tkn {token = token', tknStatus = NTRegistered, tknRegCode = regCode}
            withNtfStore (`replaceNtfToken` tkn') $ \_ -> do
-              atomically $ writeTBQueue pushQ (Nothing, tkn', PNVerification regCode)
+              pushNotification ps Nothing False tkn' $ PNVerification regCode
              incNtfStatT token ntfVrfQueued
              incNtfStatT token tknReplaced
              pure NROk
@@ -13,22 +13,27 @@ module Simplex.Messaging.Notifications.Server.Env
    SMPSubscriberVar,
    SMPSubscriber (..),
    NtfPushServer (..),
+    PushClientVar,
+    PushWorker (..),
+    PushWorkerVar,
    NtfRequest (..),
    NtfServerClient (..),
    defaultInactiveClientExpiration,
    newNtfServerEnv,
    newNtfSubscriber,
    newNtfPushServer,
-    newPushClient,
    getPushClient,
    newNtfServerClient,
  ) where

 import Control.Concurrent (ThreadId)
+import qualified Control.Exception as E
 import Control.Logger.Simple
 import Control.Monad
 import Crypto.Random
+import Data.Functor (($>))
 import Data.Int (Int64)
+import Simplex.Messaging.Agent.RetryInterval
 import Data.List.NonEmpty (NonEmpty)
 import qualified Data.Text as T
 import Data.Time.Clock (getCurrentTime)
@@ -58,6 +63,7 @@ import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport (ASrvTransport, SMPServiceRole (..), ServiceCredentials (..), THandleParams, TransportPeer (..))
 import Simplex.Messaging.Transport.Server (AddHTTP, ServerCredentials, TransportServerConfig, loadFingerprint, loadServerCredential)
+import Simplex.Messaging.Util (tshow)
 import System.Exit (exitFailure)
 import System.Mem.Weak (Weak)
 import UnliftIO.STM
@@ -163,28 +169,62 @@ data SMPSubscriber = SMPSubscriber
  }

 data NtfPushServer = NtfPushServer
-  { pushQ :: TBQueue (Maybe T.Text, NtfTknRec, PushNotification), -- Maybe Text is a hostname of "own" server
-    pushClients :: TMap PushProvider PushProviderClient,
+  { pushWorkers :: TMap (Maybe T.Text, PushProvider) PushWorkerVar,
+    pushWorkerSeq :: TVar Int,
+    pushQSize :: Natural,
+    pushClients :: TMap PushProvider PushClientVar,
+    pushClientSeq :: TVar Int,
    apnsConfig :: APNSPushClientConfig
  }

-newNtfPushServer :: Natural -> APNSPushClientConfig -> IO NtfPushServer
-newNtfPushServer qSize apnsConfig = do
-  pushQ <- newTBQueueIO qSize
-  pushClients <- TM.emptyIO
-  pure NtfPushServer {pushQ, pushClients, apnsConfig}
+data PushWorker = PushWorker
+  { workerQ :: TBQueue (NtfTknRec, PushNotification),
+    workerThreadId :: Weak ThreadId
+  }

-newPushClient :: NtfPushServer -> PushProvider -> IO PushProviderClient
-newPushClient NtfPushServer {apnsConfig, pushClients} pp = do
-  c <- case apnsProviderHost pp of
+type PushWorkerVar = SessionVar PushWorker
+
+-- The Either communicates client-creation failure from the winner to the waiters.
+type PushClientVar = SessionVar (Either E.SomeException PushProviderClient)
+
+newNtfPushServer :: Natural -> APNSPushClientConfig -> IO NtfPushServer
+newNtfPushServer pushQSize apnsConfig = do
+  pushWorkers <- TM.emptyIO
+  pushWorkerSeq <- newTVarIO 0
+  pushClients <- TM.emptyIO
+  pushClientSeq <- newTVarIO 0
+  pure NtfPushServer {pushWorkers, pushWorkerSeq, pushQSize, pushClients, pushClientSeq, apnsConfig}
+
+-- | Single-flight access to the per-provider push client with bounded retry.
+-- The returned PushClientVar is the handle retryDeliver passes to removeSessVar to evict
+-- this specific instance before re-fetching.
+getPushClient :: NtfPushServer -> PushProvider -> IO (PushProviderClient, PushClientVar)
+getPushClient s@NtfPushServer {apnsConfig = APNSPushClientConfig {reconnectInterval}} pp =
+  withRetryIntervalCount reconnectInterval $ \n _delay loop -> do
+    ts <- getCurrentTime
+    E.try (atomically (getSessVar (pushClientSeq s) pp (pushClients s) ts) >>= either (newPushClient s pp) waitForPushClient) >>= \case
+      Right result -> pure result
+      Left e
+        | n < 2 -> do
+            logError $ "getPushClient error (" <> tshow pp <> "): " <> tshow (e :: E.SomeException)
+            loop
+        | otherwise -> E.throwIO e
+
+newPushClient :: NtfPushServer -> PushProvider -> PushClientVar -> IO (PushProviderClient, PushClientVar)
+newPushClient NtfPushServer {pushClients, apnsConfig} pp v = do
+  r <- E.try $ case apnsProviderHost pp of
    Nothing -> pure $ \_ _ -> pure ()
    Just host -> apnsPushProviderClient <$> createAPNSPushClient host apnsConfig
-  atomically $ TM.insert pp c pushClients
-  pure c
+  atomically $ do
+    putTMVar (sessionVar v) r
+    case r of
+      Left _ -> removeSessVar v pp pushClients
+      Right _ -> pure ()
+  either E.throwIO (\c -> pure (c, v)) r

-getPushClient :: NtfPushServer -> PushProvider -> IO PushProviderClient
-getPushClient s@NtfPushServer {pushClients} pp =
-  TM.lookupIO pp pushClients >>= maybe (newPushClient s pp) pure
+waitForPushClient :: PushClientVar -> IO (PushProviderClient, PushClientVar)
+waitForPushClient v =
+  atomically (readTMVar $ sessionVar v) >>= either E.throwIO (\c -> pure (c, v))

 data NtfRequest
  = NtfReqNew CorrId ANewNtfEntity
@@ -23,7 +23,7 @@ module Simplex.Messaging.Notifications.Server.Push.APNS
    apnsPushProviderClient,
  ) where

-import Control.Exception (Exception)
+import Control.Exception (Exception, throwIO)
 import Control.Logger.Simple
 import Control.Monad
 import Control.Monad.Except
@@ -66,6 +66,7 @@ import qualified Network.HTTP2.Client as H
 import Network.Socket (HostName, ServiceName)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Notifications.Protocol
+import Simplex.Messaging.Agent.RetryInterval (RetryInterval (..))
 import Simplex.Messaging.Notifications.Server.Push.APNS.Internal
 import Simplex.Messaging.Notifications.Server.Store.Types (NtfTknRec (..))
 import Simplex.Messaging.Parsers (defaultJSON)
@@ -192,7 +193,8 @@ data APNSPushClientConfig = APNSPushClientConfig
    appTeamId :: Text,
    apnsPort :: ServiceName,
    http2cfg :: HTTP2ClientConfig,
-    caStoreFile :: FilePath
+    caStoreFile :: FilePath,
+    reconnectInterval :: RetryInterval
  }

 apnsProviderHost :: PushProvider -> Maybe HostName
@@ -214,7 +216,8 @@ defaultAPNSPushClientConfig =
      appTeamId = "5NN7GUYB6T",
      apnsPort = "443",
      http2cfg = defaultHTTP2ClientConfig {bufferSize = 16384},
-      caStoreFile = "/etc/ssl/cert.pem"
+      caStoreFile = "/etc/ssl/cert.pem",
+      reconnectInterval = RetryInterval {initialInterval = 2000000, increaseAfter = 0, maxInterval = 10000000}
    }

 data APNSPushClient = APNSPushClient
@@ -230,7 +233,7 @@ data APNSPushClient = APNSPushClient
 createAPNSPushClient :: HostName -> APNSPushClientConfig -> IO APNSPushClient
 createAPNSPushClient apnsHost apnsCfg@APNSPushClientConfig {authKeyFileEnv, authKeyAlg, authKeyIdEnv, appTeamId} = do
  https2Client <- newTVarIO Nothing
-  void $ connectHTTPS2 apnsHost apnsCfg https2Client
+  connectHTTPS2 apnsHost apnsCfg https2Client >>= either (throwIO . userError . show) (\_ -> pure ())
  privateKey <- readECPrivateKey =<< getEnv authKeyFileEnv
  authKeyId <- T.pack <$> getEnv authKeyIdEnv
  let jwtHeader = JWTHeader {alg = authKeyAlg, kid = authKeyId}
@@ -326,7 +329,7 @@ data PushProviderError
  | PPCryptoError C.CryptoError
  | PPResponseError (Maybe Status) Text
  | PPTokenInvalid NTInvalidReason
-  | PPRetryLater
+  | PPRetryLater Text
  | PPPermanentError
  deriving (Show, Exception)

@@ -343,8 +346,7 @@ apnsPushProviderClient c@APNSPushClient {nonceDrg, apnsCfg} tkn@NtfTknRec {token
  nonce <- atomically $ C.randomCbNonce nonceDrg
  apnsNtf <- liftEither $ first PPCryptoError $ apnsNotification tkn nonce (paddedNtfLength apnsCfg) pn
  req <- liftIO $ apnsRequest c tknStr apnsNtf
-  -- TODO when HTTP2 client is thread-safe, we can use sendRequestDirect
-  HTTP2Response {response, respBody = HTTP2Body {bodyHead}} <- liftHTTPS2 $ sendRequest http2 req Nothing
+  HTTP2Response {response, respBody = HTTP2Body {bodyHead}} <- liftHTTPS2 $ sendRequestDirect http2 req Nothing
  let status = H.responseStatus response
      reason' = maybe "" reason $ J.decodeStrict' bodyHead
  if status == Just N.ok200
@@ -373,8 +375,8 @@ apnsPushProviderClient c@APNSPushClient {nonceDrg, apnsCfg} tkn@NtfTknRec {token
      | status == Just N.gone410 = throwE $ case reason' of
          "ExpiredToken" -> PPTokenInvalid NTIRExpiredToken
          "Unregistered" -> PPTokenInvalid NTIRUnregistered
-          _ -> PPRetryLater
-      | status == Just N.serviceUnavailable503 = liftIO (disconnectApnsHTTP2Client c) >> throwE PPRetryLater
+          _ -> PPRetryLater $ "410 " <> reason'
+      | status == Just N.serviceUnavailable503 = liftIO (disconnectApnsHTTP2Client c) >> throwE (PPRetryLater "503")
      -- Just tooManyRequests429 -> TooManyRequests - too many requests for the same token
      | otherwise = throwE $ PPResponseError status reason'
    liftHTTPS2 a = ExceptT $ first PPConnection <$> a
@@ -7,6 +7,7 @@ module CoreTests.CryptoTests (cryptoTests) where

 import Control.Concurrent.STM
 import Control.Monad.Except
+import qualified Data.Aeson as J
 import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy.Char8 as LB
 import Data.Either (isRight)
@@ -22,6 +23,7 @@ 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.BBS
 import Simplex.Messaging.Crypto.SNTRUP761.Bindings
 import Simplex.Messaging.Transport.Client
 import Test.Hspec hiding (fit, it)
@@ -101,6 +103,16 @@ cryptoTests = do
    it "should validate certificates" testValidateX509
  describe "sntrup761" $
    it "should enc/dec key" testSNTRUP761
+  describe "BBS+" $ do
+    it "should sign and verify" testBBSSignVerify
+    it "should derive public key from secret key" testBBSPublicKeyDerivation
+    it "should generate and verify proof" testBBSProofRoundtrip
+    it "should reject tampered proof" testBBSTamperedProof
+    it "should reject wrong disclosed message" testBBSWrongMessage
+    it "should reject wrong public key" testBBSWrongKey
+    it "should produce unlinkable proofs" testBBSUnlinkable
+    it "should produce proof of expected size" testBBSProofSize
+    it "should roundtrip JSON and reject wrong-length input" testBBSJSON

 instance Eq C.APublicKey where
  C.APublicKey a k == C.APublicKey a' k' = case testEquality a a' of
@@ -271,3 +283,109 @@ testSNTRUP761 = do
  (c, KEMSharedKey k) <- sntrup761Enc drg pk
  KEMSharedKey k' <- sntrup761Dec c sk
  k' `shouldBe` k
+
+-- BBS+ tests
+
+bbsHeader :: BBSHeader
+bbsHeader = BBSHeader "SimpleX"
+
+bbsMessages :: [B.ByteString]
+bbsMessages = ["secret_master_key", "2026-07-31", "supporter"]
+
+bbsDisclosedIdxs :: [Int]
+bbsDisclosedIdxs = [1, 2]
+
+bbsDisclosedMsgs :: [B.ByteString]
+bbsDisclosedMsgs = ["2026-07-31", "supporter"]
+
+testBBSSignVerify :: IO ()
+testBBSSignVerify = do
+  Right (pk, sk) <- bbsKeyGen
+  let BBSSecretKey skBs = sk
+      BBSPublicKey pkBs = pk
+  B.length skBs `shouldBe` 32
+  B.length pkBs `shouldBe` 96
+  Right sig <- bbsSign sk bbsHeader bbsMessages
+  let BBSSignature sigBs = sig
+  B.length sigBs `shouldBe` 80
+  bbsVerify pk sig bbsHeader bbsMessages >>= (`shouldBe` True)
+  bbsVerify pk sig bbsHeader ["wrong", "2026-07-31", "supporter"] >>= (`shouldBe` False)
+
+testBBSPublicKeyDerivation :: IO ()
+testBBSPublicKeyDerivation = do
+  Right (pk, sk) <- bbsKeyGen
+  -- the public key derived from the secret key matches the one keygen returned
+  bbsPublicKey sk >>= (`shouldBe` Right pk)
+
+testBBSProofRoundtrip :: IO ()
+testBBSProofRoundtrip = do
+  Right (pk, sk) <- bbsKeyGen
+  Right sig <- bbsSign sk bbsHeader bbsMessages
+  let ph = BBSPresHeader "test-nonce-1"
+  Right proof <- bbsProofGen pk sig bbsHeader ph bbsDisclosedIdxs bbsMessages
+  result <- bbsProofVerify pk proof bbsHeader ph bbsDisclosedIdxs 3 bbsDisclosedMsgs
+  result `shouldBe` True
+
+testBBSTamperedProof :: IO ()
+testBBSTamperedProof = do
+  Right (pk, sk) <- bbsKeyGen
+  Right sig <- bbsSign sk bbsHeader bbsMessages
+  let ph = BBSPresHeader "test-nonce-2"
+  Right (BBSProof proofBs) <- bbsProofGen pk sig bbsHeader ph bbsDisclosedIdxs bbsMessages
+  let tampered = BBSProof $ B.take 10 proofBs <> "\xff" <> B.drop 11 proofBs
+  result <- bbsProofVerify pk tampered bbsHeader ph bbsDisclosedIdxs 3 bbsDisclosedMsgs
+  result `shouldBe` False
+
+testBBSWrongMessage :: IO ()
+testBBSWrongMessage = do
+  Right (pk, sk) <- bbsKeyGen
+  Right sig <- bbsSign sk bbsHeader bbsMessages
+  let ph = BBSPresHeader "test-nonce-3"
+  Right proof <- bbsProofGen pk sig bbsHeader ph bbsDisclosedIdxs bbsMessages
+  result <- bbsProofVerify pk proof bbsHeader ph bbsDisclosedIdxs 3 ["2026-07-31", "business"]
+  result `shouldBe` False
+
+testBBSWrongKey :: IO ()
+testBBSWrongKey = do
+  Right (pk, sk) <- bbsKeyGen
+  Right (pk2, _) <- bbsKeyGen
+  Right sig <- bbsSign sk bbsHeader bbsMessages
+  let ph = BBSPresHeader "test-nonce-4"
+  Right proof <- bbsProofGen pk sig bbsHeader ph bbsDisclosedIdxs bbsMessages
+  result <- bbsProofVerify pk2 proof bbsHeader ph bbsDisclosedIdxs 3 bbsDisclosedMsgs
+  result `shouldBe` False
+
+testBBSUnlinkable :: IO ()
+testBBSUnlinkable = do
+  Right (pk, sk) <- bbsKeyGen
+  Right sig <- bbsSign sk bbsHeader bbsMessages
+  let ph1 = BBSPresHeader "nonce-contact-1"
+      ph2 = BBSPresHeader "nonce-contact-2"
+  Right (BBSProof proof1) <- bbsProofGen pk sig bbsHeader ph1 bbsDisclosedIdxs bbsMessages
+  Right (BBSProof proof2) <- bbsProofGen pk sig bbsHeader ph2 bbsDisclosedIdxs bbsMessages
+  proof1 `shouldNotBe` proof2
+  bbsProofVerify pk (BBSProof proof1) bbsHeader ph1 bbsDisclosedIdxs 3 bbsDisclosedMsgs >>= (`shouldBe` True)
+  bbsProofVerify pk (BBSProof proof2) bbsHeader ph2 bbsDisclosedIdxs 3 bbsDisclosedMsgs >>= (`shouldBe` True)
+
+testBBSProofSize :: IO ()
+testBBSProofSize = do
+  Right (pk, sk) <- bbsKeyGen
+  Right sig <- bbsSign sk bbsHeader bbsMessages
+  let ph = BBSPresHeader "test-nonce-size"
+  Right (BBSProof proofBs) <- bbsProofGen pk sig bbsHeader ph bbsDisclosedIdxs bbsMessages
+  B.length proofBs `shouldBe` 304 -- 272 + 32 * 1 undisclosed
+
+testBBSJSON :: IO ()
+testBBSJSON = do
+  Right (pk, sk) <- bbsKeyGen
+  Right sig <- bbsSign sk bbsHeader bbsMessages
+  let ph = BBSPresHeader "json-nonce"
+  Right proof <- bbsProofGen pk sig bbsHeader ph bbsDisclosedIdxs bbsMessages
+  -- valid values roundtrip through JSON
+  J.decode (J.encode sk) `shouldBe` Just sk
+  J.decode (J.encode pk) `shouldBe` Just pk
+  J.decode (J.encode sig) `shouldBe` Just sig
+  J.decode (J.encode proof) `shouldBe` Just proof
+  -- FromJSON must reject wrong-length input (regression: StrJSON length validation)
+  (J.decode (J.encode (BBSSecretKey (B.replicate 16 '\0'))) :: Maybe BBSSecretKey) `shouldBe` Nothing
+  (J.decode (J.encode (BBSSignature (B.replicate 10 '\0'))) :: Maybe BBSSignature) `shouldBe` Nothing
Author	SHA1	Message	Date
Evgeny Poberezkin	d28f8fabed	Merge branch 'stable' into ep/optimize	2026-06-16 21:57:18 +01:00
Evgeny Poberezkin	376d6a261a	6.5.4.0	2026-06-15 22:26:45 +01:00
EvgenyandEvgeny @ SimpleX Chat <259188159+evgeny-simplex@users.noreply.github.com>	9f9b6c8e88	crypto: BBS scheme for anonymous credentials with multiple presentations (#1794 ) * crypto: BBS scheme for anonymous credentials with multiple presentations * verify * add files to sources * more files * more files, use cabal 3.0 * fix path * extensions * switch libbbs to fork * return either from keygen * use only secret key to sign * improve FFI * simplify * update libbbs to support iOS * add commoncrypto flag * bump libbbs * reject input of wrong length * ci: get submodules --------- Co-authored-by: Evgeny @ SimpleX Chat <259188159+evgeny-simplex@users.noreply.github.com>	2026-06-15 09:44:11 +01:00
Evgeny @ SimpleX Chat	3dd2f746f5	build: disable compiler optimizations by default	2026-06-09 15:38:58 +00:00
Evgeny Poberezkin	b981dcb70b	6.5.3.0	2026-06-01 13:17:47 +01:00
sh	ee2ff402fe	agent: split SimplexNameDomain out of SimplexNameInfo (#1788 ) * agent: split SimplexNameDomain out of SimplexNameInfo The type now separates the user-supplied type prefix (#/@) from the domain itself: data SimplexNameInfo = SimplexNameInfo { nameType :: SimplexNameType , nameDomain :: SimplexNameDomain } data SimplexNameDomain = SimplexNameDomain { nameTLD :: SimplexTLD , domain :: Text , subDomain :: [Text] } The domain is independent of the contact-vs-public-group distinction — the same dotted-labels structure applies to both. Future code that needs to talk about a domain without committing to a name type (e.g. server-side TLD-based registry lookup) can use SimplexNameDomain directly. fullDomainName now operates on SimplexNameDomain rather than the full info wrapper. Parser, StrEncoding instance, and aeson derivations updated accordingly. No external callers needed updating. * agent: split StrEncoding instance for SimplexNameDomain * agent: flatten TLD case + use unless guard * agent: address review - strict domain parser, permissive channel	2026-05-29 09:11:08 +01:00
Evgeny Poberezkin	e9265a7f7c	agent: allow all-digit names	2026-05-27 18:06:44 +01:00
EvgenyandEvgeny @ SimpleX Chat <259188159+evgeny-simplex@users.noreply.github.com>	7682999505	agent: types for namespace support (#1786 ) * agent: types for namespace support * parser * refactor * more refactor * simplify * refactor again * refactor * refactor * import * use @ for contact addresses * remove AConnectTarget * update parser and types * revert TLDWeb --------- Co-authored-by: Evgeny @ SimpleX Chat <259188159+evgeny-simplex@users.noreply.github.com>	2026-05-27 13:05:13 +01:00
Evgeny Poberezkin	f03cec7a58	6.5.2.0	2026-05-21 09:10:25 +01:00
sh	b6f551000f	ntf server: concurrent APNS push via sendRequestDirect (#1780 ) The per-(srvHost, provider) worker shards added in #1779 still funnel all APNS sends through one HTTP2Client's reqQ, where a single process thread calls sendRequest serially - one in-flight HTTP/2 stream at a time, capping APNS throughput at 1/RTT. sendRequestDirect bypasses the queue and invokes sendReq directly from the calling worker, so concurrent workers open parallel HTTP/2 streams on the shared APNS connection and the multiplexing happens on the wire.	2026-05-18 14:35:47 +01:00
shEvgeny @ SimpleX Chat <259188159+evgeny-simplex@users.noreply.github.com>Evgeny Poberezkin	012c8cc104	ntf server: concurrent notification delivery (#1779 ) * ntf-server: carry retry reason in PPRetryLater, log retries Change PPRetryLater from nullary to PPRetryLater Text so the cause (503 / 410-reason) propagates to the retry call site. Log a warning at every retry attempt with provider, token id and reason. * ntf-server: parallel push delivery via forkIO + per-srvHost lock Fork delivery per notification, taking an MVar keyed by srvHost_ so notifications from the same SMP server serialize while different servers proceed concurrently. Switch APNS to sendRequestDirect so concurrent deliveries share one HTTP/2 connection via stream multiplexing rather than serializing through the client reqQ. * ntf-server: single-flight push client creation via SessionVar Match the take/create/wait pattern in Agent/Client.hs (newProtocolClient / waitForProtocolClient). pushClients now wraps clients in SessionVar (Either SomeException PushProviderClient) so concurrent first-time access and concurrent retries collapse to a single mkClient call; waiters observe the winner's result via readTMVar (or its error). retryDeliver evicts the failing client by SessionVar identity before re-fetching. * use multiple queues and workers, remove semaphores and threads per notification * fix * retry connecting client * fix * move config * fix --------- Co-authored-by: Evgeny @ SimpleX Chat <259188159+evgeny-simplex@users.noreply.github.com> Co-authored-by: Evgeny Poberezkin <evgeny@poberezkin.com>	2026-05-18 09:26:50 +01:00
sh	fd298ae328	xftp: web page tweaks (#1772 )	2026-05-06 09:24:18 +01:00
Evgeny Poberezkin	1f173abf6d	6.5.1.0	2026-05-01 17:57:19 +01:00
Evgeny	21f4597dad	xftp: backwards compatible file header decoding (#1768 )	2026-05-01 13:32:19 +01:00