{-# LANGUAGE BangPatterns #-}
module Crypto.Random.SystemDRG
( SystemDRG
, getSystemDRG
) where
import Crypto.Random.Types
import Crypto.Random.Entropy.Unsafe
import Crypto.Internal.Compat
import Data.ByteArray (ScrubbedBytes, ByteArray)
import Data.Memory.PtrMethods as B (memCopy)
import Data.Maybe (catMaybes)
import Data.Tuple (swap)
import Foreign.Ptr
import qualified Data.ByteArray as B
import System.IO.Unsafe (unsafeInterleaveIO)
data SystemDRG = SystemDRG !Int [ScrubbedBytes]
instance DRG SystemDRG where
randomBytesGenerate :: Int -> SystemDRG -> (byteArray, SystemDRG)
randomBytesGenerate = Int -> SystemDRG -> (byteArray, SystemDRG)
forall byteArray.
ByteArray byteArray =>
Int -> SystemDRG -> (byteArray, SystemDRG)
generate
systemChunkSize :: Int
systemChunkSize :: Int
systemChunkSize = Int
256
getSystemDRG :: IO SystemDRG
getSystemDRG :: IO SystemDRG
getSystemDRG = do
[EntropyBackend]
backends <- [Maybe EntropyBackend] -> [EntropyBackend]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe EntropyBackend] -> [EntropyBackend])
-> IO [Maybe EntropyBackend] -> IO [EntropyBackend]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` [IO (Maybe EntropyBackend)] -> IO [Maybe EntropyBackend]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [IO (Maybe EntropyBackend)]
supportedBackends
let getNext :: IO [ScrubbedBytes]
getNext = IO [ScrubbedBytes] -> IO [ScrubbedBytes]
forall a. IO a -> IO a
unsafeInterleaveIO (IO [ScrubbedBytes] -> IO [ScrubbedBytes])
-> IO [ScrubbedBytes] -> IO [ScrubbedBytes]
forall a b. (a -> b) -> a -> b
$ do
ScrubbedBytes
bs <- Int -> (Ptr Word8 -> IO ()) -> IO ScrubbedBytes
forall ba p. ByteArray ba => Int -> (Ptr p -> IO ()) -> IO ba
B.alloc Int
systemChunkSize (Int -> [EntropyBackend] -> Ptr Word8 -> IO ()
replenish Int
systemChunkSize [EntropyBackend]
backends)
[ScrubbedBytes]
more <- IO [ScrubbedBytes]
getNext
[ScrubbedBytes] -> IO [ScrubbedBytes]
forall (m :: * -> *) a. Monad m => a -> m a
return (ScrubbedBytes
bsScrubbedBytes -> [ScrubbedBytes] -> [ScrubbedBytes]
forall a. a -> [a] -> [a]
:[ScrubbedBytes]
more)
Int -> [ScrubbedBytes] -> SystemDRG
SystemDRG Int
0 ([ScrubbedBytes] -> SystemDRG)
-> IO [ScrubbedBytes] -> IO SystemDRG
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [ScrubbedBytes]
getNext
generate :: ByteArray output => Int -> SystemDRG -> (output, SystemDRG)
generate :: Int -> SystemDRG -> (output, SystemDRG)
generate Int
nbBytes (SystemDRG Int
ofs [ScrubbedBytes]
sysChunks) = (SystemDRG, output) -> (output, SystemDRG)
forall a b. (a, b) -> (b, a)
swap ((SystemDRG, output) -> (output, SystemDRG))
-> (SystemDRG, output) -> (output, SystemDRG)
forall a b. (a -> b) -> a -> b
$ IO (SystemDRG, output) -> (SystemDRG, output)
forall a. IO a -> a
unsafeDoIO (IO (SystemDRG, output) -> (SystemDRG, output))
-> IO (SystemDRG, output) -> (SystemDRG, output)
forall a b. (a -> b) -> a -> b
$ Int -> (Ptr Word8 -> IO SystemDRG) -> IO (SystemDRG, output)
forall ba p a. ByteArray ba => Int -> (Ptr p -> IO a) -> IO (a, ba)
B.allocRet Int
nbBytes ((Ptr Word8 -> IO SystemDRG) -> IO (SystemDRG, output))
-> (Ptr Word8 -> IO SystemDRG) -> IO (SystemDRG, output)
forall a b. (a -> b) -> a -> b
$ Int -> [ScrubbedBytes] -> Int -> Ptr Word8 -> IO SystemDRG
loop Int
ofs [ScrubbedBytes]
sysChunks Int
nbBytes
where loop :: Int -> [ScrubbedBytes] -> Int -> Ptr Word8 -> IO SystemDRG
loop Int
currentOfs [ScrubbedBytes]
chunks Int
0 Ptr Word8
_ = SystemDRG -> IO SystemDRG
forall (m :: * -> *) a. Monad m => a -> m a
return (SystemDRG -> IO SystemDRG) -> SystemDRG -> IO SystemDRG
forall a b. (a -> b) -> a -> b
$! Int -> [ScrubbedBytes] -> SystemDRG
SystemDRG Int
currentOfs [ScrubbedBytes]
chunks
loop Int
_ [] Int
_ Ptr Word8
_ = [Char] -> IO SystemDRG
forall a. HasCallStack => [Char] -> a
error [Char]
"SystemDRG: the impossible happened: empty chunk"
loop Int
currentOfs oChunks :: [ScrubbedBytes]
oChunks@(ScrubbedBytes
c:[ScrubbedBytes]
cs) Int
n Ptr Word8
d = do
let currentLeft :: Int
currentLeft = ScrubbedBytes -> Int
forall ba. ByteArrayAccess ba => ba -> Int
B.length ScrubbedBytes
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
currentOfs
toCopy :: Int
toCopy = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
n Int
currentLeft
nextOfs :: Int
nextOfs = Int
currentOfs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
toCopy
n' :: Int
n' = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
toCopy
ScrubbedBytes -> (Ptr Any -> IO ()) -> IO ()
forall ba p a. ByteArrayAccess ba => ba -> (Ptr p -> IO a) -> IO a
B.withByteArray ScrubbedBytes
c ((Ptr Any -> IO ()) -> IO ()) -> (Ptr Any -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr Any
src -> Ptr Word8 -> Ptr Word8 -> Int -> IO ()
B.memCopy Ptr Word8
d (Ptr Any
src Ptr Any -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
currentOfs) Int
toCopy
if Int
nextOfs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== ScrubbedBytes -> Int
forall ba. ByteArrayAccess ba => ba -> Int
B.length ScrubbedBytes
c
then Int -> [ScrubbedBytes] -> Int -> Ptr Word8 -> IO SystemDRG
loop Int
0 [ScrubbedBytes]
cs Int
n' (Ptr Word8
d Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
toCopy)
else Int -> [ScrubbedBytes] -> Int -> Ptr Word8 -> IO SystemDRG
loop Int
nextOfs [ScrubbedBytes]
oChunks Int
n' (Ptr Word8
d Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
toCopy)