-- |
-- Module      : Crypto.Random.SystemDRG
-- License     : BSD-style
-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
-- Stability   : experimental
-- Portability : Good
--
{-# 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)

-- | A referentially transparent System representation of
-- the random evaluated out of the system.
--
-- Holding onto a specific DRG means that all the already
-- evaluated bytes will be consistently replayed.
--
-- There's no need to reseed this DRG, as only pure
-- entropy is represented here.
data SystemDRG = SystemDRG !Int [ScrubbedBytes]

instance DRG SystemDRG where
    randomBytesGenerate :: forall byteArray.
ByteArray byteArray =>
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

-- | Grab one instance of the System DRG
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 a b. (a -> b) -> IO a -> IO b
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)
forall (m :: * -> *) a. Monad m => [m a] -> m [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 a. a -> IO a
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 :: forall byteArray.
ByteArray byteArray =>
Int -> SystemDRG -> (byteArray, 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)
forall p a. Int -> (Ptr p -> IO a) -> IO (a, output)
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 a. a -> IO a
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
forall p a. ScrubbedBytes -> (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)