merge entropy from crypto-random

Crypto/Random/Entropy.hs

@@ -0,0 +1,119 @@
+-- |
+-- Module      : Crypto.Random.Entropy
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : experimental
+-- Portability : Good
+--
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ExistentialQuantification #-}
+module Crypto.Random.Entropy
+    ( EntropyPool
+    , createEntropyPool
+    , grabEntropyPtr
+    , grabEntropy
+    ) where
+
+import Control.Monad (when)
+import Control.Concurrent.MVar
+import Data.Maybe (catMaybes)
+import Data.SecureMem
+import Data.Word (Word8)
+import Foreign.Marshal.Utils (copyBytes)
+import Foreign.Ptr (plusPtr, Ptr)
+
+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
+
+supportedBackends :: [IO (Maybe EntropyBackend)]
+supportedBackends =
+    [
+#ifdef SUPPORT_RDRAND
+    openBackend (undefined :: RDRand),
+#endif
+#ifdef WINDOWS
+    openBackend (undefined :: WinCryptoAPI)
+#else
+    openBackend (undefined :: DevRandom), openBackend (undefined :: DevURandom)
+#endif
+    ]
+
+data EntropyBackend = forall b . EntropySource b => EntropyBackend b
+
+openBackend :: EntropySource b => b -> IO (Maybe EntropyBackend)
+openBackend b = fmap EntropyBackend `fmap` callOpen b
+  where callOpen :: EntropySource b => b -> IO (Maybe b)
+        callOpen _ = entropyOpen
+
+gatherBackend :: EntropyBackend -> Ptr Word8 -> Int -> IO Int
+gatherBackend (EntropyBackend backend) ptr n = entropyGather backend ptr n
+
+-- | Pool of Entropy. contains a self mutating pool of entropy,
+-- that is always guarantee to contains data.
+data EntropyPool = EntropyPool [EntropyBackend] (MVar Int) SecureMem
+
+-- size of entropy pool by default
+defaultPoolSize :: Int
+defaultPoolSize = 4096
+
+-- | Create a new entropy pool of a specific size
+--
+-- While you can create as many entropy pool as you want, the pool can be shared between multiples RNGs.
+createEntropyPoolWith :: Int -> [EntropyBackend] -> IO EntropyPool
+createEntropyPoolWith poolSize backends = do
+    when (null backends) $ fail "cannot get any source of entropy on this system"
+    sm <- allocateSecureMem poolSize
+    m  <- newMVar 0
+    withSecureMemPtr sm $ replenish poolSize backends
+    return $ EntropyPool backends m sm
+
+-- | Create a new entropy pool with a default size.
+--
+-- While you can create as many entropy pool as you want, the pool can be shared between multiples RNGs.
+createEntropyPool :: IO EntropyPool
+createEntropyPool = do
+    backends <- catMaybes `fmap` sequence supportedBackends
+    createEntropyPoolWith defaultPoolSize backends
+
+-- | Put a chunk of the entropy pool into a buffer
+grabEntropyPtr :: Int -> EntropyPool -> Ptr Word8 -> IO ()
+grabEntropyPtr n (EntropyPool backends posM sm) outPtr =
+    withSecureMemPtr sm $ \entropyPoolPtr ->
+        modifyMVar_ posM $ \pos ->
+            copyLoop outPtr entropyPoolPtr pos n
+  where poolSize = secureMemGetSize sm
+        copyLoop d s pos left
+            | left == 0 = return pos
+            | otherwise = do
+                wrappedPos <-
+                    if pos == poolSize
+                        then replenish poolSize backends s >> return 0
+                        else return pos
+                let m = min (poolSize - wrappedPos) left
+                copyBytes d (s `plusPtr` wrappedPos) m
+                copyLoop (d `plusPtr` m) s (wrappedPos + m) (left - m)
+
+-- | Grab a chunk of entropy from the entropy pool.
+grabEntropy :: Int -> EntropyPool -> IO SecureMem
+grabEntropy n pool = do
+    out <- allocateSecureMem n
+    withSecureMemPtr out $ grabEntropyPtr n pool
+    return $ out
+
+replenish :: Int -> [EntropyBackend] -> Ptr Word8 -> IO ()
+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 "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)

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)

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 ()

Crypto/Random/Entropy/Unix.hs

