pass ChaChaDRG via FunPtr

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"

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)

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