diff --git a/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings/FFI.hs b/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings/FFI.hs index 77d17c5bf..1a603a87c 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" - sntrup761_keypair :: Ptr Word8 -> Ptr Word8 -> RNGContext -> RNGFunc -> IO () + sntrup761_keypair :: Ptr Word8 -> Ptr Word8 -> 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" - sntrup761_enc :: Ptr Word8 -> Ptr Word8 -> Ptr Word8 -> RNGContext -> RNGFunc -> IO () + sntrup761_enc :: Ptr Word8 -> Ptr Word8 -> Ptr Word8 -> 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 cdc47472c..627f735c0 100644 --- a/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings/RNG.hs +++ b/src/Simplex/Messaging/Crypto/SNTRUP761/Bindings/RNG.hs @@ -1,25 +1,54 @@ +{-# LANGUAGE NamedFieldPuns #-} module Simplex.Messaging.Crypto.SNTRUP761.Bindings.RNG ( RNG (..) , dummyRNG + , withHaskellRNG + , startHaskellRNG + , stopHaskellRNG , RNGContext , RNGFunc + , mkRNGFunc ) where import Foreign import Foreign.C +import Crypto.Random (getRandomBytes, drgNew, randomBytesGenerate) +import Data.ByteArray (Bytes, ByteArrayAccess (copyByteArrayToPtr)) +import UnliftIO (bracket) +import Data.IORef (newIORef, atomicModifyIORef') + data RNG = RNG { rngContext :: RNGContext - , rngFunc :: RNGFunc + , rngFunc :: FunPtr RNGFunc } dummyRNG :: RNG dummyRNG = RNG {rngContext = nullPtr, rngFunc = randomDummy} +withHaskellRNG :: (RNG -> IO c) -> IO c +withHaskellRNG = bracket startHaskellRNG stopHaskellRNG + +startHaskellRNG :: IO RNG +startHaskellRNG = 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 + copyByteArrayToPtr bs buf + pure RNG {rngContext = nullPtr, rngFunc} + where + swap (a, b) = (b, a) + +stopHaskellRNG :: RNG -> IO () +stopHaskellRNG RNG {rngFunc} = freeHaskellFunPtr rngFunc + type RNGContext = Ptr RNG -- typedef void random_func (void *ctx, size_t length, uint8_t *dst); -type RNGFunc = FunPtr (Ptr RNGContext -> CSize -> Ptr Word8 -> IO ()) +type RNGFunc = Ptr RNGContext -> CSize -> Ptr Word8 -> IO () foreign import ccall "&sxcrandom_dummy" - randomDummy :: RNGFunc + randomDummy :: FunPtr RNGFunc + +foreign import ccall "wrapper" + mkRNGFunc :: RNGFunc -> IO (FunPtr RNGFunc) diff --git a/tests/CoreTests/CryptoTests.hs b/tests/CoreTests/CryptoTests.hs index 3ad26a886..839cebbe3 100644 --- a/tests/CoreTests/CryptoTests.hs +++ b/tests/CoreTests/CryptoTests.hs @@ -16,7 +16,7 @@ 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 (dummyRNG) +import Simplex.Messaging.Crypto.SNTRUP761.Bindings.RNG import Test.Hspec import Test.Hspec.QuickCheck (modifyMaxSuccess) import Test.QuickCheck @@ -203,8 +203,8 @@ testEncoding alg = it "should encode / decode key" . ioProperty $ do && C.decodePrivKey (C.encodePrivKey pk) == Right pk testSNTRUP761 :: IO () -testSNTRUP761 = do - let rng = dummyRNG +testSNTRUP761 = withHaskellRNG $ \rng -> do + -- let rng = dummyRNG (pk, sk) <- sntrup761KeypairWith rng (c, k) <- sntrup761EncWith rng pk sntrup761Dec c sk `shouldReturn` k