git.iko.soy/typeable/entropy
on a605127 help sign in
typeable/entropy/System/EntropyWindows.hs
134 lines 4.1 kB history raw
1{-# LANGUAGE CPP, ForeignFunctionInterface, BangPatterns, ScopedTypeVariables #-}
2{-|
3 Maintainer: Thomas.DuBuisson@gmail.com
4 Stability: beta
5 Portability: portable
7 Obtain entropy from system sources or x86 RDRAND when available.
8-}
10module System.EntropyWindows
11 ( CryptHandle
12 , openHandle
13 , hGetEntropy
14 , closeHandle
15 ) where
17import Control.Monad (liftM, when)
18import System.IO.Error (mkIOError, eofErrorType, ioeSetErrorString)
19import Foreign (allocaBytes)
20import Data.ByteString as B
21import Data.ByteString.Internal as BI
22import Data.Int (Int32)
23import Data.Bits (xor)
24import Data.Word (Word32, Word8)
25import Foreign.C.String (CString, withCString)
26import Foreign.C.Types
27import Foreign.Ptr (Ptr, nullPtr, castPtr)
28import Foreign.Marshal.Alloc (alloca)
29import Foreign.Marshal.Utils (toBool)
30import Foreign.Storable (peek)
32{- C example for windows rng - taken from a blog, can't recall which one but thank you!
33 #include <Windows.h>
34 #include <Wincrypt.h>
35 ...
36 //
37 // DISCLAIMER: Don't forget to check your error codes!!
38 // I am not checking as to make the example simple...
39 //
40 HCRYPTPROV hCryptCtx = NULL;
41 BYTE randomArray[128];
43 CryptAcquireContext(&hCryptCtx, NULL, MS_DEF_PROV, PROV_RSA_FULL, CRYPT_VERIFYCONTEXT);
44 CryptGenRandom(hCryptCtx, 128, randomArray);
45 CryptReleaseContext(hCryptCtx, 0);
46-}
49#ifdef HAVE_RDRAND
50foreign import ccall unsafe "cpu_has_rdrand"
51 c_cpu_has_rdrand :: IO CInt
53foreign import ccall unsafe "get_rand_bytes"
54 c_get_rand_bytes :: Ptr CUChar -> CSize -> IO CInt
56cpuHasRdRand :: IO Bool
57cpuHasRdRand = (/= 0) `fmap` c_cpu_has_rdrand
58#endif
60data CryptHandle
61 = CH Word32
62#ifdef HAVE_RDRAND
63 | UseRdRand Word32
64#endif
66-- Define the constants we need from WinCrypt.h
67msDefProv :: String
68msDefProv = "Microsoft Base Cryptographic Provider v1.0"
69provRSAFull :: Word32
70provRSAFull = 1
71cryptVerifyContext :: Word32
72cryptVerifyContext = fromIntegral 0xF0000000
74-- Declare the required CryptoAPI imports
75foreign import stdcall unsafe "CryptAcquireContextA"
76 c_cryptAcquireCtx :: Ptr Word32 -> CString -> CString -> Word32 -> Word32 -> IO Int32
77foreign import stdcall unsafe "CryptGenRandom"
78 c_cryptGenRandom :: Word32 -> Word32 -> Ptr Word8 -> IO Int32
79foreign import stdcall unsafe "CryptReleaseContext"
80 c_cryptReleaseCtx :: Word32 -> Word32 -> IO Int32
82cryptAcquireCtx :: IO Word32
83cryptAcquireCtx =
84 alloca $ \handlePtr ->
85 withCString msDefProv $ \provName -> do
86 stat <- c_cryptAcquireCtx handlePtr nullPtr provName provRSAFull cryptVerifyContext
87 if (toBool stat)
88 then peek handlePtr
89 else fail "c_cryptAcquireCtx"
91cryptGenRandom :: Word32 -> Int -> IO B.ByteString
92cryptGenRandom h i =
93 BI.create i $ \c_buffer -> do
94 stat <- c_cryptGenRandom h (fromIntegral i) c_buffer
95 if (toBool stat)
96 then return ()
97 else fail "c_cryptGenRandom"
99cryptReleaseCtx :: Word32 -> IO ()
100cryptReleaseCtx h = do
101 stat <- c_cryptReleaseCtx h 0
102 if (toBool stat)
103 then return ()
104 else fail "c_cryptReleaseCtx"
106-- |Open a handle from which random data can be read
107openHandle :: IO CryptHandle
108openHandle = do
109#ifdef HAVE_RDRAND
110 b <- cpuHasRdRand
111 if b then UseRdRand `fmap` cryptAcquireCtx
112 else do
113#endif
114 CH `fmap` cryptAcquireCtx
116-- |Close the `CryptHandle`
117closeHandle :: CryptHandle -> IO ()
118closeHandle (CH h) = cryptReleaseCtx h
119#ifdef HAVE_RDRAND
120closeHandle (UseRdRand h) = cryptReleaseCtx h
121#endif
123-- |Read from `CryptHandle`
124hGetEntropy :: CryptHandle -> Int -> IO B.ByteString
125hGetEntropy (CH h) n = cryptGenRandom h n
126#ifdef HAVE_RDRAND
127hGetEntropy (UseRdRand h) n =
128 do bsRDRAND <- BI.create n $ \ptr -> do
129 r <- c_get_rand_bytes (castPtr ptr) (fromIntegral n)
130 when (r /= 0)
131 (fail "RDRand failed to gather entropy")
132 bsWinCrypt <- cryptGenRandom h n
133 return $ B.pack $ B.zipWith xor bsRDRAND bsWinCrypt
134#endif