@@ -0,0 +1,67 @@
+-- |
+-- 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.Posix.IO
+
+type H = Fd
+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 -> gatherDevEntropy 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` openFd filepath ReadOnly Nothing fileFlags)
+    `E.catch` \(_ :: IOException) -> return Nothing
+  where fileFlags = defaultFileFlags { nonBlock = True }
+
+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 = closeFd h
+
+gatherDevEntropy :: H -> Ptr Word8 -> Int -> IO Int
+gatherDevEntropy h ptr sz =
+     (fromIntegral `fmap` fdReadBuf h ptr (fromIntegral sz))
+    `E.catch` \(_ :: IOException) -> return 0

Crypto/Random/Entropy/Windows.hs

@@ -0,0 +1,82 @@
+-- |
+-- 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 #-}
+module Crypto.Random.Entropy.Windows
+    ( WinCryptoAPI
+    ) where
+
+import Data.Int (Int32)
+import Data.Word (Word32, Word8)
+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 Crypto.Random.Entropy.Source
+
+-- Define the constants we need from WinCrypt.h 
+msDefProv :: String
+msDefProv = "Microsoft Base Cryptographic Provider v1.0"
+
+provRSAFull :: Word32
+provRSAFull = 1
+
+cryptVerifyContext :: Word32
+cryptVerifyContext = 0xF0000000
+
+-- | 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  -> error "cannot re-grab win crypto api"
+            Just ctx -> do
+                r <- cryptGenRandom ctx ptr n
+                cryptReleaseCtx ctx
+                return r
+    entropyClose WinCryptoAPI = return ()
+
+type CryptCtx = Word32
+
+-- Declare the required CryptoAPI imports 
+foreign import stdcall unsafe "CryptAcquireContextA"
+   c_cryptAcquireCtx :: Ptr Word32 -> CString -> CString -> Word32 -> Word32 -> IO CryptCtx
+foreign import stdcall unsafe "CryptGenRandom"
+   c_cryptGenRandom :: CryptCtx -> Word32 -> Ptr Word8 -> IO Int32
+foreign import stdcall unsafe "CryptReleaseContext"
+   c_cryptReleaseCtx :: CryptCtx -> Word32 -> IO Int32
+
+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 fail "cryptReleaseCtx"

cbits/cryptonite_rdrand.c

@@ -0,0 +1,100 @@
+/*
+ * Copyright (C) Thomas DuBuisson
+ * Copyright (C) 2013 Vincent Hanquez <tab@snarc.org>
+ *
+ * All rights reserved.
+ * 
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ *    notice, this list of conditions and the following disclaimer in the
+ *    documentation and/or other materials provided with the distribution.
+ * 3. Neither the name of the author nor the names of his contributors
+ *    may be used to endorse or promote products derived from this software
+ *    without specific prior written permission.
+ * 
+ * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ */
+
+#include <stdint.h>
+#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+
+int cryptonite_cpu_has_rdrand()
+{
+	uint32_t ax,bx,cx,dx,func=1;
+	__asm__ volatile ("cpuid": "=a" (ax), "=b" (bx), "=c" (cx), "=d" (dx) : "a" (func));
+	return (cx & 0x40000000);
+}
+
+/* sadly many people are still using an old binutils,
+ * leading to report that instruction is not recognized.
+ */
+#if 0
+/* Returns 1 on success */
+static inline int crypto_random_rdrand64_step(uint64_t *buffer)
+{
+	unsigned char err;
+	asm volatile ("rdrand %0; setc %1" : "=r" (*buffer), "=qm" (err));
+	return (int) err;
+}
+#endif
+
+/* inline encoding of 'rdrand %rax' to cover old binutils
+ * - no inputs
+ * - 'cc' to the clobber list as we modify condition code.
+ * - output of rdrand in rax and have a 8 bit error condition
+ */
+#define inline_rdrand_rax(val, err) \
+	asm(".byte 0x48,0x0f,0xc7,0xf0; setc %1" \
+	   : "=a" (val), "=q" (err) \
+	   : \
+	   : "cc")
+
+/* Returns the number of bytes succesfully generated */
+int cryptonite_get_rand_bytes(uint8_t *buffer, size_t len)
+{
+	uint64_t tmp;
+	int aligned = (unsigned long) buffer % 8;
+	int orig_len = len;
+	int to_alignment = 8 - aligned;
+	uint8_t ok;
+
+	if (aligned != 0) {
+		inline_rdrand_rax(tmp, ok);
+		if (!ok)
+			return 0;
+		memcpy(buffer, (uint8_t *) &tmp, to_alignment);
+		buffer += to_alignment;
+		len -= to_alignment;
+	}
+
+	for (; len >= 8; buffer += 8, len -= 8) {
+		inline_rdrand_rax(tmp, ok);
+		if (!ok)
+			return (orig_len - len);
+		*((uint64_t *) buffer) = tmp;
+	}
+
+	if (len > 0) {
+		inline_rdrand_rax(tmp, ok);
+		if (!ok)
+			return (orig_len - len);
+		memcpy(buffer, (uint8_t *) &tmp, len);
+	}
+	return orig_len;
+}

cryptonite.cabal

@@ -23,6 +23,8 @@ Library
   Exposed-modules:   Crypto.Cipher.ChaCha
                      Crypto.Cipher.Salsa
                      Crypto.MAC.Poly1305
+                     Crypto.Random.Entropy
+  Other-modules:     Crypto.Random.Entropy.Source
   Build-depends:     base >= 4 && < 5
                    , bytestring
                    , securemem
@@ -35,6 +37,20 @@ Library
   if (arch(i386) || arch(x86_64))
     CPP-options: -DARCH_IS_LITTLE_ENDIAN
 
+  if arch(x86_64)
+    cpp-options:    -DSUPPORT_RDRAND
+    Other-modules:  Crypto.Random.Entropy.RDRand
+    c-sources:      cbits/cryptonite_rdrand.c
+
+  if os(windows)
+    cpp-options:    -DWINDOWS
+    Build-Depends:  Win32
+    Other-modules:  Crypto.Random.Entropy.Windows
+    extra-libraries: advapi32
+  else
+    Build-Depends:  unix
+    Other-modules:  Crypto.Random.Entropy.Unix
+
 Test-Suite test-cryptonite
   type:              exitcode-stdio-1.0
   hs-source-dirs:    tests