-- |
-- 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 = fmap DevRandom `fmap` testOpen "/dev/random"
    entropyGather (DevRandom name) ptr n =
        withDev name $ \h -> gatherDevEntropyNonBlock h ptr n
    entropyClose (DevRandom _)  = return ()

instance EntropySource DevURandom where
    entropyOpen = fmap DevURandom `fmap` testOpen "/dev/urandom"
    entropyGather (DevURandom name) ptr n =
        withDev name $ \h -> gatherDevEntropy h ptr n
    entropyClose (DevURandom _)  = return ()

testOpen :: DeviceName -> IO (Maybe DeviceName)
testOpen filepath = do
    d <- openDev filepath
    case d of
        Nothing -> return Nothing
        Just h  -> closeDev h >> return (Just filepath)

openDev :: String -> IO (Maybe H)
openDev filepath = (Just `fmap` openAndNoBuffering) `E.catch` \(_ :: IOException) -> return Nothing
  where openAndNoBuffering = do
            h <- openBinaryFile filepath ReadMode
            hSetBuffering h NoBuffering
            return h

withDev :: String -> (H -> IO a) -> IO a
withDev filepath f = openDev filepath >>= \h ->
    case h of
        Nothing -> error ("device " ++ filepath ++ " cannot be grabbed")
        Just fd -> f fd >>= \r -> (closeDev fd >> return r)

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

gatherDevEntropy :: H -> Ptr Word8 -> Int -> IO Int
gatherDevEntropy h ptr sz =
     (fromIntegral `fmap` hGetBufSome h ptr (fromIntegral sz))
    `E.catch` \(_ :: IOException) -> return 0

gatherDevEntropyNonBlock :: H -> Ptr Word8 -> Int -> IO Int
gatherDevEntropyNonBlock h ptr sz =
     (fromIntegral `fmap` hGetBufNonBlocking h ptr (fromIntegral sz))
    `E.catch` \(_ :: IOException) -> return 0