Merge branch 'stable'

This commit is contained in:
Evgeny Poberezkin
2026-06-16 06:50:14 +01:00
11 changed files with 616 additions and 3 deletions
+4
View File
@@ -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
+2
View File
@@ -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
+2
View File
@@ -11,6 +11,8 @@ jobs:
steps:
- name: Checkout code
uses: actions/checkout@v3
with:
submodules: recursive
- name: Get latest release
shell: bash
+6
View File
@@ -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
Submodule
+1
Submodule cbits/blst added at db3defd0d5
Submodule
+1
Submodule cbits/libbbs added at 59a0f4bf32
+126
View File
@@ -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)
+33 -3
View File
@@ -1,7 +1,7 @@
cabal-version: 1.12
cabal-version: 3.0
name: simplexmq
version: 6.5.2.0
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,11 @@ 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
library
exposed-modules:
Simplex.FileTransfer.Agent
@@ -122,6 +134,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
@@ -300,9 +313,26 @@ library
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
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:
+300
View File
@@ -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)
+23
View File
@@ -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))
+118
View File
@@ -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