make the entropy gathering simpler for certain setup, and cleanup a bit
This commit is contained in:
parent
4e955ad505
commit
6005eca7bd
@ -10,11 +10,11 @@
|
||||
module Crypto.Random.Entropy
|
||||
( EntropyPool
|
||||
, createEntropyPool
|
||||
, grabEntropyPtr
|
||||
, grabEntropy
|
||||
, getEntropyPtr
|
||||
, getEntropyFrom
|
||||
, getEntropy
|
||||
) where
|
||||
|
||||
import Control.Monad (when)
|
||||
import Control.Concurrent.MVar
|
||||
import Data.Maybe (catMaybes)
|
||||
import Data.SecureMem
|
||||
@ -22,6 +22,8 @@ import Data.Word (Word8)
|
||||
import Foreign.Marshal.Utils (copyBytes)
|
||||
import Foreign.Ptr (plusPtr, Ptr)
|
||||
|
||||
import Crypto.Random.Types
|
||||
|
||||
import Crypto.Random.Entropy.Source
|
||||
#ifdef SUPPORT_RDRAND
|
||||
import Crypto.Random.Entropy.RDRand
|
||||
@ -68,7 +70,6 @@ defaultPoolSize = 4096
|
||||
-- While you can create as many entropy pool as you want, the pool can be shared between multiples RNGs.
|
||||
createEntropyPoolWith :: Int -> [EntropyBackend] -> IO EntropyPool
|
||||
createEntropyPoolWith poolSize backends = do
|
||||
when (null backends) $ fail "cannot get any source of entropy on this system"
|
||||
sm <- allocateSecureMem poolSize
|
||||
m <- newMVar 0
|
||||
withSecureMemPtr sm $ replenish poolSize backends
|
||||
@ -83,8 +84,8 @@ createEntropyPool = do
|
||||
createEntropyPoolWith defaultPoolSize backends
|
||||
|
||||
-- | Put a chunk of the entropy pool into a buffer
|
||||
grabEntropyPtr :: Int -> EntropyPool -> Ptr Word8 -> IO ()
|
||||
grabEntropyPtr n (EntropyPool backends posM sm) outPtr =
|
||||
getEntropyPtr :: EntropyPool -> Int -> Ptr Word8 -> IO ()
|
||||
getEntropyPtr (EntropyPool backends posM sm) n outPtr =
|
||||
withSecureMemPtr sm $ \entropyPoolPtr ->
|
||||
modifyMVar_ posM $ \pos ->
|
||||
copyLoop outPtr entropyPoolPtr pos n
|
||||
@ -101,17 +102,27 @@ grabEntropyPtr n (EntropyPool backends posM sm) outPtr =
|
||||
copyLoop (d `plusPtr` m) s (wrappedPos + m) (left - m)
|
||||
|
||||
-- | Grab a chunk of entropy from the entropy pool.
|
||||
grabEntropy :: Int -> EntropyPool -> IO SecureMem
|
||||
grabEntropy n pool = do
|
||||
getEntropyFrom :: EntropyPool -> Int -> IO Random
|
||||
getEntropyFrom pool n = do
|
||||
out <- allocateSecureMem n
|
||||
withSecureMemPtr out $ grabEntropyPtr n pool
|
||||
return $ out
|
||||
withSecureMemPtr out $ getEntropyPtr pool n
|
||||
return $ Random out
|
||||
|
||||
-- | Get some entropy from the system source of entropy
|
||||
getEntropy :: Int -> IO Random
|
||||
getEntropy n = do
|
||||
backends <- catMaybes `fmap` sequence supportedBackends
|
||||
out <- allocateSecureMem n
|
||||
withSecureMemPtr out $ replenish n backends
|
||||
return $ Random out
|
||||
|
||||
-- Refill the entropy in a buffer
|
||||
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 "cannot fully replenish"
|
||||
| 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
|
||||
|
||||
@ -16,10 +16,10 @@ import Data.Word (Word8)
|
||||
import Crypto.Random.Entropy.Source
|
||||
import Control.Exception as E
|
||||
|
||||
import System.Posix.Types (Fd)
|
||||
import System.Posix.IO
|
||||
--import System.Posix.Types (Fd)
|
||||
import System.IO
|
||||
|
||||
type H = Fd
|
||||
type H = Handle
|
||||
type DeviceName = String
|
||||
|
||||
-- | Entropy device /dev/random on unix system
|
||||
@ -48,9 +48,11 @@ testOpen filepath = do
|
||||
Just h -> closeDev h >> return (Just filepath)
|
||||
|
||||
openDev :: String -> IO (Maybe H)
|
||||
openDev filepath = (Just `fmap` openFd filepath ReadOnly Nothing fileFlags)
|
||||
`E.catch` \(_ :: IOException) -> return Nothing
|
||||
where fileFlags = defaultFileFlags { nonBlock = True }
|
||||
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 ->
|
||||
@ -59,9 +61,9 @@ withDev filepath f = openDev filepath >>= \h ->
|
||||
Just fd -> f fd >>= \r -> (closeDev fd >> return r)
|
||||
|
||||
closeDev :: H -> IO ()
|
||||
closeDev h = closeFd h
|
||||
closeDev h = hClose h
|
||||
|
||||
gatherDevEntropy :: H -> Ptr Word8 -> Int -> IO Int
|
||||
gatherDevEntropy h ptr sz =
|
||||
(fromIntegral `fmap` fdReadBuf h ptr (fromIntegral sz))
|
||||
(fromIntegral `fmap` hGetBufSome h ptr (fromIntegral sz))
|
||||
`E.catch` \(_ :: IOException) -> return 0
|
||||
|
||||
17
Crypto/Random/Types.hs
Normal file
17
Crypto/Random/Types.hs
Normal file
@ -0,0 +1,17 @@
|
||||
-- |
|
||||
-- Module : Crypto.Random.Types
|
||||
-- License : BSD-style
|
||||
-- Maintainer : Vincent Hanquez <vincent@snarc.org>
|
||||
-- Stability : experimental
|
||||
-- Portability : Good
|
||||
--
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
module Crypto.Random.Types
|
||||
( Random(..)
|
||||
) where
|
||||
|
||||
import Data.Byteable
|
||||
import Data.SecureMem
|
||||
|
||||
newtype Random = Random SecureMem
|
||||
deriving (Eq, Byteable)
|
||||
@ -23,6 +23,7 @@ Library
|
||||
Exposed-modules: Crypto.Cipher.ChaCha
|
||||
Crypto.Cipher.Salsa
|
||||
Crypto.MAC.Poly1305
|
||||
Crypto.Random.Types
|
||||
Crypto.Random.Entropy
|
||||
Other-modules: Crypto.Random.Entropy.Source
|
||||
Build-depends: base >= 4 && < 5
|
||||
@ -48,7 +49,6 @@ Library
|
||||
Other-modules: Crypto.Random.Entropy.Windows
|
||||
extra-libraries: advapi32
|
||||
else
|
||||
Build-Depends: unix
|
||||
Other-modules: Crypto.Random.Entropy.Unix
|
||||
|
||||
Test-Suite test-cryptonite
|
||||
|
||||
Loading…
Reference in New Issue
Block a user