{-# LANGUAGE CPP #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE DeriveDataTypeable #-}
module Crypto.Random.Entropy
( EntropyPool
, createEntropyPool
, createTestEntropyPool
, grabEntropyPtr
, grabEntropy
, grabEntropyIO
) where
import Control.Monad (when)
import Control.Concurrent.MVar
import System.IO.Unsafe (unsafePerformIO)
import Data.Maybe (catMaybes)
import Data.SecureMem
import Data.Typeable (Typeable)
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Internal as B
import Data.Word (Word8)
import Foreign.Marshal.Utils (copyBytes)
import Foreign.Ptr (plusPtr, Ptr)
import Foreign.ForeignPtr (withForeignPtr)
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
supportedBackends :: [IO (Maybe EntropyBackend)]
supportedBackends :: [IO (Maybe EntropyBackend)]
supportedBackends =
[
#ifdef SUPPORT_RDRAND
openBackend (undefined :: RDRand),
#endif
#ifdef WINDOWS
openBackend (undefined :: WinCryptoAPI)
#else
DevRandom -> IO (Maybe EntropyBackend)
forall b. EntropySource b => b -> IO (Maybe EntropyBackend)
openBackend (DevRandom
forall a. HasCallStack => a
undefined :: DevRandom), DevURandom -> IO (Maybe EntropyBackend)
forall b. EntropySource b => b -> IO (Maybe EntropyBackend)
openBackend (DevURandom
forall a. HasCallStack => a
undefined :: DevURandom)
#endif
]
data EntropyBackend = forall b . EntropySource b => EntropyBackend b
newtype TestEntropySource = TestEntropySource ByteString
instance EntropySource TestEntropySource where
entropyOpen :: IO (Maybe TestEntropySource)
entropyOpen = Maybe TestEntropySource -> IO (Maybe TestEntropySource)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe TestEntropySource
forall a. Maybe a
Nothing
entropyGather :: TestEntropySource -> Ptr Word8 -> Int -> IO Int
entropyGather (TestEntropySource bs :: ByteString
bs) dst :: Ptr Word8
dst n :: Int
n
| Int
len Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 1 = Ptr Word8 -> Word8 -> CSize -> IO (Ptr Word8)
B.memset Ptr Word8
dst (ByteString -> Int -> Word8
B.index ByteString
bs 0) (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n) IO (Ptr Word8) -> IO Int -> IO Int
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
n
| Bool
otherwise = do ForeignPtr Word8 -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
fptr ((Ptr Word8 -> IO ()) -> IO ()) -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ptr :: Ptr Word8
ptr -> Ptr Word8 -> Ptr Word8 -> Int -> IO ()
loop Ptr Word8
dst (Ptr Word8
ptr Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
o) Int
n
Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
n
where (B.PS fptr :: ForeignPtr Word8
fptr o :: Int
o len :: Int
len) = ByteString
bs
loop :: Ptr Word8 -> Ptr Word8 -> Int -> IO ()
loop d :: Ptr Word8
d s :: Ptr Word8
s i :: Int
i
| Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
len = Ptr Word8 -> Ptr Word8 -> Int -> IO ()
B.memcpy Ptr Word8
d Ptr Word8
s (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i)
| Bool
otherwise = Ptr Word8 -> Ptr Word8 -> Int -> IO ()
B.memcpy Ptr Word8
d Ptr Word8
s (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len) IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Ptr Word8 -> Ptr Word8 -> Int -> IO ()
loop (Ptr Word8
d Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
len) Ptr Word8
s (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
len)
entropyClose :: TestEntropySource -> IO ()
entropyClose _ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
openBackend :: EntropySource b => b -> IO (Maybe EntropyBackend)
openBackend :: b -> IO (Maybe EntropyBackend)
openBackend b :: b
b = (b -> EntropyBackend) -> Maybe b -> Maybe EntropyBackend
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> EntropyBackend
forall b. EntropySource b => b -> EntropyBackend
EntropyBackend (Maybe b -> Maybe EntropyBackend)
-> IO (Maybe b) -> IO (Maybe EntropyBackend)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` b -> IO (Maybe b)
forall b. EntropySource b => b -> IO (Maybe b)
callOpen b
b
where callOpen :: EntropySource b => b -> IO (Maybe b)
callOpen :: b -> IO (Maybe b)
callOpen _ = IO (Maybe b)
forall a. EntropySource a => IO (Maybe a)
entropyOpen
gatherBackend :: EntropyBackend -> Ptr Word8 -> Int -> IO Int
gatherBackend :: EntropyBackend -> Ptr Word8 -> Int -> IO Int
gatherBackend (EntropyBackend backend :: b
backend) ptr :: Ptr Word8
ptr n :: Int
n = b -> Ptr Word8 -> Int -> IO Int
forall a. EntropySource a => a -> Ptr Word8 -> Int -> IO Int
entropyGather b
backend Ptr Word8
ptr Int
n
data EntropyPool = EntropyPool [EntropyBackend] (MVar Int) SecureMem
deriving Typeable
defaultPoolSize :: Int
defaultPoolSize :: Int
defaultPoolSize = 4096
createEntropyPoolWith :: Int -> [EntropyBackend] -> IO EntropyPool
createEntropyPoolWith :: Int -> [EntropyBackend] -> IO EntropyPool
createEntropyPoolWith poolSize :: Int
poolSize backends :: [EntropyBackend]
backends = do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([EntropyBackend] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [EntropyBackend]
backends) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "cannot get any source of entropy on this system"
SecureMem
sm <- Int -> IO SecureMem
allocateSecureMem Int
poolSize
MVar Int
m <- Int -> IO (MVar Int)
forall a. a -> IO (MVar a)
newMVar 0
SecureMem -> (Ptr Word8 -> IO ()) -> IO ()
forall b. SecureMem -> (Ptr Word8 -> IO b) -> IO b
withSecureMemPtr SecureMem
sm ((Ptr Word8 -> IO ()) -> IO ()) -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> [EntropyBackend] -> Ptr Word8 -> IO ()
replenish Int
poolSize [EntropyBackend]
backends
EntropyPool -> IO EntropyPool
forall (m :: * -> *) a. Monad m => a -> m a
return (EntropyPool -> IO EntropyPool) -> EntropyPool -> IO EntropyPool
forall a b. (a -> b) -> a -> b
$ [EntropyBackend] -> MVar Int -> SecureMem -> EntropyPool
EntropyPool [EntropyBackend]
backends MVar Int
m SecureMem
sm
createEntropyPool :: IO EntropyPool
createEntropyPool :: IO EntropyPool
createEntropyPool = 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
Int -> [EntropyBackend] -> IO EntropyPool
createEntropyPoolWith Int
defaultPoolSize [EntropyBackend]
backends
createTestEntropyPool :: ByteString -> EntropyPool
createTestEntropyPool :: ByteString -> EntropyPool
createTestEntropyPool bs :: ByteString
bs
| ByteString -> Bool
B.null ByteString
bs = String -> EntropyPool
forall a. HasCallStack => String -> a
error "cannot create entropy pool from an empty bytestring"
| Bool
otherwise = IO EntropyPool -> EntropyPool
forall a. IO a -> a
unsafePerformIO (IO EntropyPool -> EntropyPool) -> IO EntropyPool -> EntropyPool
forall a b. (a -> b) -> a -> b
$ Int -> [EntropyBackend] -> IO EntropyPool
createEntropyPoolWith Int
defaultPoolSize [TestEntropySource -> EntropyBackend
forall b. EntropySource b => b -> EntropyBackend
EntropyBackend (TestEntropySource -> EntropyBackend)
-> TestEntropySource -> EntropyBackend
forall a b. (a -> b) -> a -> b
$ ByteString -> TestEntropySource
TestEntropySource ByteString
bs]
grabEntropyPtr :: Int -> EntropyPool -> Ptr Word8 -> IO ()
grabEntropyPtr :: Int -> EntropyPool -> Ptr Word8 -> IO ()
grabEntropyPtr n :: Int
n (EntropyPool backends :: [EntropyBackend]
backends posM :: MVar Int
posM sm :: SecureMem
sm) outPtr :: Ptr Word8
outPtr =
SecureMem -> (Ptr Word8 -> IO ()) -> IO ()
forall b. SecureMem -> (Ptr Word8 -> IO b) -> IO b
withSecureMemPtr SecureMem
sm ((Ptr Word8 -> IO ()) -> IO ()) -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \entropyPoolPtr :: Ptr Word8
entropyPoolPtr ->
MVar Int -> (Int -> IO Int) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar Int
posM ((Int -> IO Int) -> IO ()) -> (Int -> IO Int) -> IO ()
forall a b. (a -> b) -> a -> b
$ \pos :: Int
pos ->
Ptr Word8 -> Ptr Word8 -> Int -> Int -> IO Int
forall b. Ptr b -> Ptr Word8 -> Int -> Int -> IO Int
copyLoop Ptr Word8
outPtr Ptr Word8
entropyPoolPtr Int
pos Int
n
where poolSize :: Int
poolSize = SecureMem -> Int
secureMemGetSize SecureMem
sm
copyLoop :: Ptr b -> Ptr Word8 -> Int -> Int -> IO Int
copyLoop d :: Ptr b
d s :: Ptr Word8
s pos :: Int
pos left :: Int
left
| Int
left Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 = Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
pos
| Bool
otherwise = do
Int
wrappedPos <-
if Int
pos Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
poolSize
then Int -> [EntropyBackend] -> Ptr Word8 -> IO ()
replenish Int
poolSize [EntropyBackend]
backends Ptr Word8
s IO () -> IO Int -> IO Int
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return 0
else Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
pos
let m :: Int
m = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int
poolSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
wrappedPos) Int
left
Ptr b -> Ptr b -> Int -> IO ()
forall a. Ptr a -> Ptr a -> Int -> IO ()
copyBytes Ptr b
d (Ptr Word8
s Ptr Word8 -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
wrappedPos) Int
m
Ptr b -> Ptr Word8 -> Int -> Int -> IO Int
copyLoop (Ptr b
d Ptr b -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
m) Ptr Word8
s (Int
wrappedPos Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
m) (Int
left Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
m)
grabEntropyIO :: Int -> EntropyPool -> IO SecureMem
grabEntropyIO :: Int -> EntropyPool -> IO SecureMem
grabEntropyIO n :: Int
n pool :: EntropyPool
pool = do
SecureMem
out <- Int -> IO SecureMem
allocateSecureMem Int
n
SecureMem -> (Ptr Word8 -> IO ()) -> IO ()
forall b. SecureMem -> (Ptr Word8 -> IO b) -> IO b
withSecureMemPtr SecureMem
out ((Ptr Word8 -> IO ()) -> IO ()) -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> EntropyPool -> Ptr Word8 -> IO ()
grabEntropyPtr Int
n EntropyPool
pool
SecureMem -> IO SecureMem
forall (m :: * -> *) a. Monad m => a -> m a
return (SecureMem -> IO SecureMem) -> SecureMem -> IO SecureMem
forall a b. (a -> b) -> a -> b
$ SecureMem
out
{-# NOINLINE grabEntropy #-}
grabEntropy :: Int -> EntropyPool -> SecureMem
grabEntropy :: Int -> EntropyPool -> SecureMem
grabEntropy n :: Int
n pool :: EntropyPool
pool = IO SecureMem -> SecureMem
forall a. IO a -> a
unsafePerformIO (IO SecureMem -> SecureMem) -> IO SecureMem -> SecureMem
forall a b. (a -> b) -> a -> b
$ Int -> EntropyPool -> IO SecureMem
grabEntropyIO Int
n EntropyPool
pool
replenish :: Int -> [EntropyBackend] -> Ptr Word8 -> IO ()
replenish :: Int -> [EntropyBackend] -> Ptr Word8 -> IO ()
replenish poolSize :: Int
poolSize backends :: [EntropyBackend]
backends ptr :: Ptr Word8
ptr = Int -> [EntropyBackend] -> Ptr Word8 -> Int -> IO ()
loop 0 [EntropyBackend]
backends Ptr Word8
ptr Int
poolSize
where loop :: Int -> [EntropyBackend] -> Ptr Word8 -> Int -> IO ()
loop :: Int -> [EntropyBackend] -> Ptr Word8 -> Int -> IO ()
loop retry :: Int
retry [] p :: Ptr Word8
p n :: Int
n | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Int
retry Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 3 = String -> IO ()
forall a. HasCallStack => String -> a
error "cannot fully replenish"
| Bool
otherwise = Int -> [EntropyBackend] -> Ptr Word8 -> Int -> IO ()
loop (Int
retryInt -> Int -> Int
forall a. Num a => a -> a -> a
+1) [EntropyBackend]
backends Ptr Word8
p Int
n
loop _ (_:_) _ 0 = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
loop retry :: Int
retry (b :: EntropyBackend
b:bs :: [EntropyBackend]
bs) p :: Ptr Word8
p n :: Int
n = do
Int
r <- EntropyBackend -> Ptr Word8 -> Int -> IO Int
gatherBackend EntropyBackend
b Ptr Word8
p Int
n
Int -> [EntropyBackend] -> Ptr Word8 -> Int -> IO ()
loop Int
retry [EntropyBackend]
bs (Ptr Word8
p Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
r) (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
r)