Initial commit

bundled/Crypto/Random/Entropy/Unix.hs

@@ -0,0 +1,74 @@
+-- |
+-- 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 `E.finally` closeDev fd
+
+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