SystemDRG.hs

{-# LANGUAGE BangPatterns #-}

-- |
-- Module      : Crypto.Random.SystemDRG
-- License     : BSD-style
-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
-- Stability   : experimental
-- Portability : Good
module Crypto.Random.SystemDRG (
    SystemDRG,
    getSystemDRG,
) where

import Crypto.Internal.Compat
import Crypto.Random.Entropy.Unsafe
import Crypto.Random.Types
import Data.ByteArray (ByteArray, ScrubbedBytes)
import qualified Data.ByteArray as B
import Data.Maybe (catMaybes)
import Data.Memory.PtrMethods as B (memCopy)
import Data.Tuple (swap)
import Foreign.Ptr
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 = generate

systemChunkSize :: Int
systemChunkSize = 256

-- | Grab one instance of the System DRG
getSystemDRG :: IO SystemDRG
getSystemDRG = do
    backends <- catMaybes `fmap` sequence supportedBackends
    let getNext = unsafeInterleaveIO $ do
            bs <- B.alloc systemChunkSize (replenish systemChunkSize backends)
            more <- getNext
            return (bs : more)
    SystemDRG 0 <$> getNext

generate :: ByteArray output => Int -> SystemDRG -> (output, SystemDRG)
generate nbBytes (SystemDRG ofs sysChunks) = swap $ unsafeDoIO $ B.allocRet nbBytes $ loop ofs sysChunks nbBytes
  where
    loop currentOfs chunks 0 _ = return $! SystemDRG currentOfs chunks
    loop _ [] _ _ = error "SystemDRG: the impossible happened: empty chunk"
    loop currentOfs oChunks@(c : cs) n d = do
        let currentLeft = B.length c - currentOfs
            toCopy = min n currentLeft
            nextOfs = currentOfs + toCopy
            n' = n - toCopy
        B.withByteArray c $ \src -> B.memCopy d (src `plusPtr` currentOfs) toCopy
        if nextOfs == B.length c
            then loop 0 cs n' (d `plusPtr` toCopy)
            else loop nextOfs oChunks n' (d `plusPtr` toCopy)