Initial commit

bundled/Crypto/Random/ChaChaDRG.hs

@@ -0,0 +1,46 @@
+-- |
+-- Module      : Crypto.Random.ChaChaDRG
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : stable
+-- Portability : good
+--
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module Crypto.Random.ChaChaDRG
+    ( ChaChaDRG
+    , initialize
+    , initializeWords
+    ) where
+
+import           Crypto.Random.Types
+import           Crypto.Internal.Imports
+import           Crypto.Internal.ByteArray (ByteArray, ByteArrayAccess, ScrubbedBytes)
+import qualified Crypto.Internal.ByteArray as B
+import           Foreign.Storable (pokeElemOff)
+
+import qualified Crypto.Cipher.ChaCha as C
+
+instance DRG ChaChaDRG where
+    randomBytesGenerate = generate
+
+-- | ChaCha Deterministic Random Generator
+newtype ChaChaDRG = ChaChaDRG C.StateSimple
+    deriving (NFData)
+
+-- | Initialize a new ChaCha context with the number of rounds,
+-- the key and the nonce associated.
+initialize :: ByteArrayAccess seed
+           => seed        -- ^ 40 bytes of seed
+           -> ChaChaDRG   -- ^ the initial ChaCha state
+initialize seed = ChaChaDRG $ C.initializeSimple seed
+
+-- | Initialize a new ChaCha context from 5-tuple of words64.
+-- This interface is useful when creating a RNG out of tests generators (e.g. QuickCheck).
+initializeWords :: (Word64, Word64, Word64, Word64, Word64) -> ChaChaDRG
+initializeWords (a,b,c,d,e) = initialize (B.allocAndFreeze 40 fill :: ScrubbedBytes)
+  where fill s = mapM_ (uncurry (pokeElemOff s)) [(0,a), (1,b), (2,c), (3,d), (4,e)]
+
+generate :: ByteArray output => Int -> ChaChaDRG -> (output, ChaChaDRG)
+generate nbBytes st@(ChaChaDRG prevSt)
+    | nbBytes <= 0 = (B.empty, st)
+    | otherwise    = let (output, newSt) = C.generateSimple prevSt nbBytes in (output, ChaChaDRG newSt)

bundled/Crypto/Random/Entropy.hs

@@ -0,0 +1,22 @@
+-- |
+-- Module      : Crypto.Random.Entropy
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : experimental
+-- Portability : Good
+--
+module Crypto.Random.Entropy
+    ( getEntropy
+    ) where
+
+import           Data.Maybe (catMaybes)
+import           Crypto.Internal.ByteArray (ByteArray)
+import qualified Crypto.Internal.ByteArray as B
+
+import           Crypto.Random.Entropy.Unsafe
+
+-- | Get some entropy from the system source of entropy
+getEntropy :: ByteArray byteArray => Int -> IO byteArray
+getEntropy n = do
+    backends <- catMaybes `fmap` sequence supportedBackends
+    B.alloc n (replenish n backends)

bundled/Crypto/Random/Entropy/Backend.hs

@@ -0,0 +1,57 @@
+-- |
+-- Module      : Crypto.Random.Entropy.Backend
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : stable
+-- Portability : good
+--
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ExistentialQuantification #-}
+module Crypto.Random.Entropy.Backend
+    ( EntropyBackend
+    , supportedBackends
+    , gatherBackend
+    ) where
+
+import Foreign.Ptr
+import Data.Proxy
+import Data.Word (Word8)
+import Crypto.Random.Entropy.Source
+#ifdef SUPPORT_RDRAND
+import Crypto.Random.Entropy.RDRand
+#endif
+#ifdef WINDOWS
+import Crypto.Random.Entropy.Windows
+#else
+import Crypto.Random.Entropy.Unix
+#endif
+
+-- | All supported backends 
+supportedBackends :: [IO (Maybe EntropyBackend)]
+supportedBackends =
+    [
+#ifdef SUPPORT_RDRAND
+    openBackend (Proxy :: Proxy RDRand),
+#endif
+#ifdef WINDOWS
+    openBackend (Proxy :: Proxy WinCryptoAPI)
+#else
+    openBackend (Proxy :: Proxy DevRandom), openBackend (Proxy :: Proxy DevURandom)
+#endif
+    ]
+
+-- | Any Entropy Backend
+data EntropyBackend = forall b . EntropySource b => EntropyBackend b
+
+-- | Open a backend handle
+openBackend :: EntropySource b => Proxy b -> IO (Maybe EntropyBackend)
+openBackend b = fmap EntropyBackend `fmap` callOpen b
+  where callOpen :: EntropySource b => Proxy b -> IO (Maybe b)
+        callOpen _ = entropyOpen
+
+-- | Gather randomness from an open handle
+gatherBackend :: EntropyBackend -- ^ An open Entropy Backend
+              -> Ptr Word8      -- ^ Pointer to a buffer to write to
+              -> Int            -- ^ number of bytes to write
+              -> IO Int         -- ^ return the number of bytes actually written
+gatherBackend (EntropyBackend backend) ptr n = entropyGather backend ptr n

