Initial commit

bundled/Crypto/Random/Entropy/Backend.hs

@@ -0,0 +1,57 @@
+-- |
+-- Module      : Crypto.Random.Entropy.Backend
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : stable
+-- Portability : good
+--
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ExistentialQuantification #-}
+module Crypto.Random.Entropy.Backend
+    ( EntropyBackend
+    , supportedBackends
+    , gatherBackend
+    ) where
+
+import Foreign.Ptr
+import Data.Proxy
+import Data.Word (Word8)
+import Crypto.Random.Entropy.Source
+#ifdef SUPPORT_RDRAND
+import Crypto.Random.Entropy.RDRand
+#endif
+#ifdef WINDOWS
+import Crypto.Random.Entropy.Windows
+#else
+import Crypto.Random.Entropy.Unix
+#endif
+
+-- | All supported backends 
+supportedBackends :: [IO (Maybe EntropyBackend)]
+supportedBackends =
+    [
+#ifdef SUPPORT_RDRAND
+    openBackend (Proxy :: Proxy RDRand),
+#endif
+#ifdef WINDOWS
+    openBackend (Proxy :: Proxy WinCryptoAPI)
+#else
+    openBackend (Proxy :: Proxy DevRandom), openBackend (Proxy :: Proxy DevURandom)
+#endif
+    ]
+
+-- | Any Entropy Backend
+data EntropyBackend = forall b . EntropySource b => EntropyBackend b
+
+-- | Open a backend handle
+openBackend :: EntropySource b => Proxy b -> IO (Maybe EntropyBackend)
+openBackend b = fmap EntropyBackend `fmap` callOpen b
+  where callOpen :: EntropySource b => Proxy b -> IO (Maybe b)
+        callOpen _ = entropyOpen
+
+-- | Gather randomness from an open handle
+gatherBackend :: EntropyBackend -- ^ An open Entropy Backend
+              -> Ptr Word8      -- ^ Pointer to a buffer to write to
+              -> Int            -- ^ number of bytes to write
+              -> IO Int         -- ^ return the number of bytes actually written
+gatherBackend (EntropyBackend backend) ptr n = entropyGather backend ptr n

bundled/Crypto/Random/Entropy/RDRand.hs

