    -- |
    -- 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.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 = (DeviceName -> DevRandom) -> Maybe DeviceName -> Maybe DevRandom
    forall a b. (a -> b) -> Maybe a -> Maybe b
    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 a b. (a -> b) -> IO a -> IO b
    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
    gatherDevEntropyNonBlock H
    h Ptr Word8
    ptr Int
    n
        entropyClose :: DevRandom -> IO ()
    entropyClose (DevRandom DeviceName
    _)  = () -> IO ()
    forall a. a -> IO a
    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 a b. (a -> b) -> Maybe a -> Maybe b
    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 a b. (a -> b) -> IO a -> IO b
    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 a. a -> IO a
    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 a. a -> IO a
    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 a b. IO a -> IO b -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> Maybe DeviceName -> IO (Maybe DeviceName)
    forall a. a -> IO a
    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 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
    h <- DeviceName -> IOMode -> IO H
    openBinaryFile DeviceName
    filepath IOMode
    ReadMode
                H -> BufferMode -> IO ()
    hSetBuffering H
    h BufferMode
    NoBuffering
                H -> IO H
    forall a. a -> IO a
    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 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 -> 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 -> 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

    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