bundled/Crypto/Random/Entropy/RDRand.hs

@@ -0,0 +1,38 @@
+-- |
+-- Module      : Crypto.Random.Entropy.RDRand
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : experimental
+-- Portability : Good
+--
+{-# LANGUAGE ForeignFunctionInterface #-}
+module Crypto.Random.Entropy.RDRand
+    ( RDRand
+    ) where
+
+import Foreign.Ptr
+import Foreign.C.Types
+import Data.Word (Word8)
+import Crypto.Random.Entropy.Source
+
+foreign import ccall unsafe "cryptonite_cpu_has_rdrand"
+   c_cpu_has_rdrand :: IO CInt
+
+foreign import ccall unsafe "cryptonite_get_rand_bytes"
+  c_get_rand_bytes :: Ptr Word8 -> CInt -> IO CInt
+
+-- | Fake handle to Intel RDRand entropy CPU instruction
+data RDRand = RDRand
+
+instance EntropySource RDRand where
+    entropyOpen     = rdrandGrab
+    entropyGather _ = rdrandGetBytes
+    entropyClose  _ = return ()
+
+rdrandGrab :: IO (Maybe RDRand)
+rdrandGrab = supported `fmap` c_cpu_has_rdrand
+  where supported 0 = Nothing
+        supported _ = Just RDRand
+
+rdrandGetBytes :: Ptr Word8 -> Int -> IO Int
+rdrandGetBytes ptr sz = fromIntegral `fmap` c_get_rand_bytes ptr (fromIntegral sz)

bundled/Crypto/Random/Entropy/Source.hs

@@ -0,0 +1,22 @@
+-- |
+-- Module      : Crypto.Random.Entropy.Source
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : experimental
+-- Portability : Good
+--
+module Crypto.Random.Entropy.Source where
+
+import Foreign.Ptr
+import Data.Word (Word8)
+
+-- | A handle to an entropy maker, either a system capability
+-- or a hardware generator.
+class EntropySource a where
+    -- | Try to open an handle for this source
+    entropyOpen   :: IO (Maybe a)
+    -- | Try to gather a number of entropy bytes into a buffer.
+    -- Return the number of actual bytes gathered
+    entropyGather :: a -> Ptr Word8 -> Int -> IO Int
+    -- | Close an open handle
+    entropyClose  :: a -> IO ()

bundled/Crypto/Random/Entropy/Unix.hs

@@ -0,0 +1,74 @@
+-- |
+-- Module      : Crypto.Random.Entropy.Unix
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : experimental
+-- Portability : Good
+--
+{-# LANGUAGE ScopedTypeVariables #-}
+module Crypto.Random.Entropy.Unix
+    ( DevRandom
+    , DevURandom
+    ) where
+
+import Foreign.Ptr
+import Data.Word (Word8)
+import Crypto.Random.Entropy.Source
+import Control.Exception as E
+
+--import System.Posix.Types (Fd)
+import System.IO
+
+type H = Handle
+type DeviceName = String
+
+-- | Entropy device @/dev/random@ on unix system
+newtype DevRandom  = DevRandom DeviceName
+
+-- | Entropy device @/dev/urandom@ on unix system
+newtype DevURandom = DevURandom DeviceName
+
+instance EntropySource DevRandom where
+    entropyOpen = fmap DevRandom `fmap` testOpen "/dev/random"
+    entropyGather (DevRandom name) ptr n =
+        withDev name $ \h -> gatherDevEntropyNonBlock h ptr n
+    entropyClose (DevRandom _)  = return ()
+
+instance EntropySource DevURandom where
+    entropyOpen = fmap DevURandom `fmap` testOpen "/dev/urandom"
+    entropyGather (DevURandom name) ptr n =
+        withDev name $ \h -> gatherDevEntropy h ptr n
+    entropyClose (DevURandom _)  = return ()
+
+testOpen :: DeviceName -> IO (Maybe DeviceName)
+testOpen filepath = do
+    d <- openDev filepath
+    case d of
+        Nothing -> return Nothing
+        Just h  -> closeDev h >> return (Just filepath)
+
+openDev :: String -> IO (Maybe H)
+openDev filepath = (Just `fmap` openAndNoBuffering) `E.catch` \(_ :: IOException) -> return Nothing
+  where openAndNoBuffering = do
+            h <- openBinaryFile filepath ReadMode
+            hSetBuffering h NoBuffering
+            return h
+
+withDev :: String -> (H -> IO a) -> IO a
+withDev filepath f = openDev filepath >>= \h ->
+    case h of
+        Nothing -> error ("device " ++ filepath ++ " cannot be grabbed")
+        Just fd -> f fd `E.finally` closeDev fd
+
+closeDev :: H -> IO ()
+closeDev h = hClose h
+
+gatherDevEntropy :: H -> Ptr Word8 -> Int -> IO Int
+gatherDevEntropy h ptr sz =
+     (fromIntegral `fmap` hGetBufSome h ptr (fromIntegral sz))
+    `E.catch` \(_ :: IOException) -> return 0
+
+gatherDevEntropyNonBlock :: H -> Ptr Word8 -> Int -> IO Int
+gatherDevEntropyNonBlock h ptr sz =
+     (fromIntegral `fmap` hGetBufNonBlocking h ptr (fromIntegral sz))
+    `E.catch` \(_ :: IOException) -> return 0

bundled/Crypto/Random/Entropy/Unsafe.hs

@@ -0,0 +1,34 @@
+-- |
+-- Module      : Crypto.Random.Entropy.Unsafe
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : experimental
+-- Portability : Good
+--
+module Crypto.Random.Entropy.Unsafe
+    ( replenish
+    , module Crypto.Random.Entropy.Backend
+    ) where
+
+import Data.Word (Word8)
+import Foreign.Ptr (Ptr, plusPtr)
+import Crypto.Random.Entropy.Backend
+
+-- | Refill the entropy in a buffer
+--
+-- Call each entropy backend in turn until the buffer has
+-- been replenished.
+--
+-- If the buffer cannot be refill after 3 loopings, this will raise
+-- an User Error exception
+replenish :: Int -> [EntropyBackend] -> Ptr Word8 -> IO ()
+replenish _        []       _   = fail "cryptonite: random: cannot get any source of entropy on this system"
+replenish poolSize backends ptr = loop 0 backends ptr poolSize
+  where loop :: Int -> [EntropyBackend] -> Ptr Word8 -> Int -> IO ()
+        loop retry [] p n | n == 0     = return ()
+                          | retry == 3 = error "cryptonite: random: cannot fully replenish"
+                          | otherwise  = loop (retry+1) backends p n
+        loop _     (_:_)  _ 0 = return ()
+        loop retry (b:bs) p n = do
+            r <- gatherBackend b p n
+            loop retry bs (p `plusPtr` r) (n - r)

bundled/Crypto/Random/Entropy/Windows.hs

@@ -0,0 +1,103 @@
+-- |
+-- Module      : Crypto.Random.Entropy.Windows
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : experimental
+-- Portability : Good
+--
+-- Code originally from the entropy package and thus is:
+--   Copyright (c) Thomas DuBuisson.
+--
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE CPP #-}
+module Crypto.Random.Entropy.Windows
+    ( WinCryptoAPI
+    ) where
+
+import Data.Int (Int32)
+import Data.Word
+import Foreign.C.String (CString, withCString)
+import Foreign.Ptr (Ptr, nullPtr)
+import Foreign.Marshal.Alloc (alloca)
+import Foreign.Marshal.Utils (toBool)
+import Foreign.Storable (peek)
+import System.Win32.Types (getLastError)
+
+import Crypto.Random.Entropy.Source
+
+
+-- | Handle to Windows crypto API for random generation
+data WinCryptoAPI = WinCryptoAPI
+
+instance EntropySource WinCryptoAPI where
+    entropyOpen = do
+        mctx <- cryptAcquireCtx
+        maybe (return Nothing) (\ctx -> cryptReleaseCtx ctx >> return (Just WinCryptoAPI)) mctx
+    entropyGather WinCryptoAPI ptr n = do
+        mctx <- cryptAcquireCtx
+        case mctx of
+            Nothing  -> do
+                lastError <- getLastError
+                fail $ "cannot re-grab win crypto api: error " ++ show lastError
+            Just ctx -> do
+                r <- cryptGenRandom ctx ptr n
+                cryptReleaseCtx ctx
+                return r
+    entropyClose WinCryptoAPI = return ()
+
+
+type DWORD = Word32
+type BOOL  = Int32
+type BYTE  = Word8
+
+#if defined(ARCH_X86)
+# define WINDOWS_CCONV stdcall
+type CryptCtx = Word32
+#elif defined(ARCH_X86_64)
+# define WINDOWS_CCONV ccall
+type CryptCtx = Word64
+#else
+# error Unknown mingw32 arch
+#endif
+
+-- Declare the required CryptoAPI imports
+foreign import WINDOWS_CCONV unsafe "CryptAcquireContextA"
+   c_cryptAcquireCtx :: Ptr CryptCtx -> CString -> CString -> DWORD -> DWORD -> IO BOOL
+foreign import WINDOWS_CCONV unsafe "CryptGenRandom"
+   c_cryptGenRandom :: CryptCtx -> DWORD -> Ptr BYTE -> IO BOOL
+foreign import WINDOWS_CCONV unsafe "CryptReleaseContext"
+   c_cryptReleaseCtx :: CryptCtx -> DWORD -> IO BOOL
+
+
+-- Define the constants we need from WinCrypt.h
+msDefProv :: String
+msDefProv = "Microsoft Base Cryptographic Provider v1.0"
+
+provRSAFull :: DWORD
+provRSAFull = 1
+
+cryptVerifyContext :: DWORD
+cryptVerifyContext = 0xF0000000
+
+cryptAcquireCtx :: IO (Maybe CryptCtx)
+cryptAcquireCtx =
+    alloca $ \handlePtr ->
+    withCString msDefProv $ \provName -> do
+        r <- toBool `fmap` c_cryptAcquireCtx handlePtr nullPtr provName provRSAFull cryptVerifyContext
+        if r
+            then Just `fmap` peek handlePtr
+            else return Nothing
+
+cryptGenRandom :: CryptCtx -> Ptr Word8 -> Int -> IO Int
+cryptGenRandom h buf n = do
+    success <- toBool `fmap` c_cryptGenRandom h (fromIntegral n) buf
+    return $ if success then n else 0
+
+cryptReleaseCtx :: CryptCtx -> IO ()
+cryptReleaseCtx h = do
+    success <- toBool `fmap` c_cryptReleaseCtx h 0
+    if success
+        then return ()
+        else do
+            lastError <- getLastError
+            fail $ "cryptReleaseCtx: error " ++ show lastError

bundled/Crypto/Random/EntropyPool.hs

@@ -0,0 +1,71 @@
+-- |
+-- Module      : Crypto.Random.EntropyPool
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : experimental
+-- Portability : Good
+--
+module Crypto.Random.EntropyPool
+    ( EntropyPool
+    , createEntropyPool
+    , createEntropyPoolWith
+    , getEntropyFrom
+    ) where
+
+import           Control.Concurrent.MVar
+import           Crypto.Random.Entropy.Unsafe
+import           Crypto.Internal.ByteArray (ByteArray, ScrubbedBytes)
+import qualified Crypto.Internal.ByteArray as B
+import           Data.Word (Word8)
+import           Data.Maybe (catMaybes)
+import           Foreign.Marshal.Utils (copyBytes)
+import           Foreign.Ptr (plusPtr, Ptr)
+
+-- | Pool of Entropy. Contains a self-mutating pool of entropy,
+-- that is always guaranteed to contain data.
+data EntropyPool = EntropyPool [EntropyBackend] (MVar Int) ScrubbedBytes
+
+-- size of entropy pool by default
+defaultPoolSize :: Int
+defaultPoolSize = 4096
+
+-- | Create a new entropy pool of a specific size
+--
+-- While you can create as many entropy pools as you want,
+-- the pool can be shared between multiples RNGs.
+createEntropyPoolWith :: Int -> [EntropyBackend] -> IO EntropyPool
+createEntropyPoolWith poolSize backends = do
+    m  <- newMVar 0
+    sm <- B.alloc poolSize (replenish poolSize backends)
+    return $ EntropyPool backends m sm
+
+-- | Create a new entropy pool with a default size.
+--
+-- While you can create as many entropy pools as you want,
+-- the pool can be shared between multiples RNGs.
+createEntropyPool :: IO EntropyPool
+createEntropyPool = do
+    backends <- catMaybes `fmap` sequence supportedBackends
+    createEntropyPoolWith defaultPoolSize backends
+
+-- | Put a chunk of the entropy pool into a buffer
+getEntropyPtr :: EntropyPool -> Int -> Ptr Word8 -> IO ()
+getEntropyPtr (EntropyPool backends posM sm) n outPtr =
+    B.withByteArray sm $ \entropyPoolPtr ->
+        modifyMVar_ posM $ \pos ->
+            copyLoop outPtr entropyPoolPtr pos n
+  where poolSize = B.length sm
+        copyLoop d s pos left
+            | left == 0 = return pos
+            | otherwise = do
+                wrappedPos <-
+                    if pos == poolSize
+                        then replenish poolSize backends s >> return 0
+                        else return pos
+                let m = min (poolSize - wrappedPos) left
+                copyBytes d (s `plusPtr` wrappedPos) m
+                copyLoop (d `plusPtr` m) s (wrappedPos + m) (left - m)
+
+-- | Grab a chunk of entropy from the entropy pool.
+getEntropyFrom :: ByteArray byteArray => EntropyPool -> Int -> IO byteArray
+getEntropyFrom pool n = B.alloc n (getEntropyPtr pool n)

bundled/Crypto/Random/Probabilistic.hs

@@ -0,0 +1,28 @@
+-- |
+-- Module      : Crypto.Random.Probabilistic
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : experimental
+-- Portability : Good
+--
+module Crypto.Random.Probabilistic
+    ( probabilistic
+    ) where
+
+import Crypto.Internal.Compat
+import Crypto.Random.Types
+import Crypto.Random
+
+-- | This create a random number generator out of thin air with
+-- the system entropy; don't generally use as the IO is not exposed
+-- this can have unexpected random for.
+-- 
+-- This is useful for probabilistic algorithm like Miller Rabin
+-- probably prime algorithm, given appropriate choice of the heuristic
+--
+-- Generally, it's advised not to use this function.
+probabilistic :: MonadPseudoRandom ChaChaDRG a -> a
+probabilistic f = fst $ withDRG drg f
+  where {-# NOINLINE drg #-}
+        drg = unsafeDoIO drgNew
+{-# NOINLINE probabilistic #-}

bundled/Crypto/Random/SystemDRG.hs

@@ -0,0 +1,63 @@
+-- |
+-- 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 = 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)

bundled/Crypto/Random/Types.hs

@@ -0,0 +1,60 @@
+-- |
+-- Module      : Crypto.Random.Types
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : experimental
+-- Portability : Good
+--
+module Crypto.Random.Types
+    (
+      MonadRandom(..)
+    , MonadPseudoRandom
+    , DRG(..)
+    , withDRG
+    ) where
+
+import Crypto.Random.Entropy
+import Crypto.Internal.ByteArray
+
+-- | A monad constraint that allows to generate random bytes
+class Monad m => MonadRandom m where
+    getRandomBytes :: ByteArray byteArray => Int -> m byteArray
+
+-- | A Deterministic Random Generator (DRG) class
+class DRG gen where
+    -- | Generate N bytes of randomness from a DRG
+    randomBytesGenerate :: ByteArray byteArray => Int -> gen -> (byteArray, gen)
+
+instance MonadRandom IO where
+    getRandomBytes = getEntropy
+
+-- | A simple Monad class very similar to a State Monad
+-- with the state being a DRG.
+newtype MonadPseudoRandom gen a = MonadPseudoRandom
+    { runPseudoRandom :: gen -> (a, gen)
+    }
+
+instance DRG gen => Functor (MonadPseudoRandom gen) where
+    fmap f m = MonadPseudoRandom $ \g1 ->
+        let (a, g2) = runPseudoRandom m g1 in (f a, g2)
+
+instance DRG gen => Applicative (MonadPseudoRandom gen) where
+    pure a     = MonadPseudoRandom $ \g -> (a, g)
+    (<*>) fm m = MonadPseudoRandom $ \g1 ->
+        let (f, g2) = runPseudoRandom fm g1
+            (a, g3) = runPseudoRandom m g2
+         in (f a, g3)
+
+instance DRG gen => Monad (MonadPseudoRandom gen) where
+    return      = pure
+    (>>=) m1 m2 = MonadPseudoRandom $ \g1 ->
+        let (a, g2) = runPseudoRandom m1 g1
+         in runPseudoRandom (m2 a) g2
+
+instance DRG gen => MonadRandom (MonadPseudoRandom gen) where
+    getRandomBytes n = MonadPseudoRandom (randomBytesGenerate n)
+
+-- | Run a pure computation with a Deterministic Random Generator
+-- in the 'MonadPseudoRandom'
+withDRG :: DRG gen => gen -> MonadPseudoRandom gen a -> (a, gen)
+withDRG gen m = runPseudoRandom m gen