diff --git a/simplexmq.cabal b/simplexmq.cabal index c8ed1f759..9f8937e5b 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -101,6 +101,7 @@ library Simplex.Messaging.Crypto.File Simplex.Messaging.Crypto.Lazy Simplex.Messaging.Crypto.Ratchet + Simplex.Messaging.Crypto.SNTRUP761 Simplex.Messaging.Crypto.SNTRUP761.Bindings Simplex.Messaging.Crypto.SNTRUP761.Bindings.Defines Simplex.Messaging.Crypto.SNTRUP761.Bindings.FFI diff --git a/src/Simplex/Messaging/Crypto.hs b/src/Simplex/Messaging/Crypto.hs index cfc8156cf..4370a247a 100644 --- a/src/Simplex/Messaging/Crypto.hs +++ b/src/Simplex/Messaging/Crypto.hs @@ -115,6 +115,8 @@ module Simplex.Messaging.Crypto cbEncrypt, cbEncryptMaxLenBS, cbDecrypt, + sbDecrypt_, + sbEncrypt_, cbNonce, randomCbNonce, pseudoRandomCbNonce, diff --git a/src/Simplex/Messaging/Crypto/SNTRUP761.hs b/src/Simplex/Messaging/Crypto/SNTRUP761.hs new file mode 100644 index 000000000..db29508e8 --- /dev/null +++ b/src/Simplex/Messaging/Crypto/SNTRUP761.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} + +module Simplex.Messaging.Crypto.SNTRUP761 where + +import Crypto.Hash (Digest, SHA256, hash) +import Data.ByteArray (ScrubbedBytes) +import qualified Data.ByteArray as BA +import Data.ByteString (ByteString) +import Simplex.Messaging.Crypto +import Simplex.Messaging.Crypto.SNTRUP761.Bindings + +-- Hybrid shared secret for crypto_box is defined as SHA256(DHSecret || KEMSharedKey), +-- similar to https://datatracker.ietf.org/doc/draft-josefsson-ntruprime-hybrid/ + +newtype KEMHybridSecret = KEMHybridSecret ScrubbedBytes + +-- | NaCl @crypto_box@ decrypt with a shared hybrid DH + KEM secret and 192-bit nonce. +kcbDecrypt :: KEMHybridSecret -> CbNonce -> ByteString -> Either CryptoError ByteString +kcbDecrypt (KEMHybridSecret secret) = sbDecrypt_ secret + +-- | NaCl @crypto_box@ encrypt with a shared hybrid DH + KEM secret and 192-bit nonce. +kcbEncrypt :: KEMHybridSecret -> CbNonce -> ByteString -> Int -> Either CryptoError ByteString +kcbEncrypt (KEMHybridSecret secret) = sbEncrypt_ secret + +kemHybridSecret :: DhSecret 'X25519 -> KEMSharedKey -> KEMHybridSecret +kemHybridSecret (DhSecretX25519 k1) (KEMSharedKey k2) = + KEMHybridSecret $ BA.convert (hash $ BA.convert k1 <> k2 :: Digest SHA256) diff --git a/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings.hs b/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings.hs index 0da90fbc9..3c430e76f 100644 --- a/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings.hs +++ b/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings.hs @@ -1,38 +1,64 @@ -{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeApplications #-} module Simplex.Messaging.Crypto.SNTRUP761.Bindings where +import Control.Concurrent.STM +import Crypto.Random (ChaChaDRG) +import Data.Bifunctor (bimap) import Data.ByteArray (ScrubbedBytes) import qualified Data.ByteArray as BA import Data.ByteString (ByteString) +import Foreign (nullPtr) import Simplex.Messaging.Crypto.SNTRUP761.Bindings.Defines import Simplex.Messaging.Crypto.SNTRUP761.Bindings.FFI -import Simplex.Messaging.Crypto.SNTRUP761.Bindings.RNG (RNG (..)) +import Simplex.Messaging.Crypto.SNTRUP761.Bindings.RNG (withDRG) +import Simplex.Messaging.Encoding +import Simplex.Messaging.Encoding.String -type PublicKey = ByteString +newtype KEMPublicKey = KEMPublicKey ByteString -type SecretKey = ScrubbedBytes +newtype KEMSecretKey = KEMSecretKey ScrubbedBytes -type Ciphertext = ByteString +newtype KEMCiphertext = KEMCiphertext ByteString -type Key = ScrubbedBytes +newtype KEMSharedKey = KEMSharedKey ScrubbedBytes -sntrup761Keypair :: RNG -> IO (PublicKey, SecretKey) -sntrup761Keypair RNG {rngContext, rngFunc} = do - BA.allocRet c_SNTRUP761_SECRETKEY_SIZE $ \skPtr -> - BA.alloc c_SNTRUP761_PUBLICKEY_SIZE $ \pkPtr -> - c_sntrup761_keypair pkPtr skPtr rngContext rngFunc +sntrup761Keypair :: TVar ChaChaDRG -> IO (KEMPublicKey, KEMSecretKey) +sntrup761Keypair drg = + bimap KEMPublicKey KEMSecretKey + <$> BA.allocRet + c_SNTRUP761_SECRETKEY_SIZE + ( \skPtr -> + BA.alloc c_SNTRUP761_PUBLICKEY_SIZE $ \pkPtr -> + withDRG drg $ c_sntrup761_keypair pkPtr skPtr nullPtr + ) -sntrup761Enc :: RNG -> PublicKey -> IO (Ciphertext, Key) -sntrup761Enc RNG {rngContext, rngFunc} pk = +sntrup761Enc :: TVar ChaChaDRG -> KEMPublicKey -> IO (KEMCiphertext, KEMSharedKey) +sntrup761Enc drg (KEMPublicKey pk) = BA.withByteArray pk $ \pkPtr -> - BA.allocRet c_SNTRUP761_SIZE $ \kPtr -> - BA.alloc c_SNTRUP761_CIPHERTEXT_SIZE $ \cPtr -> - c_sntrup761_enc cPtr kPtr pkPtr rngContext rngFunc + bimap KEMCiphertext KEMSharedKey + <$> BA.allocRet + c_SNTRUP761_SIZE + ( \kPtr -> + BA.alloc c_SNTRUP761_CIPHERTEXT_SIZE $ \cPtr -> + withDRG drg $ c_sntrup761_enc cPtr kPtr pkPtr nullPtr + ) -sntrup761Dec :: Ciphertext -> SecretKey -> IO Key -sntrup761Dec c sk = +sntrup761Dec :: KEMCiphertext -> KEMSecretKey -> IO KEMSharedKey +sntrup761Dec (KEMCiphertext c) (KEMSecretKey sk) = BA.withByteArray sk $ \skPtr -> BA.withByteArray c $ \cPtr -> - BA.alloc c_SNTRUP761_SIZE $ \kPtr -> - c_sntrup761_dec kPtr cPtr skPtr + KEMSharedKey + <$> BA.alloc c_SNTRUP761_SIZE (\kPtr -> c_sntrup761_dec kPtr cPtr skPtr) + +instance Encoding KEMPublicKey where + smpEncode (KEMPublicKey pk) = smpEncode (BA.convert pk :: ByteString) + smpP = KEMPublicKey . BA.convert <$> smpP @ByteString + +instance StrEncoding KEMPublicKey where + strEncode (KEMPublicKey pk) = strEncode (BA.convert pk :: ByteString) + strP = KEMPublicKey . BA.convert <$> strP @ByteString + +instance Encoding KEMCiphertext where + smpEncode (KEMCiphertext c) = smpEncode (BA.convert c :: ByteString) + smpP = KEMCiphertext . BA.convert <$> smpP @ByteString diff --git a/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings/Defines.hsc b/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings/Defines.hsc index a7ba2a09b..1f18e16d0 100644 --- a/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings/Defines.hsc +++ b/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings/Defines.hsc @@ -1,7 +1,5 @@ module Simplex.Messaging.Crypto.SNTRUP761.Bindings.Defines where -import Foreign.C - #include "sntrup761.h" c_SNTRUP761_SECRETKEY_SIZE :: Int diff --git a/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings/FFI.hs b/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings/FFI.hs index 922d54eae..4983e9210 100644 --- a/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings/FFI.hs +++ b/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings/FFI.hs @@ -12,11 +12,11 @@ import Simplex.Messaging.Crypto.SNTRUP761.Bindings.RNG (RNGContext, RNGFunc) -- void sntrup761_keypair (uint8_t *pk, uint8_t *sk, void *random_ctx, sntrup761_random_func *random); foreign import ccall "sntrup761_keypair" - c_sntrup761_keypair :: Ptr Word8 -> Ptr Word8 -> RNGContext -> FunPtr RNGFunc -> IO () + c_sntrup761_keypair :: Ptr Word8 -> Ptr Word8 -> Ptr RNGContext -> FunPtr RNGFunc -> IO () -- void sntrup761_enc (uint8_t *c, uint8_t *k, const uint8_t *pk, void *random_ctx, sntrup761_random_func *random); foreign import ccall "sntrup761_enc" - c_sntrup761_enc :: Ptr Word8 -> Ptr Word8 -> Ptr Word8 -> RNGContext -> FunPtr RNGFunc -> IO () + c_sntrup761_enc :: Ptr Word8 -> Ptr Word8 -> Ptr Word8 -> Ptr RNGContext -> FunPtr RNGFunc -> IO () -- void sntrup761_dec (uint8_t *k, const uint8_t *c, const uint8_t *sk); foreign import ccall "sntrup761_dec" diff --git a/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings/RNG.hs b/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings/RNG.hs index 4ed1d5ee0..e776f610d 100644 --- a/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings/RNG.hs +++ b/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings/RNG.hs @@ -1,45 +1,27 @@ -{-# LANGUAGE NamedFieldPuns #-} - module Simplex.Messaging.Crypto.SNTRUP761.Bindings.RNG - ( RNG (..), - withRNG, - createRNG, - freeRNG, + ( withDRG, RNGContext, RNGFunc, - mkRNGFunc, ) where +import Control.Concurrent.STM +import Control.Exception (bracket) +import Crypto.Random (ChaChaDRG) +import Data.ByteArray (ByteArrayAccess (copyByteArrayToPtr)) import Foreign import Foreign.C +import qualified Simplex.Messaging.Crypto as C -import Crypto.Random (drgNew, randomBytesGenerate) -import Data.ByteArray (ByteArrayAccess (copyByteArrayToPtr), Bytes) -import Data.IORef (atomicModifyIORef', newIORef) -import UnliftIO (bracket) +withDRG :: TVar ChaChaDRG -> (FunPtr RNGFunc -> IO a) -> IO a +withDRG drg = bracket (createRNGFunc drg) freeHaskellFunPtr -data RNG = RNG - { rngContext :: RNGContext, - rngFunc :: FunPtr RNGFunc - } - -withRNG :: (RNG -> IO c) -> IO c -withRNG = bracket createRNG freeRNG - -createRNG :: IO RNG -createRNG = do - chachaState <- drgNew >>= newIORef -- XXX: ctxPtr could be used to store drg state, but cryptonite doesn't provide ByteAccess for ChaChaDRG - rngFunc <- mkRNGFunc $ \_ctxPtr sz buf -> do - bs <- atomicModifyIORef' chachaState $ swap . randomBytesGenerate (fromIntegral sz) :: IO Bytes +createRNGFunc :: TVar ChaChaDRG -> IO (FunPtr RNGFunc) +createRNGFunc drg = + mkRNGFunc $ \_ctx sz buf -> do + bs <- atomically $ C.pseudoRandomBytes (fromIntegral sz) drg copyByteArrayToPtr bs buf - pure RNG {rngContext = nullPtr, rngFunc} - where - swap (a, b) = (b, a) -freeRNG :: RNG -> IO () -freeRNG RNG {rngFunc} = freeHaskellFunPtr rngFunc - -type RNGContext = Ptr RNG +type RNGContext = () -- typedef void random_func (void *ctx, size_t length, uint8_t *dst); type RNGFunc = Ptr RNGContext -> CSize -> Ptr Word8 -> IO () diff --git a/tests/CoreTests/CryptoTests.hs b/tests/CoreTests/CryptoTests.hs index af613fe84..fb902a41e 100644 --- a/tests/CoreTests/CryptoTests.hs +++ b/tests/CoreTests/CryptoTests.hs @@ -3,8 +3,9 @@ module CoreTests.CryptoTests (cryptoTests) where +import Control.Concurrent.STM import Control.Monad.Except -import Crypto.Random (getRandomBytes) +import Crypto.Random (drgNew, getRandomBytes) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as LB import Data.Either (isRight) @@ -16,7 +17,6 @@ import qualified Data.Text.Lazy.Encoding as LE import qualified Simplex.Messaging.Crypto as C import qualified Simplex.Messaging.Crypto.Lazy as LC import Simplex.Messaging.Crypto.SNTRUP761.Bindings -import Simplex.Messaging.Crypto.SNTRUP761.Bindings.RNG import Test.Hspec import Test.Hspec.QuickCheck (modifyMaxSuccess) import Test.QuickCheck @@ -203,7 +203,9 @@ testEncoding alg = it "should encode / decode key" . ioProperty $ do && C.decodePrivKey (C.encodePrivKey pk) == Right pk testSNTRUP761 :: IO () -testSNTRUP761 = withRNG $ \rng -> do - (pk, sk) <- sntrup761Keypair rng - (c, k) <- sntrup761Enc rng pk - sntrup761Dec c sk `shouldReturn` k +testSNTRUP761 = do + drg <- newTVarIO =<< drgNew + (pk, sk) <- sntrup761Keypair drg + (c, KEMSharedKey k) <- sntrup761Enc drg pk + KEMSharedKey k' <- sntrup761Dec c sk + k' `shouldBe` k