1module Foundation.Random.ChaChaDRG
2    ( State(..)
3    , keySize
4    ) where
5
6import           Foundation.Class.Storable (peek)
7import           Basement.Imports
8import           Basement.Types.OffsetSize
9import           Basement.Monad
10import           Foundation.Random.Class
11import           Foundation.Random.DRG
12import qualified Basement.UArray as A
13import qualified Basement.UArray.Mutable as A
14import           GHC.ST
15import qualified Foreign.Marshal.Alloc (alloca)
16
17-- | RNG based on ChaCha core.
18--
19-- The algorithm is identical to the arc4random found in recent BSDs,
20-- namely a ChaCha core provide 64 bytes of random from 32 bytes of
21-- key.
22newtype State = State (UArray Word8)
23
24instance RandomGen State where
25    randomNew = State <$> getRandomBytes keySize
26    randomNewFrom bs
27        | A.length bs == keySize = Just $ State bs
28        | otherwise              = Nothing
29    randomGenerate = generate
30    randomGenerateWord64 = generateWord64
31    randomGenerateF32 = generateF32
32    randomGenerateF64 = generateF64
33
34keySize :: CountOf Word8
35keySize = 32
36
37generate :: CountOf Word8 -> State -> (UArray Word8, State)
38generate n (State key) = runST $ do
39    dst    <- A.newPinned n
40    newKey <- A.newPinned keySize
41    A.withMutablePtr dst        $ \dstP    ->
42        A.withMutablePtr newKey $ \newKeyP ->
43        A.withPtr key           $ \keyP    -> do
44            _ <- unsafePrimFromIO $ c_rngv1_generate newKeyP dstP keyP n
45            return ()
46    (,) <$> A.unsafeFreeze dst
47        <*> (State <$> A.unsafeFreeze newKey)
48
49generateWord64 :: State -> (Word64, State)
50generateWord64 (State key) = runST $ unsafePrimFromIO $
51    Foreign.Marshal.Alloc.alloca $ \dst -> do
52        newKey <- A.newPinned keySize
53        A.withMutablePtr newKey $ \newKeyP ->
54          A.withPtr key           $ \keyP  ->
55            c_rngv1_generate_word64 newKeyP dst keyP *> return ()
56        (,) <$> peek dst <*> (State <$> A.unsafeFreeze newKey)
57
58generateF32 :: State -> (Float, State)
59generateF32 (State key) = runST $ unsafePrimFromIO $
60    Foreign.Marshal.Alloc.alloca $ \dst -> do
61        newKey <- A.newPinned keySize
62        A.withMutablePtr newKey $ \newKeyP ->
63          A.withPtr key           $ \keyP  ->
64            c_rngv1_generate_f32 newKeyP dst keyP *> return ()
65        (,) <$> peek dst <*> (State <$> A.unsafeFreeze newKey)
66
67generateF64 :: State -> (Double, State)
68generateF64 (State key) = runST $ unsafePrimFromIO $
69    Foreign.Marshal.Alloc.alloca $ \dst -> do
70        newKey <- A.newPinned keySize
71        A.withMutablePtr newKey $ \newKeyP ->
72          A.withPtr key           $ \keyP  ->
73            c_rngv1_generate_f64 newKeyP dst keyP *> return ()
74        (,) <$> peek dst <*> (State <$> A.unsafeFreeze newKey)
75
76-- return 0 on success, !0 for failure
77foreign import ccall unsafe "foundation_rngV1_generate"
78   c_rngv1_generate :: Ptr Word8 -- new key
79                    -> Ptr Word8 -- destination
80                    -> Ptr Word8 -- current key
81                    -> CountOf Word8 -- number of bytes to generate
82                    -> IO Word32
83
84foreign import ccall unsafe "foundation_rngV1_generate_word64"
85   c_rngv1_generate_word64 :: Ptr Word8  -- new key
86                           -> Ptr Word64 -- destination
87                           -> Ptr Word8  -- current key
88                           -> IO Word32
89
90foreign import ccall unsafe "foundation_rngV1_generate_f32"
91   c_rngv1_generate_f32 :: Ptr Word8  -- new key
92                        -> Ptr Float -- destination
93                        -> Ptr Word8  -- current key
94                        -> IO Word32
95
96foreign import ccall unsafe "foundation_rngV1_generate_f64"
97   c_rngv1_generate_f64 :: Ptr Word8  -- new key
98                        -> Ptr Double -- destination
99                        -> Ptr Word8  -- current key
100                        -> IO Word32
101