{-# LANGUAGE ScopedTypeVariables #-}

-- |
-- Module      : Crypto.Random.Entropy.Unix
-- License     : BSD-style
-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
-- Stability   : experimental
-- Portability : Good
module Crypto.Random.Entropy.Unix (
    DevRandom,
    DevURandom,
) where

import Control.Exception as E
import Crypto.Random.Entropy.Source
import Data.Word (Word8)
import Foreign.Ptr

-- import System.Posix.Types (Fd)
import System.IO

type H = Handle
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 = ([Char] -> DevRandom) -> Maybe [Char] -> Maybe DevRandom
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Char] -> DevRandom
DevRandom (Maybe [Char] -> Maybe DevRandom)
-> IO (Maybe [Char]) -> IO (Maybe DevRandom)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` [Char] -> IO (Maybe [Char])
testOpen [Char]
"/dev/random"
    entropyGather :: DevRandom -> Ptr Word8 -> Int -> IO Int
entropyGather (DevRandom [Char]
name) Ptr Word8
ptr Int
n =
        [Char] -> (H -> IO Int) -> IO Int
forall a. [Char] -> (H -> IO a) -> IO a
withDev [Char]
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
gatherDevEntropyNonBlock H
h Ptr Word8
ptr Int
n
    entropyClose :: DevRandom -> IO ()
entropyClose (DevRandom [Char]
_) = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

instance EntropySource DevURandom where
    entropyOpen :: IO (Maybe DevURandom)
entropyOpen = ([Char] -> DevURandom) -> Maybe [Char] -> Maybe DevURandom
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Char] -> DevURandom
DevURandom (Maybe [Char] -> Maybe DevURandom)
-> IO (Maybe [Char]) -> IO (Maybe DevURandom)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` [Char] -> IO (Maybe [Char])
testOpen [Char]
"/dev/urandom"
    entropyGather :: DevURandom -> Ptr Word8 -> Int -> IO Int
entropyGather (DevURandom [Char]
name) Ptr Word8
ptr Int
n =
        [Char] -> (H -> IO Int) -> IO Int
forall a. [Char] -> (H -> IO a) -> IO a
withDev [Char]
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 [Char]
_) = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

testOpen :: DeviceName -> IO (Maybe DeviceName)
testOpen :: [Char] -> IO (Maybe [Char])
testOpen [Char]
filepath = do
    d <- [Char] -> IO (Maybe H)
openDev [Char]
filepath
    case d of
        Maybe H
Nothing -> Maybe [Char] -> IO (Maybe [Char])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [Char]
forall a. Maybe a
Nothing
        Just H
h -> H -> IO ()
closeDev H
h IO () -> IO (Maybe [Char]) -> IO (Maybe [Char])
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe [Char] -> IO (Maybe [Char])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
filepath)

openDev :: String -> IO (Maybe H)
openDev :: [Char] -> IO (Maybe H)
openDev [Char]
filepath =
    (H -> Maybe H
forall a. a -> Maybe a
Just (H -> Maybe H) -> IO H -> IO (Maybe H)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` IO H
openAndNoBuffering) 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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe H
forall a. Maybe a
Nothing
  where
    openAndNoBuffering :: IO H
openAndNoBuffering = do
        h <- [Char] -> IOMode -> IO H
openBinaryFile [Char]
filepath IOMode
ReadMode
        hSetBuffering h NoBuffering
        return h

withDev :: String -> (H -> IO a) -> IO a
withDev :: forall a. [Char] -> (H -> IO a) -> IO a
withDev [Char]
filepath H -> IO a
f =
    [Char] -> IO (Maybe H)
openDev [Char]
filepath IO (Maybe H) -> (Maybe H -> IO a) -> IO a
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Maybe H
h ->
        case Maybe H
h of
            Maybe H
Nothing -> [Char] -> IO a
forall a. HasCallStack => [Char] -> a
error ([Char]
"device " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
filepath [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" cannot be grabbed")
            Just H
fd -> H -> IO a
f H
fd IO a -> IO () -> IO a
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 IO () -> (IOException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` \(IOException
_ :: IOException) -> () -> IO ()
forall a. a -> IO a
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 =
    (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int) -> IO Int -> IO Int
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` H -> Ptr Word8 -> Int -> IO Int
forall a. H -> Ptr a -> Int -> IO Int
hGetBufSome H
h Ptr Word8
ptr (Int -> Int
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 a. a -> IO a
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 =
    (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int) -> IO Int -> IO Int
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` H -> Ptr Word8 -> Int -> IO Int
forall a. H -> Ptr a -> Int -> IO Int
hGetBufNonBlocking H
h Ptr Word8
ptr (Int -> Int
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
0