-- |
-- Module      : Foundation.System.Entropy.Unix
-- License     : BSD-style
-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
-- Stability   : experimental
-- Portability : Good
--
{-# 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

-- | try to fill the ptr with the amount of data required.
-- Return the number of bytes, or a negative number otherwise
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 #-}

-- return 0 on success, !0 for failure
foreign import ccall unsafe "foundation_sysrandom_linux"
   c_sysrandom_linux :: Ptr Word8 -> CSize -> IO Int