1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
|
-- |
-- 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 CPP, ForeignFunctionInterface #-}
module Crypto.Random.Entropy.Windows
( WinCryptoAPI
) where
import Data.Int (Int32)
import Data.Word (Word8, Word32, Word64)
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
|
