-- |
-- Module      : Crypto.Random.Entropy.Unix
-- License     : BSD-style
-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
-- Stability   : experimental
-- Portability : Good
--
{-# 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.Posix.Types (Fd)
import System.Posix.IO

type H = Fd
type DeviceName = String

-- | Entropy device /dev/random on unix system 
newtype DevRandom  = DevRandom DeviceName

-- | Entropy device /dev/urandom on unix system 
newtype DevURandom = DevURandom DeviceName

instance EntropySource DevRandom where
    entropyOpen :: IO (Maybe DevRandom)
entropyOpen = (DeviceName -> DevRandom) -> Maybe DeviceName -> Maybe DevRandom
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DeviceName -> DevRandom
DevRandom (Maybe DeviceName -> Maybe DevRandom)
-> IO (Maybe DeviceName) -> IO (Maybe 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 =
        DeviceName -> (H -> IO Int) -> IO Int
forall a. DeviceName -> (H -> IO a) -> IO a
withDev DeviceName
name ((H -> IO Int) -> IO Int) -> (H -> IO Int) -> IO Int
forall a b. (a -> b) -> a -> b
$ \H
h -> H -> Ptr Word8 -> Int -> IO Int
gatherDevEntropy H
h Ptr Word8
ptr Int
n
    entropyClose :: DevRandom -> IO ()
entropyClose (DevRandom DeviceName
_)  = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

instance EntropySource DevURandom where
    entropyOpen :: IO (Maybe DevURandom)
entropyOpen = (DeviceName -> DevURandom) -> Maybe DeviceName -> Maybe DevURandom
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DeviceName -> DevURandom
DevURandom (Maybe DeviceName -> Maybe DevURandom)
-> IO (Maybe DeviceName) -> IO (Maybe 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 =
        DeviceName -> (H -> IO Int) -> IO Int
forall a. DeviceName -> (H -> IO a) -> IO a
withDev DeviceName
name ((H -> IO Int) -> IO Int) -> (H -> IO Int) -> IO Int
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
_)  = () -> IO ()
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 -> Maybe DeviceName -> IO (Maybe DeviceName)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe DeviceName
forall a. Maybe a
Nothing
        Just H
h  -> H -> IO ()
closeDev H
h IO () -> IO (Maybe DeviceName) -> IO (Maybe DeviceName)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe DeviceName -> IO (Maybe DeviceName)
forall (m :: * -> *) a. Monad m => a -> m a
return (DeviceName -> Maybe DeviceName
forall a. a -> Maybe a
Just DeviceName
filepath)

openDev :: String -> IO (Maybe H)
openDev :: DeviceName -> IO (Maybe H)
openDev DeviceName
filepath = (H -> Maybe H
forall a. a -> Maybe a
Just (H -> Maybe H) -> IO H -> IO (Maybe H)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` DeviceName -> OpenMode -> Maybe FileMode -> OpenFileFlags -> IO H
openFd DeviceName
filepath OpenMode
ReadOnly Maybe FileMode
forall a. Maybe a
Nothing OpenFileFlags
fileFlags)
    IO (Maybe H) -> (IOException -> IO (Maybe H)) -> IO (Maybe H)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` \(IOException
_ :: IOException) -> Maybe H -> IO (Maybe H)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe H
forall a. Maybe a
Nothing
  where fileFlags :: OpenFileFlags
fileFlags = OpenFileFlags
defaultFileFlags { nonBlock :: Bool
nonBlock = Bool
True }

withDev :: String -> (H -> IO a) -> IO a
withDev :: DeviceName -> (H -> IO a) -> IO a
withDev DeviceName
filepath H -> IO a
f = DeviceName -> IO (Maybe H)
openDev DeviceName
filepath IO (Maybe H) -> (Maybe H -> IO a) -> IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Maybe H
h ->
    case Maybe H
h of
        Maybe H
Nothing -> DeviceName -> IO a
forall a. HasCallStack => DeviceName -> a
error (DeviceName
"device " DeviceName -> DeviceName -> DeviceName
forall a. [a] -> [a] -> [a]
++ DeviceName
filepath DeviceName -> DeviceName -> DeviceName
forall a. [a] -> [a] -> [a]
++ DeviceName
" cannot be grabbed")
        Just H
fd -> H -> IO a
f H
fd IO a -> (a -> IO a) -> IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
r -> (H -> IO ()
closeDev H
fd IO () -> IO a -> IO a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r)

closeDev :: H -> IO ()
closeDev :: H -> IO ()
closeDev H
h = H -> IO ()
closeFd H
h

gatherDevEntropy :: H -> Ptr Word8 -> Int -> IO Int
gatherDevEntropy :: H -> Ptr Word8 -> Int -> IO Int
gatherDevEntropy H
h Ptr Word8
ptr Int
sz =
     (ByteCount -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteCount -> Int) -> IO ByteCount -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` H -> Ptr Word8 -> ByteCount -> IO ByteCount
fdReadBuf H
h Ptr Word8
ptr (Int -> ByteCount
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sz))
    IO Int -> (IOException -> IO Int) -> IO Int
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` \(IOException
_ :: IOException) -> Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
0