support windows 64 bits
This commit is contained in:
parent
80b379c98d
commit
9c1d9695c5
@ -20,18 +20,10 @@ 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
|
||||
|
||||
-- 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
|
||||
@ -43,26 +35,52 @@ instance EntropySource WinCryptoAPI where
|
||||
entropyGather WinCryptoAPI ptr n = do
|
||||
mctx <- cryptAcquireCtx
|
||||
case mctx of
|
||||
Nothing -> error "cannot re-grab win crypto api"
|
||||
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 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
|
||||
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 ->
|
||||
cryptAcquireCtx =
|
||||
alloca $ \handlePtr ->
|
||||
withCString msDefProv $ \provName -> do
|
||||
r <- toBool `fmap` c_cryptAcquireCtx handlePtr nullPtr provName provRSAFull cryptVerifyContext
|
||||
if r
|
||||
@ -79,4 +97,6 @@ cryptReleaseCtx h = do
|
||||
success <- toBool `fmap` c_cryptReleaseCtx h 0
|
||||
if success
|
||||
then return ()
|
||||
else fail "cryptReleaseCtx"
|
||||
else do
|
||||
lastError <- getLastError
|
||||
fail $ "cryptReleaseCtx: error " ++ show lastError
|
||||
|
||||
Loading…
Reference in New Issue
Block a user