@@ -0,0 +1,38 @@
+-- |
+-- Module      : Crypto.Random.Entropy.RDRand
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : experimental
+-- Portability : Good
+--
+{-# LANGUAGE ForeignFunctionInterface #-}
+module Crypto.Random.Entropy.RDRand
+    ( RDRand
+    ) where
+
+import Foreign.Ptr
+import Foreign.C.Types
+import Data.Word (Word8)
+import Crypto.Random.Entropy.Source
+
+foreign import ccall unsafe "cryptonite_cpu_has_rdrand"
+   c_cpu_has_rdrand :: IO CInt
+
+foreign import ccall unsafe "cryptonite_get_rand_bytes"
+  c_get_rand_bytes :: Ptr Word8 -> CInt -> IO CInt
+
+-- | Fake handle to Intel RDRand entropy CPU instruction
+data RDRand = RDRand
+
+instance EntropySource RDRand where
+    entropyOpen     = rdrandGrab
+    entropyGather _ = rdrandGetBytes
+    entropyClose  _ = return ()
+
+rdrandGrab :: IO (Maybe RDRand)
+rdrandGrab = supported `fmap` c_cpu_has_rdrand
+  where supported 0 = Nothing
+        supported _ = Just RDRand
+
+rdrandGetBytes :: Ptr Word8 -> Int -> IO Int
+rdrandGetBytes ptr sz = fromIntegral `fmap` c_get_rand_bytes ptr (fromIntegral sz)

bundled/Crypto/Random/Entropy/Source.hs

@@ -0,0 +1,22 @@
+-- |
+-- Module      : Crypto.Random.Entropy.Source
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : experimental
+-- Portability : Good
+--
+module Crypto.Random.Entropy.Source where
+
+import Foreign.Ptr
+import Data.Word (Word8)
+
+-- | A handle to an entropy maker, either a system capability
+-- or a hardware generator.
+class EntropySource a where
+    -- | Try to open an handle for this source
+    entropyOpen   :: IO (Maybe a)
+    -- | Try to gather a number of entropy bytes into a buffer.
+    -- Return the number of actual bytes gathered
+    entropyGather :: a -> Ptr Word8 -> Int -> IO Int
+    -- | Close an open handle
+    entropyClose  :: a -> IO ()

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

bundled/Crypto/Random/Entropy/Unsafe.hs

@@ -0,0 +1,34 @@
+-- |
+-- Module      : Crypto.Random.Entropy.Unsafe
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : experimental
+-- Portability : Good
+--
+module Crypto.Random.Entropy.Unsafe
+    ( replenish
+    , module Crypto.Random.Entropy.Backend
+    ) where
+
+import Data.Word (Word8)
+import Foreign.Ptr (Ptr, plusPtr)
+import Crypto.Random.Entropy.Backend
+
+-- | Refill the entropy in a buffer
+--
+-- Call each entropy backend in turn until the buffer has
+-- been replenished.
+--
+-- If the buffer cannot be refill after 3 loopings, this will raise
+-- an User Error exception
+replenish :: Int -> [EntropyBackend] -> Ptr Word8 -> IO ()
+replenish _        []       _   = fail "cryptonite: random: cannot get any source of entropy on this system"
+replenish poolSize backends ptr = loop 0 backends ptr poolSize
+  where loop :: Int -> [EntropyBackend] -> Ptr Word8 -> Int -> IO ()
+        loop retry [] p n | n == 0     = return ()
+                          | retry == 3 = error "cryptonite: random: cannot fully replenish"
+                          | otherwise  = loop (retry+1) backends p n
+        loop _     (_:_)  _ 0 = return ()
+        loop retry (b:bs) p n = do
+            r <- gatherBackend b p n
+            loop retry bs (p `plusPtr` r) (n - r)

bundled/Crypto/Random/Entropy/Windows.hs

@@ -0,0 +1,103 @@
+-- |
+-- Module      : Crypto.Random.Entropy.Windows
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : experimental
+-- Portability : Good
+--
+-- Code originally from the entropy package and thus is:
+--   Copyright (c) Thomas DuBuisson.
+--
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE CPP #-}
+module Crypto.Random.Entropy.Windows
+    ( WinCryptoAPI
+    ) where
+
+import Data.Int (Int32)
+import Data.Word
+import Foreign.C.String (CString, withCString)
+import Foreign.Ptr (Ptr, nullPtr)
+import Foreign.Marshal.Alloc (alloca)
+import Foreign.Marshal.Utils (toBool)
+import Foreign.Storable (peek)
+import System.Win32.Types (getLastError)
+
+import Crypto.Random.Entropy.Source
+
+
+-- | Handle to Windows crypto API for random generation
+data WinCryptoAPI = WinCryptoAPI
+
+instance EntropySource WinCryptoAPI where
+    entropyOpen = do
+        mctx <- cryptAcquireCtx
+        maybe (return Nothing) (\ctx -> cryptReleaseCtx ctx >> return (Just WinCryptoAPI)) mctx
+    entropyGather WinCryptoAPI ptr n = do
+        mctx <- cryptAcquireCtx
+        case mctx of
+            Nothing  -> do
+                lastError <- getLastError
+                fail $ "cannot re-grab win crypto api: error " ++ show lastError
+            Just ctx -> do
+                r <- cryptGenRandom ctx ptr n
+                cryptReleaseCtx ctx
+                return r
+    entropyClose WinCryptoAPI = return ()
+
+
+type DWORD = Word32
+type BOOL  = Int32
+type BYTE  = Word8
+
+#if defined(ARCH_X86)
+# define WINDOWS_CCONV stdcall
+type CryptCtx = Word32
+#elif defined(ARCH_X86_64)
+# define WINDOWS_CCONV ccall
+type CryptCtx = Word64
+#else
+# error Unknown mingw32 arch
+#endif
+
+-- Declare the required CryptoAPI imports
+foreign import WINDOWS_CCONV unsafe "CryptAcquireContextA"
+   c_cryptAcquireCtx :: Ptr CryptCtx -> CString -> CString -> DWORD -> DWORD -> IO BOOL
+foreign import WINDOWS_CCONV unsafe "CryptGenRandom"
+   c_cryptGenRandom :: CryptCtx -> DWORD -> Ptr BYTE -> IO BOOL
+foreign import WINDOWS_CCONV unsafe "CryptReleaseContext"
+   c_cryptReleaseCtx :: CryptCtx -> DWORD -> IO BOOL
+
+
+-- Define the constants we need from WinCrypt.h
+msDefProv :: String
+msDefProv = "Microsoft Base Cryptographic Provider v1.0"
+
+provRSAFull :: DWORD
+provRSAFull = 1
+
+cryptVerifyContext :: DWORD
+cryptVerifyContext = 0xF0000000
+
+cryptAcquireCtx :: IO (Maybe CryptCtx)
+cryptAcquireCtx =
+    alloca $ \handlePtr ->
+    withCString msDefProv $ \provName -> do
+        r <- toBool `fmap` c_cryptAcquireCtx handlePtr nullPtr provName provRSAFull cryptVerifyContext
+        if r
+            then Just `fmap` peek handlePtr
+            else return Nothing
+
+cryptGenRandom :: CryptCtx -> Ptr Word8 -> Int -> IO Int
+cryptGenRandom h buf n = do
+    success <- toBool `fmap` c_cryptGenRandom h (fromIntegral n) buf
+    return $ if success then n else 0
+
+cryptReleaseCtx :: CryptCtx -> IO ()
+cryptReleaseCtx h = do
+    success <- toBool `fmap` c_cryptReleaseCtx h 0
+    if success
+        then return ()
+        else do
+            lastError <- getLastError
+            fail $ "cryptReleaseCtx: error " ++ show lastError