{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ForeignFunctionInterface #-}
module Foundation.System.Entropy.Unix
( EntropyCtx
, entropyOpen
, entropyGather
, entropyClose
, entropyMaximumSize
) where
import Foreign.Ptr
import Control.Exception as E
import Control.Monad
import System.IO
import System.IO.Unsafe (unsafePerformIO)
import Basement.Compat.Base
import Basement.Compat.C.Types
import Prelude (fromIntegral)
import Foundation.System.Entropy.Common
import Foundation.Numerical
data EntropyCtx =
EntropyCtx Handle
| EntropySyscall
entropyOpen :: IO EntropyCtx
entropyOpen :: IO EntropyCtx
entropyOpen = do
if Bool
supportSyscall
then EntropyCtx -> IO EntropyCtx
forall (m :: * -> *) a. Monad m => a -> m a
return EntropyCtx
EntropySyscall
else do
Maybe Handle
mh <- [Char] -> IO (Maybe Handle)
openDev [Char]
"/dev/urandom"
case Maybe Handle
mh of
Maybe Handle
Nothing -> EntropySystemMissing -> IO EntropyCtx
forall e a. Exception e => e -> IO a
E.throwIO EntropySystemMissing
EntropySystemMissing
Just Handle
h -> EntropyCtx -> IO EntropyCtx
forall (m :: * -> *) a. Monad m => a -> m a
return (EntropyCtx -> IO EntropyCtx) -> EntropyCtx -> IO EntropyCtx
forall a b. (a -> b) -> a -> b
$ Handle -> EntropyCtx
EntropyCtx Handle
h
entropyGather :: EntropyCtx -> Ptr Word8 -> Int -> IO Bool
entropyGather :: EntropyCtx -> Ptr Word8 -> Int -> IO Bool
entropyGather (EntropyCtx Handle
h) Ptr Word8
ptr Int
n = Handle -> Ptr Word8 -> Int -> IO Bool
gatherDevEntropy Handle
h Ptr Word8
ptr Int
n
entropyGather EntropyCtx
EntropySyscall Ptr Word8
ptr Int
n = Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
(==) Int
0 (Int -> Bool) -> IO Int -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr Word8 -> CSize -> IO Int
c_sysrandom_linux Ptr Word8
ptr (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)
entropyClose :: EntropyCtx -> IO ()
entropyClose :: EntropyCtx -> IO ()
entropyClose (EntropyCtx Handle
h) = Handle -> IO ()
hClose Handle
h
entropyClose EntropyCtx
EntropySyscall = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
entropyMaximumSize :: Int
entropyMaximumSize :: Int
entropyMaximumSize = Int
4096
openDev :: [Char] -> IO (Maybe Handle)
openDev :: [Char] -> IO (Maybe Handle)
openDev [Char]
filepath = (Handle -> Maybe Handle
forall a. a -> Maybe a
Just (Handle -> Maybe Handle) -> IO Handle -> IO (Maybe Handle)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` IO Handle
openAndNoBuffering) IO (Maybe Handle)
-> (IOException -> IO (Maybe Handle)) -> IO (Maybe Handle)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` \(IOException
_ :: IOException) -> Maybe Handle -> IO (Maybe Handle)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Handle
forall a. Maybe a
Nothing
where openAndNoBuffering :: IO Handle
openAndNoBuffering = do
Handle
h <- [Char] -> IOMode -> IO Handle
openBinaryFile [Char]
filepath IOMode
ReadMode
Handle -> BufferMode -> IO ()
hSetBuffering Handle
h BufferMode
NoBuffering
Handle -> IO Handle
forall (m :: * -> *) a. Monad m => a -> m a
return Handle
h
gatherDevEntropy :: Handle -> Ptr Word8 -> Int -> IO Bool
gatherDevEntropy :: Handle -> Ptr Word8 -> Int -> IO Bool
gatherDevEntropy Handle
h Ptr Word8
ptr Int
sz = Ptr Word8 -> Int -> IO Bool
loop Ptr Word8
ptr Int
sz IO Bool -> (IOException -> IO Bool) -> IO Bool
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` IOException -> IO Bool
failOnException
where
loop :: Ptr Word8 -> Int -> IO Bool
loop Ptr Word8
_ Int
0 = Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
loop Ptr Word8
p Int
n = do
Int
r <- Handle -> Ptr Word8 -> Int -> IO Int
forall a. Handle -> Ptr a -> Int -> IO Int
hGetBufSome Handle
h Ptr Word8
p Int
n
if Int
r Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0
then Ptr Word8 -> Int -> IO Bool
loop (Ptr Word8
p Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
r) (Int
n Int -> Int -> Difference Int
forall a. Subtractive a => a -> a -> Difference a
- Int
r)
else Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
failOnException :: E.IOException -> IO Bool
failOnException :: IOException -> IO Bool
failOnException IOException
_ = Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
supportSyscall :: Bool
supportSyscall :: Bool
supportSyscall = IO Bool -> Bool
forall a. IO a -> a
unsafePerformIO (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
(==) Int
0 (Int -> Bool) -> IO Int -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr Word8 -> CSize -> IO Int
c_sysrandom_linux Ptr Word8
forall a. Ptr a
nullPtr CSize
0)
{-# NOINLINE supportSyscall #-}
foreign import ccall unsafe "foundation_sysrandom_linux"
c_sysrandom_linux :: Ptr Word8 -> CSize -> IO Int