{-# 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.IO
type H = Handle
type DeviceName = String
newtype DevRandom = DevRandom DeviceName
newtype DevURandom = DevURandom DeviceName
instance EntropySource DevRandom where
entropyOpen :: IO (Maybe DevRandom)
entropyOpen = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DeviceName -> DevRandom
DevRandom forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` DeviceName -> IO (Maybe DeviceName)
testOpen DeviceName
"/dev/random"
entropyGather :: DevRandom -> Ptr Word8 -> Int -> IO Int
entropyGather (DevRandom DeviceName
name) Ptr Word8
ptr Int
n =
forall a. DeviceName -> (H -> IO a) -> IO a
withDev DeviceName
name forall a b. (a -> b) -> a -> b
$ \H
h -> H -> Ptr Word8 -> Int -> IO Int
gatherDevEntropyNonBlock H
h Ptr Word8
ptr Int
n
entropyClose :: DevRandom -> IO ()
entropyClose (DevRandom DeviceName
_) = forall (m :: * -> *) a. Monad m => a -> m a
return ()
instance EntropySource DevURandom where
entropyOpen :: IO (Maybe DevURandom)
entropyOpen = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DeviceName -> DevURandom
DevURandom forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` DeviceName -> IO (Maybe DeviceName)
testOpen DeviceName
"/dev/urandom"
entropyGather :: DevURandom -> Ptr Word8 -> Int -> IO Int
entropyGather (DevURandom DeviceName
name) Ptr Word8
ptr Int
n =
forall a. DeviceName -> (H -> IO a) -> IO a
withDev DeviceName
name forall a b. (a -> b) -> a -> b
$ \H
h -> H -> Ptr Word8 -> Int -> IO Int
gatherDevEntropy H
h Ptr Word8
ptr Int
n
entropyClose :: DevURandom -> IO ()
entropyClose (DevURandom DeviceName
_) = forall (m :: * -> *) a. Monad m => a -> m a
return ()
testOpen :: DeviceName -> IO (Maybe DeviceName)
testOpen :: DeviceName -> IO (Maybe DeviceName)
testOpen DeviceName
filepath = do
Maybe H
d <- DeviceName -> IO (Maybe H)
openDev DeviceName
filepath
case Maybe H
d of
Maybe H
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Just H
h -> H -> IO ()
closeDev H
h forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just DeviceName
filepath)
openDev :: String -> IO (Maybe H)
openDev :: DeviceName -> IO (Maybe H)
openDev DeviceName
filepath = (forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` IO H
openAndNoBuffering) forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` \(IOException
_ :: IOException) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
where openAndNoBuffering :: IO H
openAndNoBuffering = do
H
h <- DeviceName -> IOMode -> IO H
openBinaryFile DeviceName
filepath IOMode
ReadMode
H -> BufferMode -> IO ()
hSetBuffering H
h BufferMode
NoBuffering
forall (m :: * -> *) a. Monad m => a -> m a
return H
h
withDev :: String -> (H -> IO a) -> IO a
withDev :: forall a. DeviceName -> (H -> IO a) -> IO a
withDev DeviceName
filepath H -> IO a
f = DeviceName -> IO (Maybe H)
openDev DeviceName
filepath forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Maybe H
h ->
case Maybe H
h of
Maybe H
Nothing -> forall a. HasCallStack => DeviceName -> a
error (DeviceName
"device " forall a. [a] -> [a] -> [a]
++ DeviceName
filepath forall a. [a] -> [a] -> [a]
++ DeviceName
" cannot be grabbed")
Just H
fd -> H -> IO a
f H
fd forall a b. IO a -> IO b -> IO a
`E.finally` H -> IO ()
closeDev H
fd
closeDev :: H -> IO ()
closeDev :: H -> IO ()
closeDev H
h = H -> IO ()
hClose H
h forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` \(IOException
_ :: IOException) -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
gatherDevEntropy :: H -> Ptr Word8 -> Int -> IO Int
gatherDevEntropy :: H -> Ptr Word8 -> Int -> IO Int
gatherDevEntropy H
h Ptr Word8
ptr Int
sz =
(forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall a. H -> Ptr a -> Int -> IO Int
hGetBufSome H
h Ptr Word8
ptr (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sz))
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` \(IOException
_ :: IOException) -> forall (m :: * -> *) a. Monad m => a -> m a
return Int
0
gatherDevEntropyNonBlock :: H -> Ptr Word8 -> Int -> IO Int
gatherDevEntropyNonBlock :: H -> Ptr Word8 -> Int -> IO Int
gatherDevEntropyNonBlock H
h Ptr Word8
ptr Int
sz =
(forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall a. H -> Ptr a -> Int -> IO Int
hGetBufNonBlocking H
h Ptr Word8
ptr (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sz))
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` \(IOException
_ :: IOException) -> forall (m :: * -> *) a. Monad m => a -> m a
return Int
0