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