hspkcs11 0.5 → 0.6
raw patch · 6 files changed
+2220/−2130 lines, 6 filesdep +base64-bytestring
Dependencies added: base64-bytestring
Files
- Test.hs +42/−29
- hspkcs11.cabal +9/−2
- src/Bindings/Pkcs11.chs +1403/−0
- src/System/Crypto/Pkcs11.chs +0/−2097
- src/System/Crypto/Pkcs11.hs +763/−0
- src/System/Crypto/Pkcs11/Lazy.hs +3/−2
Test.hs view
@@ -8,6 +8,7 @@ import qualified Crypto.Cipher.AES as AESmod import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL+import qualified Data.ByteString.Base64 as B64 import Numeric @@ -66,32 +67,32 @@ putStrLn $ show sessInfo login sess User (BU8.fromString "123abc_") putStrLn "generate key"- aesKeyHandle <- generateKey sess (simpleMech AesKeyGen) [ValueLen 16, Token True, Label "testaeskey", Extractable True]+ aesKeyHandle <- generateKey (simpleMech AesKeyGen) [ValueLen 16, Token True, Label "testaeskey", Extractable True] sess putStrLn $ "generated key " ++ (show aesKeyHandle) putStrLn "encryption"- encryptInit (simpleMech AesEcb) sess aesKeyHandle+ encryptInit (simpleMech AesEcb) aesKeyHandle encData <- PL.encrypt sess (BSL.pack [0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0]) putStrLn $ show encData putStrLn "decryption"- decData <- decrypt (simpleMech AesEcb) sess aesKeyHandle (BSL.toStrict encData) 1000+ decData <- decrypt (simpleMech AesEcb) aesKeyHandle (BSL.toStrict encData) Nothing putStrLn $ show decData putStrLn "generating key pair"- (pubKeyHandle, privKeyHandle) <- generateKeyPair sess (simpleMech RsaPkcsKeyPairGen) [ModulusBits 2048, Token True, Label "key"] [Token True, Label "key"]+ (pubKeyHandle, privKeyHandle) <- generateKeyPair (simpleMech RsaPkcsKeyPairGen) [ModulusBits 2048, Token True, Label "key"] [Token True, Label "key"] sess putStrLn $ "generated " ++ (show pubKeyHandle) ++ " and " ++ (show privKeyHandle) putStrLn "wrap key"- wrappedAesKey <- wrapKey (simpleMech RsaPkcs) sess pubKeyHandle aesKeyHandle 300+ wrappedAesKey <- wrapKey (simpleMech RsaPkcs) pubKeyHandle aesKeyHandle Nothing putStrLn $ show wrappedAesKey putStrLn "unwrap key"- unwrappedAesKey <- unwrapKey (simpleMech RsaPkcs) sess privKeyHandle wrappedAesKey [Class SecretKey, KeyType AES]+ unwrappedAesKey <- unwrapKey (simpleMech RsaPkcs) privKeyHandle wrappedAesKey [Class SecretKey, KeyType AES] putStrLn "sign" let signedData = BS.pack [0,0,0,0]- signature <- sign (simpleMech RsaPkcs) sess privKeyHandle signedData 1000+ signature <- sign (simpleMech RsaPkcs) privKeyHandle signedData Nothing putStrLn $ show signature --putStrLn "get operation state" --operState <- getOperationState sess 1000 --putStrLn $ show operState putStrLn "verify"- verRes <- verify (simpleMech RsaPkcs) sess pubKeyHandle signedData signature+ verRes <- verify (simpleMech RsaPkcs) pubKeyHandle signedData signature putStrLn $ "verify result " ++ (show verRes) --putStrLn "signRecoverInit" --signRecoverInit (simpleMech Rsa9796) sess privKeyHandle@@ -101,17 +102,17 @@ randData <- generateRandom sess 10 putStrLn $ show randData putStrLn "set attributes"- setAttributes sess aesKeyHandle [Extractable False]+ setAttributes aesKeyHandle [Extractable False] putStrLn "get object size"- aesKeySize <- getObjectSize sess aesKeyHandle+ aesKeySize <- getObjectSize aesKeyHandle putStrLn $ show $ fromIntegral aesKeySize putStrLn "copy object"- copiedObjHandle <- copyObject sess aesKeyHandle []+ copiedObjHandle <- copyObject aesKeyHandle [] putStrLn $ show copiedObjHandle putStrLn "deleting object"- destroyObject sess aesKeyHandle+ destroyObject aesKeyHandle putStrLn "digest"- digestedData <- digest (simpleMech Sha256) sess (BS.replicate 16 0) 1000+ digestedData <- digest (simpleMech Sha256) sess (BS.replicate 16 0) Nothing putStrLn $ show digestedData putStrLn "create object" createdAesKey <- createObject sess [Class SecretKey,@@ -119,9 +120,9 @@ Value (BS.replicate 16 0)] putStrLn $ show createdAesKey putStrLn "generate DH domain parameters"- dhParamsHandle <- generateKey sess (simpleMech DhPkcsParameterGen) [PrimeBits 512]- dhPrime <- getPrime sess dhParamsHandle- dhBase <- getBase sess dhParamsHandle+ dhParamsHandle <- generateKey (simpleMech DhPkcsParameterGen) [PrimeBits 512] sess+ dhPrime <- getPrime dhParamsHandle+ dhBase <- getBase dhParamsHandle putStrLn $ "generated DH prime=" ++ (show dhPrime) ++ " base=" ++ (show dhBase) --putStrLn "generate DH PKCS key pair" --(pubKeyHandle, privKeyHandle) <- generateKeyPair sess (simpleMech DhPkcsKeyPairGen) [Prime dhPrime, Base dhBase] []@@ -129,7 +130,19 @@ --putStrLn "deriving DH key" --deriveKey sess (simpleMech DhPkcsDerive) privKeyHandle [] + putStrLn "generating EC key pair using prime256v1"+ (ecPubKey, ecPrivKey) <- generateKeyPair (simpleMech EcKeyPairGen) [EcParams (B64.decodeLenient "BggqhkjOPQMBBw==")] [] sess+ derEcPoint <- getEcPoint ecPubKey+ derEcParams <- getEcdsaParams ecPubKey+ putStrLn $ "EC point DER=" ++ (show $ B64.encode derEcPoint) ++ " params DER=" ++ (show $ B64.encode derEcParams)+ putStrLn "signing with ECDSA"+ ecSignature <- sign (simpleMech Ecdsa) ecPrivKey signedData Nothing+ putStrLn $ show ecSignature+ putStrLn "verifying signature"+ ecVerifyRes <- verify (simpleMech Ecdsa) ecPubKey signedData ecSignature+ putStrLn $ show ecVerifyRes + putStrLn "close all sessions" closeAllSessions lib slotId @@ -140,16 +153,16 @@ objects <- findObjects sess [Class PrivateKey, Label "key"] putStrLn $ show objects let objId = head objects- getTokenFlag sess objId- getPrivateFlag sess objId- getSensitiveFlag sess objId- --getEncryptFlag sess objId- decryptFlag <- getDecryptFlag sess objId- --getWrapFlag sess objId- getUnwrapFlag sess objId- signFlag <- getSignFlag sess objId- mod <- getModulus sess objId- pubExp <- getPublicExponent sess objId+ getTokenFlag objId+ getPrivateFlag objId+ getSensitiveFlag objId+ --getEncryptFlag objId+ decryptFlag <- getDecryptFlag objId+ --getWrapFlag objId+ getUnwrapFlag objId+ signFlag <- getSignFlag objId+ mod <- getModulus objId+ pubExp <- getPublicExponent objId putStrLn $ show decryptFlag putStrLn $ show signFlag putStrLn $ showHex mod ""@@ -164,17 +177,17 @@ --putStrLn $ show encText --let encTextLen = BS.length encText --putStrLn $ show encTextLen- unwrappedKeyHandle <- unwrapKey (simpleMech RsaPkcs) sess objId (BSL.toStrict encKey) [Class SecretKey, KeyType AES]+ unwrappedKey <- unwrapKey (simpleMech RsaPkcs) objId (BSL.toStrict encKey) [Class SecretKey, KeyType AES] let aesKey = AESmod.initAES aesKeyBs encryptedMessage = AESmod.encryptECB aesKey "hello00000000000" -- test decryption using RSA key- dec <- decrypt (simpleMech RsaPkcs) sess objId (BSL.toStrict encKey) 1000+ dec <- decrypt (simpleMech RsaPkcs) objId (BSL.toStrict encKey) Nothing putStrLn $ show dec -- test decryption using AES key- decAes <- decrypt (simpleMech AesEcb) sess unwrappedKeyHandle encryptedMessage 1000+ decAes <- decrypt (simpleMech AesEcb) unwrappedKey encryptedMessage Nothing putStrLn $ show decAes logout sess
hspkcs11.cabal view
@@ -1,5 +1,5 @@ name: hspkcs11-version: 0.5+version: 0.6 synopsis: Wrapper for PKCS #11 interface description: This package allows to call PKCS#11 provider libraries. PKCS#11 is a C interface specification for cryptography providers, such as crypto tokens and HSMs homepage: https://github.com/denisenkom/hspkcs11@@ -24,9 +24,11 @@ exposed-modules: System.Crypto.Pkcs11 System.Crypto.Pkcs11.Lazy+ Bindings.Pkcs11 Default-language: Haskell2010 -executable pkcs11-tests+test-suite pkcs11-tests+ type: exitcode-stdio-1.0 main-is: Test.hs build-depends: base,@@ -34,8 +36,13 @@ unix, utf8-string, bytestring,+ base64-bytestring, crypto-api, cprng-aes, cipher-aes, RSA default-language: Haskell2010++source-repository head+ type: git+ location: https://github.com/denisenkom/hspkcs11.git
+ src/Bindings/Pkcs11.chs view
@@ -0,0 +1,1403 @@+{-# LANGUAGE ForeignFunctionInterface #-}+-- | This module contains low-level binding for PKCS#11 C interface. Module is not intended to be used directly by+-- user applications.+module Bindings.Pkcs11 where+import Foreign+import Foreign.Marshal.Utils+import Foreign.Marshal.Alloc+import Foreign.C+import Foreign.Ptr+import Control.Monad+import Control.Exception+import qualified Data.ByteString.UTF8 as BU8+import qualified Data.ByteString as BS+import Data.ByteString.Unsafe+import Data.List++#include "pkcs11import.h"++{-+ Currently cannot use c2hs structure alignment and offset detector since it does not support pragma pack+ which is required by PKCS11, which is using 1 byte packing+ https://github.com/haskell/c2hs/issues/172+-}++_serialSession = {#const CKF_SERIAL_SESSION#} :: Int+_rwSession = {#const CKF_RW_SESSION#} :: Int++-- | Used to reference an object+type ObjectHandle = {#type CK_OBJECT_HANDLE#}+{#typedef CK_OBJECT_HANDLE ObjectHandle#}+{#default in `ObjectHandle' [CK_OBJECT_HANDLE] fromIntegral#}+{#default out `ObjectHandle' [CK_OBJECT_HANDLE] fromIntegral#}++type SlotId = {#type CK_SLOT_ID#}+{#typedef CK_SLOT_ID SlotId#}+{#default in `SlotId' [CK_SLOT_ID] fromIntegral#}+{#default out `SlotId' [CK_SLOT_ID] fromIntegral#}+type Rv = {#type CK_RV#}+{#typedef CK_RV Rv#}+{#default out `Rv' [CK_RV] fromIntegral#}+type CK_BBOOL = {#type CK_BBOOL#}+type CK_BYTE = {#type CK_BYTE#}+type CK_FLAGS = {#type CK_FLAGS#}+type GetFunctionListFunPtr = {#type CK_C_GetFunctionList#}+type NotifyFunPtr = {#type CK_NOTIFY#}+type SessionHandle = {#type CK_SESSION_HANDLE#}+{#typedef CK_SESSION_HANDLE SessionHandle#}+{#default in `SessionHandle' [CK_SESSION_HANDLE] fromIntegral#}+{#default out `SessionHandle' [CK_SESSION_HANDLE] fromIntegral#}++{#pointer *CK_FUNCTION_LIST as FunctionListPtr#}+{#pointer *CK_INFO as LibraryInfoPtr -> LibraryInfo#}+{#pointer *CK_SLOT_INFO as SlotInfoPtr -> SlotInfo#}+{#pointer *CK_TOKEN_INFO as TokenInfoPtr -> TokenInfo#}+{#pointer *CK_SESSION_INFO as SessionInfoPtr -> SessionInfo#}+{#pointer *CK_ATTRIBUTE as LlAttributePtr -> LlAttribute#}+{#pointer *CK_MECHANISM_INFO as MechInfoPtr -> MechInfo#}+{#pointer *CK_MECHANISM as MechPtr -> Mech#}++errSignatureInvalid = {#const CKR_SIGNATURE_INVALID#} :: {#type CK_RV#}+errBufferTooSmall = {#const CKR_BUFFER_TOO_SMALL#} :: {#type CK_RV#}++-- defined this one manually because I don't know how to make c2hs to define it yet+type GetFunctionListFun = (C2HSImp.Ptr (FunctionListPtr)) -> (IO C2HSImp.CULong)++foreign import ccall unsafe "dynamic"+ getFunctionList'_ :: GetFunctionListFunPtr -> GetFunctionListFun++data Version = Version {+ versionMajor :: Int,+ versionMinor :: Int+} deriving (Show)++instance Storable Version where+ sizeOf _ = {#sizeof CK_VERSION#}+ alignment _ = {#alignof CK_VERSION#}+ peek p = Version+ <$> liftM fromIntegral ({#get CK_VERSION->major#} p)+ <*> liftM fromIntegral ({#get CK_VERSION->minor#} p)+ poke p x = do+ {#set CK_VERSION->major#} p (fromIntegral $ versionMajor x)+ {#set CK_VERSION->minor#} p (fromIntegral $ versionMinor x)++-- | Represents general library information. Returned by 'getInfo' function.+data LibraryInfo = LibraryInfo {+ -- | Cryptoki interface version number, for compatibility with future revisions of this interface+ infoCryptokiVersion :: Version,+ -- | ID of the Cryptoki library manufacturer+ infoManufacturerId :: String,+ -- | bit flags reserved for future versions. Must be zero for this version+ infoFlags :: Int,+ infoLibraryDescription :: String,+ -- | Cryptoki library version number+ infoLibraryVersion :: Version+} deriving (Show)++instance Storable LibraryInfo where+ sizeOf _ = (2+32+4+32+10+2)+ alignment _ = 1+ peek p = do+ ver <- peek (p `plusPtr` {#offsetof CK_INFO->cryptokiVersion#}) :: IO Version+ manufacturerId <- peekCStringLen ((p `plusPtr` 2), 32)+ flags <- (\ptr -> do {C2HSImp.peekByteOff ptr (2+32) :: IO C2HSImp.CULong}) p+ --flags <- {#get CK_INFO->flags#} p+ libraryDescription <- peekCStringLen ((p `plusPtr` (2+32+4+10)), 32)+ --libraryDescription <- {# get CK_INFO->libraryDescription #} p+ libVer <- peek (p `plusPtr` (2+32+4+32+10)) :: IO Version+ return LibraryInfo {infoCryptokiVersion=ver,+ infoManufacturerId=manufacturerId,+ infoFlags=fromIntegral flags,+ infoLibraryDescription=libraryDescription,+ infoLibraryVersion=libVer+ }+ poke p v = do+ error "not implemented"+++data SlotInfo = SlotInfo {+ slotInfoDescription :: String,+ slotInfoManufacturerId :: String,+ -- | bit flags indicating capabilities and status of the slot as defined in https://www.cryptsoft.com/pkcs11doc/v220/pkcs11__all_8h.html#aCK_SLOT_INFO+ slotInfoFlags :: Int,+ slotInfoHardwareVersion :: Version,+ slotInfoFirmwareVersion :: Version+} deriving (Show)++instance Storable SlotInfo where+ sizeOf _ = (64+32+4+2+2)+ alignment _ = 1+ peek p = do+ description <- peekCStringLen ((p `plusPtr` 0), 64)+ manufacturerId <- peekCStringLen ((p `plusPtr` 64), 32)+ flags <- C2HSImp.peekByteOff p (64+32) :: IO C2HSImp.CULong+ hwVer <- peek (p `plusPtr` (64+32+4)) :: IO Version+ fwVer <- peek (p `plusPtr` (64+32+4+2)) :: IO Version+ return SlotInfo {slotInfoDescription=description,+ slotInfoManufacturerId=manufacturerId,+ slotInfoFlags=fromIntegral flags,+ slotInfoHardwareVersion=hwVer,+ slotInfoFirmwareVersion=fwVer+ }+ poke p v = do+ error "not implemented"+++data TokenInfo = TokenInfo {+ tokenInfoLabel :: String,+ tokenInfoManufacturerId :: String,+ tokenInfoModel :: String,+ tokenInfoSerialNumber :: String,+ -- | bit flags indicating capabilities and status of the device as defined in https://www.cryptsoft.com/pkcs11doc/v220/pkcs11__all_8h.html#aCK_TOKEN_INFO+ tokenInfoFlags :: Int--,+ --tokenInfoHardwareVersion :: Version,+ --tokenInfoFirmwareVersion :: Version+} deriving (Show)++instance Storable TokenInfo where+ sizeOf _ = (64+32+4+2+2)+ alignment _ = 1+ peek p = do+ label <- peekCStringLen ((p `plusPtr` 0), 32)+ manufacturerId <- peekCStringLen ((p `plusPtr` 32), 32)+ model <- peekCStringLen ((p `plusPtr` (32+32)), 16)+ serialNumber <- peekCStringLen ((p `plusPtr` (32+32+16)), 16)+ flags <- C2HSImp.peekByteOff p (32+32+16+16) :: IO C2HSImp.CULong+ --hwVer <- peek (p `plusPtr` (64+32+4)) :: IO Version+ --fwVer <- peek (p `plusPtr` (64+32+4+2)) :: IO Version+ return TokenInfo {tokenInfoLabel=label,+ tokenInfoManufacturerId=manufacturerId,+ tokenInfoModel=model,+ tokenInfoSerialNumber=serialNumber,+ tokenInfoFlags=fromIntegral flags--,+ --tokenInfoHardwareVersion=hwVer,+ --tokenInfoFirmwareVersion=fwVer+ }++ poke p v = do+ error "not implemented"+++-- | Represent information about a mechanism. Returned by 'getMechanismInfo' function.+data MechInfo = MechInfo {+ -- | Minimum size of a key in bits or bytes depending on the mechanism.+ mechInfoMinKeySize :: Int,+ -- | Maximum size of a key in bits or bytes depending on the mechanism.+ mechInfoMaxKeySize :: Int,+ -- | Mechanism's flags as described in https://www.cryptsoft.com/pkcs11doc/v220/pkcs11__all_8h.html#aCK_MECHANISM_INFO+ mechInfoFlags :: Int+} deriving (Show)++instance Storable MechInfo where+ sizeOf _ = {#sizeof CK_MECHANISM_INFO#}+ alignment _ = 1+ peek p = MechInfo+ <$> liftM fromIntegral ({#get CK_MECHANISM_INFO->ulMinKeySize#} p)+ <*> liftM fromIntegral ({#get CK_MECHANISM_INFO->ulMaxKeySize#} p)+ <*> liftM fromIntegral ({#get CK_MECHANISM_INFO->flags#} p)+ poke p x = do+ {#set CK_MECHANISM_INFO->ulMinKeySize#} p (fromIntegral $ mechInfoMinKeySize x)+ {#set CK_MECHANISM_INFO->ulMaxKeySize#} p (fromIntegral $ mechInfoMaxKeySize x)+ {#set CK_MECHANISM_INFO->flags#} p (fromIntegral $ mechInfoFlags x)+++-- | Represents mechanism with parameters to be used in cryptographic operation. Parameterless mechanism can be+-- created with 'simpleMech' function. Few example operations using this data structure are 'encrypt', 'generateKey'.+data Mech = Mech {+ mechType :: MechType,+ mechParamPtr :: Ptr (),+ mechParamSize :: Int+}++instance Storable Mech where+ sizeOf _ = {#sizeof CK_MECHANISM_TYPE#} + {#sizeof CK_VOID_PTR#} + {#sizeof CK_ULONG#}+ alignment _ = 1+ peek p = do+ error "not implemented"+ poke p x = do+ poke (p `plusPtr` 0) (fromEnum $ mechType x)+ poke (p `plusPtr` {#sizeof CK_MECHANISM_TYPE#}) (mechParamPtr x :: {#type CK_VOID_PTR#})+ poke (p `plusPtr` ({#sizeof CK_MECHANISM_TYPE#} + {#sizeof CK_VOID_PTR#})) (mechParamSize x)+++-- | Represent session information. Returned by 'getSessionInfo' function.+data SessionInfo = SessionInfo {+ -- | Slot for which session is open+ sessionInfoSlotId :: SlotId,+ -- | State of the session, e.g. 'ROPublicSession', 'RWUserFunctions'.+ sessionInfoState :: SessionState,+ -- | Session flags as described in https://www.cryptsoft.com/pkcs11doc/v220/pkcs11__all_8h.html#aCK_SESSION_INFO.+ sessionInfoFlags :: CULong,+ -- | Device specific error code.+ sessionInfoDeviceError :: CULong+} deriving (Show)+++instance Storable SessionInfo where+ sizeOf _ = {#sizeof CK_SESSION_INFO#}+ alignment _ = 1+ peek p = SessionInfo+ <$> liftM fromIntegral ({#get CK_SESSION_INFO->slotID#} p)+ <*> liftM culong2sessState ({#get CK_SESSION_INFO->state#} p)+ <*> {#get CK_SESSION_INFO->flags#} p+ <*> {#get CK_SESSION_INFO->ulDeviceError#} p+ where culong2sessState val = toEnum $ fromIntegral val+ poke p x = do+ error "not implemented"+++{#fun unsafe CK_FUNCTION_LIST.C_Initialize as initialize+ {`FunctionListPtr',+ alloca- `()' } -> `Rv'+#}++{#fun unsafe CK_FUNCTION_LIST.C_GetInfo as getInfo'+ {`FunctionListPtr',+ alloca- `LibraryInfo' peek* } -> `Rv'+#}++{#fun unsafe CK_FUNCTION_LIST.C_GetSlotList as getSlotList'+ {`FunctionListPtr',+ `Bool',+ castPtr `Ptr SlotId',+ `CULong' peek*} -> `Rv'+#}+++initToken' :: FunctionListPtr -> SlotId -> BU8.ByteString -> String -> IO (Rv)+initToken' funcListPtr slotId pin label = do+ unsafeUseAsCStringLen pin $ \(pinPtr, pinLen) -> do+ allocaArray 32 $ \labelArray -> do+ pokeArray labelArray (map CUChar (BS.unpack $ BU8.fromString label))+ res <- {#call unsafe CK_FUNCTION_LIST.C_InitToken#} funcListPtr (fromIntegral slotId) (castPtr pinPtr) (fromIntegral pinLen) labelArray+ return (fromIntegral res)+++initPin' :: FunctionListPtr -> CULong -> BU8.ByteString -> IO (Rv)+initPin' funcListPtr sessHandle pin = do+ unsafeUseAsCStringLen pin $ \(pinPtr, pinLen) -> do+ res <- {#call unsafe CK_FUNCTION_LIST.C_InitPIN#} funcListPtr sessHandle (castPtr pinPtr) (fromIntegral pinLen)+ return (fromIntegral res)+++setPin' :: FunctionListPtr -> CULong -> BU8.ByteString -> BU8.ByteString -> IO (Rv)+setPin' funcListPtr sessHandle oldPin newPin = do+ unsafeUseAsCStringLen oldPin $ \(oldPinPtr, oldPinLen) -> do+ unsafeUseAsCStringLen newPin $ \(newPinPtr, newPinLen) -> do+ res <- {#call unsafe CK_FUNCTION_LIST.C_SetPIN#} funcListPtr sessHandle (castPtr oldPinPtr)+ (fromIntegral oldPinLen) (castPtr newPinPtr) (fromIntegral newPinLen)+ return (fromIntegral res)+++{#fun unsafe CK_FUNCTION_LIST.C_GetSessionInfo as getSessionInfo'+ {`FunctionListPtr',+ `SessionHandle',+ alloca- `SessionInfo' peek* } -> `Rv'+#}+++{#fun unsafe CK_FUNCTION_LIST.C_GetSlotInfo as getSlotInfo'+ {`FunctionListPtr',+ `SlotId',+ alloca- `SlotInfo' peek* } -> `Rv'+#}+++{#fun unsafe CK_FUNCTION_LIST.C_GetTokenInfo as getTokenInfo'+ {`FunctionListPtr',+ `SlotId',+ alloca- `TokenInfo' peek* } -> `Rv'+#}+++openSession' functionListPtr slotId flags =+ alloca $ \slotIdPtr -> do+ res <- {#call unsafe CK_FUNCTION_LIST.C_OpenSession#} functionListPtr (fromIntegral slotId) (fromIntegral flags) nullPtr nullFunPtr slotIdPtr+ slotId <- peek slotIdPtr+ return (fromIntegral res, fromIntegral slotId)+++{#fun unsafe CK_FUNCTION_LIST.C_CloseSession as closeSession'+ {`FunctionListPtr',+ `SessionHandle' } -> `Rv'+#}+++{#fun unsafe CK_FUNCTION_LIST.C_CloseAllSessions as closeAllSessions'+ {`FunctionListPtr',+ `SlotId' } -> `Rv' fromIntegral#}+++{#fun unsafe CK_FUNCTION_LIST.C_Finalize as finalize+ {`FunctionListPtr',+ alloca- `()' } -> `Rv'+#}++{#fun unsafe CK_FUNCTION_LIST.C_FindObjectsInit as findObjectsInit'+ {`FunctionListPtr',+ `SessionHandle',+ `LlAttributePtr',+ `CULong'} -> `Rv'+#}+++findObjects' functionListPtr session maxObjects = do+ alloca $ \arrayLenPtr -> do+ poke arrayLenPtr (fromIntegral 0)+ allocaArray maxObjects $ \array -> do+ res <- {#call unsafe CK_FUNCTION_LIST.C_FindObjects#} functionListPtr session array (fromIntegral maxObjects) arrayLenPtr+ arrayLen <- peek arrayLenPtr+ objectHandles <- peekArray (fromIntegral arrayLen) array+ return (fromIntegral res, objectHandles)+++{#fun unsafe CK_FUNCTION_LIST.C_FindObjectsFinal as findObjectsFinal'+ {`FunctionListPtr',+ `CULong' } -> `Rv'+#}+++{#enum define UserType {CKU_USER as User, CKU_SO as SecurityOfficer, CKU_CONTEXT_SPECIFIC as ContextSpecific} deriving (Eq) #}++{#enum define SessionState {+ CKS_RO_PUBLIC_SESSION as ROPublicSession,+ CKS_RO_USER_FUNCTIONS as ROUserFunctions,+ CKS_RW_PUBLIC_SESSION as RWPublicSession,+ CKS_RW_USER_FUNCTIONS as RWUserFunctions,+ CKS_RW_SO_FUNCTIONS as RWSOFunctions+ } deriving (Eq,Show)+#}+++{#fun unsafe CK_FUNCTION_LIST.C_GetOperationState as getOperationState'+ {`FunctionListPtr',+ `SessionHandle',+ castPtr `Ptr CUChar',+ `CULong' peek*} -> `Rv'+#}+++_login :: FunctionListPtr -> SessionHandle -> UserType -> BU8.ByteString -> IO (Rv)+_login functionListPtr session userType pin = do+ unsafeUseAsCStringLen pin $ \(pinPtr, pinLen) -> do+ res <- {#call unsafe CK_FUNCTION_LIST.C_Login#} functionListPtr session (fromIntegral $ fromEnum userType) (castPtr pinPtr) (fromIntegral pinLen)+ return (fromIntegral res)+++{#fun unsafe CK_FUNCTION_LIST.C_Logout as logout'+ {`FunctionListPtr',+ `SessionHandle'} -> `Rv'+#}+++{#fun unsafe CK_FUNCTION_LIST.C_DestroyObject as destroyObject'+ {`FunctionListPtr',+ `SessionHandle',+ `ObjectHandle'} -> `Rv'+#}+++{#fun unsafe CK_FUNCTION_LIST.C_GenerateKey as generateKey'+ {`FunctionListPtr',+ `SessionHandle',+ with* `Mech',+ `LlAttributePtr',+ `CULong',+ alloca- `ObjectHandle' peek*} -> `Rv'+#}+++_generateKeyPair :: FunctionListPtr+ -> SessionHandle+ -> Mech+ -> [Attribute]+ -> [Attribute]+ -> IO (Rv, ObjectHandle, ObjectHandle)+_generateKeyPair functionListPtr session mech pubAttrs privAttrs = do+ alloca $ \pubKeyHandlePtr -> do+ alloca $ \privKeyHandlePtr -> do+ with mech $ \mechPtr -> do+ _withAttribs pubAttrs $ \pubAttrsPtr -> do+ _withAttribs privAttrs $ \privAttrsPtr -> do+ res <- {#call unsafe CK_FUNCTION_LIST.C_GenerateKeyPair#} functionListPtr session mechPtr pubAttrsPtr (fromIntegral $ length pubAttrs) privAttrsPtr (fromIntegral $ length privAttrs) pubKeyHandlePtr privKeyHandlePtr+ pubKeyHandle <- peek pubKeyHandlePtr+ privKeyHandle <- peek privKeyHandlePtr+ return (fromIntegral res, fromIntegral pubKeyHandle, fromIntegral privKeyHandle)+++{#fun unsafe CK_FUNCTION_LIST.C_GetMechanismList as getMechanismList'+ {`FunctionListPtr',+ `SlotId',+ castPtr `Ptr CUChar',+ `CULong' peek*} -> `Rv'+#}+++{#fun unsafe CK_FUNCTION_LIST.C_GetMechanismInfo as _getMechanismInfo+ {`FunctionListPtr',+ `SlotId',+ `Int',+ alloca- `MechInfo' peek* } -> `Rv'+#}+++rvToStr :: Rv -> String+rvToStr {#const CKR_OK#} = "ok"+rvToStr {#const CKR_ARGUMENTS_BAD#} = "bad arguments"+rvToStr {#const CKR_ATTRIBUTE_READ_ONLY#} = "attribute is read-only"+rvToStr {#const CKR_ATTRIBUTE_TYPE_INVALID#} = "invalid attribute type specified in template"+rvToStr {#const CKR_ATTRIBUTE_VALUE_INVALID#} = "invalid attribute value specified in template"+rvToStr {#const CKR_BUFFER_TOO_SMALL#} = "buffer too small"+rvToStr {#const CKR_CRYPTOKI_NOT_INITIALIZED#} = "cryptoki not initialized"+rvToStr {#const CKR_DATA_INVALID#} = "data invalid"+rvToStr {#const CKR_DEVICE_ERROR#} = "device error"+rvToStr {#const CKR_DEVICE_MEMORY#} = "device memory"+rvToStr {#const CKR_DEVICE_REMOVED#} = "device removed"+rvToStr {#const CKR_DOMAIN_PARAMS_INVALID#} = "invalid domain parameters"+rvToStr {#const CKR_ENCRYPTED_DATA_INVALID#} = "encrypted data is invalid"+rvToStr {#const CKR_ENCRYPTED_DATA_LEN_RANGE#} = "encrypted data length not in range"+rvToStr {#const CKR_FUNCTION_CANCELED#} = "function canceled"+rvToStr {#const CKR_FUNCTION_FAILED#} = "function failed"+rvToStr {#const CKR_FUNCTION_NOT_SUPPORTED#} = "function not supported"+rvToStr {#const CKR_GENERAL_ERROR#} = "general error"+rvToStr {#const CKR_HOST_MEMORY#} = "host memory"+rvToStr {#const CKR_KEY_FUNCTION_NOT_PERMITTED#} = "key function not permitted"+rvToStr {#const CKR_KEY_HANDLE_INVALID#} = "key handle invalid"+rvToStr {#const CKR_KEY_SIZE_RANGE#} = "key size range"+rvToStr {#const CKR_KEY_TYPE_INCONSISTENT#} = "key type inconsistent"+rvToStr {#const CKR_MECHANISM_INVALID#} = "invalid mechanism"+rvToStr {#const CKR_MECHANISM_PARAM_INVALID#} = "invalid mechanism parameter"+rvToStr {#const CKR_OPERATION_ACTIVE#} = "there is already an active operation in-progress"+rvToStr {#const CKR_OPERATION_NOT_INITIALIZED#} = "operation was not initialized"+rvToStr {#const CKR_PIN_EXPIRED#} = "PIN is expired, you need to setup a new PIN"+rvToStr {#const CKR_PIN_INCORRECT#} = "PIN is incorrect, authentication failed"+rvToStr {#const CKR_PIN_LOCKED#} = "PIN is locked, authentication failed"+rvToStr {#const CKR_SESSION_CLOSED#} = "session was closed in a middle of operation"+rvToStr {#const CKR_SESSION_COUNT#} = "session count"+rvToStr {#const CKR_SESSION_HANDLE_INVALID#} = "session handle is invalid"+rvToStr {#const CKR_SESSION_PARALLEL_NOT_SUPPORTED#} = "parallel session not supported"+rvToStr {#const CKR_SESSION_READ_ONLY#} = "session is read-only"+rvToStr {#const CKR_SESSION_READ_ONLY_EXISTS#} = "read-only session exists, SO cannot login"+rvToStr {#const CKR_SESSION_READ_WRITE_SO_EXISTS#} = "read-write SO session exists"+rvToStr {#const CKR_SLOT_ID_INVALID#} = "slot id invalid"+rvToStr {#const CKR_TEMPLATE_INCOMPLETE#} = "provided template is incomplete"+rvToStr {#const CKR_TEMPLATE_INCONSISTENT#} = "provided template is inconsistent"+rvToStr {#const CKR_TOKEN_NOT_PRESENT#} = "token not present"+rvToStr {#const CKR_TOKEN_NOT_RECOGNIZED#} = "token not recognized"+rvToStr {#const CKR_TOKEN_WRITE_PROTECTED#} = "token is write protected"+rvToStr {#const CKR_UNWRAPPING_KEY_HANDLE_INVALID#} = "unwrapping key handle invalid"+rvToStr {#const CKR_UNWRAPPING_KEY_SIZE_RANGE#} = "unwrapping key size not in range"+rvToStr {#const CKR_UNWRAPPING_KEY_TYPE_INCONSISTENT#} = "unwrapping key type inconsistent"+rvToStr {#const CKR_USER_NOT_LOGGED_IN#} = "user needs to be logged in to perform this operation"+rvToStr {#const CKR_USER_ALREADY_LOGGED_IN#} = "user already logged in"+rvToStr {#const CKR_USER_ANOTHER_ALREADY_LOGGED_IN#} = "another user already logged in, first another user should be logged out"+rvToStr {#const CKR_USER_PIN_NOT_INITIALIZED#} = "user PIN not initialized, need to setup PIN first"+rvToStr {#const CKR_USER_TOO_MANY_TYPES#} = "cannot login user, somebody should logout first"+rvToStr {#const CKR_USER_TYPE_INVALID#} = "invalid value for user type"+rvToStr {#const CKR_WRAPPED_KEY_INVALID#} = "wrapped key invalid"+rvToStr {#const CKR_WRAPPED_KEY_LEN_RANGE#} = "wrapped key length not in range"+rvToStr {#const CKR_KEY_UNEXTRACTABLE#} = "key unextractable"+rvToStr rv = "unknown value for error " ++ (show rv)+++-- Attributes++{#enum define ClassType {+ CKO_DATA as Data,+ CKO_CERTIFICATE as Certificate,+ CKO_PUBLIC_KEY as PublicKey, -- ^ asymmetric public key, e.g. RSA public key+ CKO_PRIVATE_KEY as PrivateKey, -- ^ asymmetric private key, e.g. RSA private key+ CKO_SECRET_KEY as SecretKey, -- ^ symmetric key, e.g. AES key+ CKO_HW_FEATURE as HWFeature,+ CKO_DOMAIN_PARAMETERS as DomainParameters, -- ^ e.g. parameters for Diffie-Hellman+ CKO_MECHANISM as Mechanism+} deriving (Show, Eq)+#}++{#enum define KeyTypeValue {+ CKK_RSA as RSA,+ CKK_DSA as DSA,+ CKK_DH as DH,+ CKK_ECDSA as ECDSA,+ CKK_EC as EC,+ CKK_AES as AES+ } deriving (Show, Eq) #}++{#enum define AttributeType {+ CKA_CLASS as ClassType,+ CKA_TOKEN as TokenType,+ CKA_PRIVATE as PrivateType,+ CKA_LABEL as LabelType,+ CKA_APPLICATION as ApplicationType,+ CKA_VALUE as ValueType,+ CKA_OBJECT_ID as ObjectType,+ CKA_CERTIFICATE_TYPE as CertificateType,+ CKA_ISSUER as IssuerType,+ CKA_SERIAL_NUMBER as SerialNumberType,+ CKA_AC_ISSUER as AcIssuerType,+ CKA_OWNER as OwnerType,+ CKA_ATTR_TYPES as AttrTypesType,+ CKA_TRUSTED as TrustedType,+ CKA_CERTIFICATE_CATEGORY as CertificateCategoryType,+ CKA_JAVA_MIDP_SECURITY_DOMAIN as JavaMidpSecurityDomainType,+ CKA_URL as UrlType,+ CKA_HASH_OF_SUBJECT_PUBLIC_KEY as HashOfSubjectPublicKeyType,+ CKA_HASH_OF_ISSUER_PUBLIC_KEY as HashOfIssuerPublicKeyType,+ CKA_CHECK_VALUE as CheckValueType,++ CKA_KEY_TYPE as KeyTypeType,+ CKA_SUBJECT as SubjectType,+ CKA_ID as IdType,+ CKA_SENSITIVE as SensitiveType,+ CKA_ENCRYPT as EncryptType,+ CKA_DECRYPT as DecryptType,+ CKA_WRAP as WrapType,+ CKA_UNWRAP as UnwrapType,+ CKA_SIGN as SignType,+ CKA_SIGN_RECOVER as SignRecoverType,+ CKA_VERIFY as VerifyType,+ CKA_VERIFY_RECOVER as VerifyRecoverType,+ CKA_DERIVE as DeriveType,+ CKA_START_DATE as StartDateType,+ CKA_END_DATE as EndDataType,+ CKA_PUBLIC_EXPONENT as PublicExponentType,+ CKA_PRIVATE_EXPONENT as PrivateExponentType,+ CKA_MODULUS as ModulusType,+ CKA_MODULUS_BITS as ModulusBitsType,+ CKA_PRIME_1 as Prime1Type,+ CKA_PRIME_2 as Prime2Type,+ CKA_EXPONENT_1 as Exponent1Type,+ CKA_EXPONENT_2 as Exponent2Type,+ CKA_COEFFICIENT as CoefficientType,+ CKA_PRIME as PrimeType,+ CKA_SUBPRIME as SubPrimeType,+ CKA_BASE as BaseType,++ CKA_PRIME_BITS as PrimeBitsType,+ CKA_SUBPRIME_BITS as SubPrimeBitsType,++ CKA_VALUE_BITS as ValueBitsType,+ CKA_VALUE_LEN as ValueLenType,+ CKA_EXTRACTABLE as ExtractableType,+ CKA_LOCAL as LocalType,+ CKA_NEVER_EXTRACTABLE as NeverExtractableType,+ CKA_ALWAYS_SENSITIVE as AlwaysSensitiveType,+ CKA_KEY_GEN_MECHANISM as KeyGenMechanismType,++ CKA_MODIFIABLE as ModifiableType,++ -- CKA_ECDSA_PARAMS is deprecated in v2.11,+ -- CKA_EC_PARAMS is preferred.+ CKA_ECDSA_PARAMS as EcdsaParamsType,+ CKA_EC_PARAMS as EcParamsType,++ CKA_EC_POINT as EcPointType,++ -- CKA_SECONDARY_AUTH, CKA_AUTH_PIN_FLAGS,+ -- are new for v2.10. Deprecated in v2.11 and onwards.+ CKA_SECONDARY_AUTH as SecondaryAuthType,+ CKA_AUTH_PIN_FLAGS as AuthPinFlagsType,++ CKA_ALWAYS_AUTHENTICATE as AlwaysAuthenticateType,++ CKA_WRAP_WITH_TRUSTED as WrapWithTrustedType,+ CKA_WRAP_TEMPLATE as WrapTemplateType,+ CKA_UNWRAP_TEMPLATE as UnwrapTemplateType,+ CKA_DERIVE_TEMPLATE as DeriveTemplateType,++ CKA_OTP_FORMAT as OtpFormatType,+ CKA_OTP_LENGTH as OtpLengthType,+ CKA_OTP_TIME_INTERVAL as OtpTimeIntervalType,+ CKA_OTP_USER_FRIENDLY_MODE as OtpUserFriendlyModeType,+ CKA_OTP_CHALLENGE_REQUIREMENT as OtpChallengeRequirementType,+ CKA_OTP_TIME_REQUIREMENT as OtpTimeRequirementType,+ CKA_OTP_COUNTER_REQUIREMENT as OtpCounterRequirementType,+ CKA_OTP_PIN_REQUIREMENT as OtpPinRequirementType,+ CKA_OTP_COUNTER as OtpCounterType,+ CKA_OTP_TIME as OtpTimeType,+ CKA_OTP_USER_IDENTIFIER as OtpUserIdentifierType,+ CKA_OTP_SERVICE_IDENTIFIER as OtpServiceIdentifierType,+ CKA_OTP_SERVICE_LOGO as OtpServiceLogoType,+ CKA_OTP_SERVICE_LOGO_TYPE as OtpServiceLogoTypeType,++ CKA_GOSTR3410_PARAMS as GostR3410ParamsType,+ CKA_GOSTR3411_PARAMS as GostR3411ParamsType,+ CKA_GOST28147_PARAMS as Gost28147ParamsType,++ CKA_HW_FEATURE_TYPE as HwFeatureTypeType,+ CKA_RESET_ON_INIT as ResetOnInitType,+ CKA_HAS_RESET as HasResetType,++ CKA_PIXEL_X as PixelXType,+ CKA_PIXEL_Y as PixelYType,+ CKA_RESOLUTION as ResolutionType,+ CKA_CHAR_ROWS as CharRowsType,+ CKA_CHAR_COLUMNS as CharColumnsType,+ CKA_COLOR as ColorType,+ CKA_BITS_PER_PIXEL as BitPerPixelType,+ CKA_CHAR_SETS as CharSetsType,+ CKA_ENCODING_METHODS as EncodingMethodsType,+ CKA_MIME_TYPES as MimeTypesType,+ CKA_MECHANISM_TYPE as MechanismTypeType,+ CKA_REQUIRED_CMS_ATTRIBUTES as RequiredCmsAttributesType,+ CKA_DEFAULT_CMS_ATTRIBUTES as DefaultCmsAttributesType,+ CKA_SUPPORTED_CMS_ATTRIBUTES as SupportedCmsAttributesType,+ CKA_ALLOWED_MECHANISMS as AllowedMechanismsType,++ CKA_VENDOR_DEFINED as VendorDefinedType+ } deriving (Show, Eq) #}++-- | Represents an attribute of an object+data Attribute = Class ClassType -- ^ class of an object, e.g. 'PrivateKey', 'SecretKey'+ | KeyType KeyTypeValue -- ^ e.g. 'RSA' or 'AES'+ | Label String -- ^ object's label+ | Token Bool -- ^ whether object is stored on the token or is a temporary session object+ | Decrypt Bool -- ^ allow/deny encryption function for an object+ | Sign Bool -- ^ allow/deny signing function for an object+ | ModulusBits Int -- ^ number of bits used by modulus, for example in RSA public key+ | Modulus Integer -- ^ modulus value, used by RSA keys+ | PublicExponent Integer -- ^ value of public exponent, used by RSA public keys+ | PrimeBits Int -- ^ number of bits used by prime in classic Diffie-Hellman+ | Prime Integer -- ^ value of prime modulus, used in classic Diffie-Hellman+ | Base Integer -- ^ value of generator, used in classic Diffie-Hellman+ | ValueLen Int -- ^ length in bytes of the corresponding 'Value' attribute+ | Value BS.ByteString -- ^ object's value attribute, for example it is a DER encoded certificate for certificate objects+ | Extractable Bool -- ^ allows or denys extraction of certain attributes of private keys+ | EcParams BS.ByteString -- ^ DER encoded ANSI X9.62 parameters value for elliptic-curve algorithm+ | EcdsaParams BS.ByteString -- ^ DER encoded ANSI X9.62 parameters value for elliptic-curve algorithm+ | EcPoint BS.ByteString -- ^ DER encoded ANSI X9.62 point for elliptic-curve algorithm+ deriving (Show)++data LlAttribute = LlAttribute {+ attributeType :: AttributeType,+ attributeValuePtr :: Ptr (),+ attributeSize :: {#type CK_ULONG#}+}++instance Storable LlAttribute where+ sizeOf _ = {#sizeof CK_ATTRIBUTE_TYPE#} + {#sizeof CK_VOID_PTR#} + {#sizeof CK_ULONG#}+ alignment _ = 1+ poke p x = do+ poke (p `plusPtr` 0) (fromEnum $ attributeType x)+ poke (p `plusPtr` {#sizeof CK_ATTRIBUTE_TYPE#}) (attributeValuePtr x :: {#type CK_VOID_PTR#})+ poke (p `plusPtr` ({#sizeof CK_ATTRIBUTE_TYPE#} + {#sizeof CK_VOID_PTR#})) (attributeSize x)+ peek p = do+ attrType <- peek (p `plusPtr` 0) :: IO {#type CK_ATTRIBUTE_TYPE#}+ valPtr <- peek (p `plusPtr` {#sizeof CK_ATTRIBUTE_TYPE#})+ valSize <- peek (p `plusPtr` ({#sizeof CK_ATTRIBUTE_TYPE#} + {#sizeof CK_VOID_PTR#}))+ return $ LlAttribute (toEnum $ fromIntegral attrType) valPtr valSize+++_attrType :: Attribute -> AttributeType+_attrType (Class _) = ClassType+_attrType (KeyType _) = KeyTypeType+_attrType (Label _) = LabelType+_attrType (ModulusBits _) = ModulusBitsType+_attrType (PrimeBits _) = PrimeBitsType+_attrType (Token _) = TokenType+_attrType (ValueLen _) = ValueLenType+_attrType (Extractable _) = ExtractableType+_attrType (Value _) = ValueType+_attrType (Prime _) = PrimeType+_attrType (Base _) = BaseType+_attrType (EcParams _) = EcParamsType+_attrType (EcPoint _) = EcPointType+++_valueSize :: Attribute -> Int+_valueSize (Class _) = {#sizeof CK_OBJECT_CLASS#}+_valueSize (KeyType _) = {#sizeof CK_KEY_TYPE#}+_valueSize (Label l) = BU8.length $ BU8.fromString l+_valueSize (ModulusBits _) = {#sizeof CK_ULONG#}+_valueSize (PrimeBits _) = {#sizeof CK_ULONG#}+_valueSize (Token _) = {#sizeof CK_BBOOL#}+_valueSize (ValueLen _) = {#sizeof CK_ULONG#}+_valueSize (Extractable _) = {#sizeof CK_BBOOL#}+_valueSize (Value bs) = BS.length bs+_valueSize (Prime p) = _bigIntLen p+_valueSize (Base b) = _bigIntLen b+_valueSize (EcParams bs) = BS.length bs+_valueSize (EcPoint bs) = BS.length bs+++_pokeValue :: Attribute -> Ptr () -> IO ()+_pokeValue (Class c) ptr = poke (castPtr ptr :: Ptr {#type CK_OBJECT_CLASS#}) (fromIntegral $ fromEnum c)+_pokeValue (KeyType k) ptr = poke (castPtr ptr :: Ptr {#type CK_KEY_TYPE#}) (fromIntegral $ fromEnum k)+_pokeValue (Label l) ptr = unsafeUseAsCStringLen (BU8.fromString l) $ \(src, len) -> copyBytes ptr (castPtr src :: Ptr ()) len+_pokeValue (ModulusBits l) ptr = poke (castPtr ptr :: Ptr {#type CK_ULONG#}) (fromIntegral l)+_pokeValue (PrimeBits l) ptr = poke (castPtr ptr :: Ptr {#type CK_ULONG#}) (fromIntegral l)+_pokeValue (Token b) ptr = poke (castPtr ptr :: Ptr {#type CK_BBOOL#}) (fromBool b :: {#type CK_BBOOL#})+_pokeValue (ValueLen l) ptr = poke (castPtr ptr :: Ptr {#type CK_ULONG#}) (fromIntegral l :: {#type CK_ULONG#})+_pokeValue (Extractable b) ptr = poke (castPtr ptr :: Ptr {#type CK_BBOOL#}) (fromBool b :: {#type CK_BBOOL#})+_pokeValue (Value bs) ptr = unsafeUseAsCStringLen bs $ \(src, len) -> copyBytes ptr (castPtr src :: Ptr ()) len+_pokeValue (Prime p) ptr = _pokeBigInt p (castPtr ptr)+_pokeValue (Base b) ptr = _pokeBigInt b (castPtr ptr)+_pokeValue (EcParams bs) ptr = unsafeUseAsCStringLen bs $ \(src, len) -> copyBytes ptr (castPtr src :: Ptr ()) len+_pokeValue (EcPoint bs) ptr = unsafeUseAsCStringLen bs $ \(src, len) -> copyBytes ptr (castPtr src :: Ptr ()) len+++_pokeValues :: [Attribute] -> Ptr () -> IO ()+_pokeValues [] p = return ()+_pokeValues (a:rem) p = do+ _pokeValue a p+ _pokeValues rem (p `plusPtr` (_valueSize a))+++_valuesSize :: [Attribute] -> Int+_valuesSize attribs = foldr (+) 0 (map (_valueSize) attribs)+++_makeLowLevelAttrs :: [Attribute] -> Ptr () -> [LlAttribute]+_makeLowLevelAttrs [] valuePtr = []+_makeLowLevelAttrs (a:rem) valuePtr =+ let valuePtr' = valuePtr `plusPtr` (_valueSize a)+ llAttr = LlAttribute {attributeType=_attrType a, attributeValuePtr=valuePtr, attributeSize=(fromIntegral $ _valueSize a)}+ in+ llAttr:(_makeLowLevelAttrs rem valuePtr')+++_withAttribs :: [Attribute] -> (Ptr LlAttribute -> IO a) -> IO a+_withAttribs attribs f = do+ allocaBytes (_valuesSize attribs) $ \valuesPtr -> do+ _pokeValues attribs valuesPtr+ allocaArray (length attribs) $ \attrsPtr -> do+ pokeArray attrsPtr (_makeLowLevelAttrs attribs valuesPtr)+ f attrsPtr+++-- from http://hackage.haskell.org/package/binary-0.5.0.2/docs/src/Data-Binary.html#unroll+unroll :: Integer -> [Word8]+unroll = unfoldr step+ where+ step 0 = Nothing+ step i = Just (fromIntegral i, i `shiftR` 8)+++_bigIntLen i = length $ unroll i+++_pokeBigInt i ptr = pokeArray ptr (unroll i)+++_peekBigInt :: Ptr () -> CULong -> IO Integer+_peekBigInt ptr len = do+ arr <- peekArray (fromIntegral len) (castPtr ptr :: Ptr Word8)+ return $ foldl (\acc v -> (fromIntegral v) + (acc * 256)) 0 arr+++_llAttrToAttr :: LlAttribute -> IO Attribute+_llAttrToAttr (LlAttribute ClassType ptr len) = do+ val <- peek (castPtr ptr :: Ptr {#type CK_OBJECT_CLASS#})+ return (Class $ toEnum $ fromIntegral val)+_llAttrToAttr (LlAttribute ModulusType ptr len) = do+ val <- _peekBigInt ptr len+ return (Modulus val)+_llAttrToAttr (LlAttribute PublicExponentType ptr len) = do+ val <- _peekBigInt ptr len+ return (PublicExponent val)+_llAttrToAttr (LlAttribute PrimeType ptr len) = do+ val <- _peekBigInt ptr len+ return (Prime val)+_llAttrToAttr (LlAttribute BaseType ptr len) = do+ val <- _peekBigInt ptr len+ return (Base val)+_llAttrToAttr (LlAttribute DecryptType ptr len) = do+ val <- peek (castPtr ptr :: Ptr {#type CK_BBOOL#})+ return $ Decrypt(val /= 0)+_llAttrToAttr (LlAttribute SignType ptr len) = do+ val <- peek (castPtr ptr :: Ptr {#type CK_BBOOL#})+ return $ Sign(val /= 0)+_llAttrToAttr (LlAttribute EcParamsType ptr len) = do+ val <- BS.packCStringLen (castPtr ptr, fromIntegral len)+ return $ EcParams val+_llAttrToAttr (LlAttribute EcdsaParamsType ptr len) = do+ val <- BS.packCStringLen (castPtr ptr, fromIntegral len)+ return $ EcdsaParams val+_llAttrToAttr (LlAttribute EcPointType ptr len) = do+ val <- BS.packCStringLen (castPtr ptr, fromIntegral len)+ return $ EcPoint val+_llAttrToAttr (LlAttribute typ _ _) = error("_llAttrToAttr needs to be implemented for " ++ (show typ))+++{#fun unsafe CK_FUNCTION_LIST.C_DeriveKey as deriveKey'+ {`FunctionListPtr',+ `SessionHandle',+ with* `Mech',+ `ObjectHandle',+ `LlAttributePtr',+ `CULong',+ alloca- `ObjectHandle' peek*} -> `Rv'+#}+++{#fun unsafe CK_FUNCTION_LIST.C_CreateObject as createObject'+ {`FunctionListPtr',+ `SessionHandle',+ `LlAttributePtr',+ `CULong',+ alloca- `ObjectHandle' peek*} -> `Rv'+#}+++{#fun unsafe CK_FUNCTION_LIST.C_CopyObject as copyObject'+ {`FunctionListPtr',+ `SessionHandle',+ `ObjectHandle',+ `LlAttributePtr',+ `CULong',+ alloca- `ObjectHandle' peek*} -> `Rv'+#}+++{#fun unsafe CK_FUNCTION_LIST.C_GetObjectSize as getObjectSize'+ {`FunctionListPtr',+ `SessionHandle',+ `ObjectHandle',+ alloca- `CULong' peek*} -> `Rv'+#}+++_getAttr :: FunctionListPtr -> SessionHandle -> ObjectHandle -> AttributeType -> Ptr x -> IO ()+_getAttr functionListPtr sessionHandle objHandle attrType valPtr = do+ alloca $ \attrPtr -> do+ poke attrPtr (LlAttribute attrType (castPtr valPtr) (fromIntegral $ sizeOf valPtr))+ rv <- {#call unsafe CK_FUNCTION_LIST.C_GetAttributeValue#} functionListPtr sessionHandle objHandle attrPtr 1+ if rv /= 0+ then fail $ "failed to get attribute: " ++ (rvToStr rv)+ else return ()+++getObjectAttr' :: FunctionListPtr -> SessionHandle -> ObjectHandle -> AttributeType -> IO Attribute+getObjectAttr' functionListPtr sessionHandle objHandle attrType = do+ alloca $ \attrPtr -> do+ poke attrPtr (LlAttribute attrType nullPtr 0)+ rv <- {#call unsafe CK_FUNCTION_LIST.C_GetAttributeValue#} functionListPtr sessionHandle objHandle attrPtr 1+ attrWithLen <- peek attrPtr+ allocaBytes (fromIntegral $ attributeSize attrWithLen) $ \attrVal -> do+ poke attrPtr (LlAttribute attrType attrVal (attributeSize attrWithLen))+ rv <- {#call unsafe CK_FUNCTION_LIST.C_GetAttributeValue#} functionListPtr sessionHandle objHandle attrPtr 1+ if rv /= 0+ then fail $ "failed to get attribute: " ++ (rvToStr rv)+ else do+ llAttr <- peek attrPtr+ _llAttrToAttr llAttr+++{#fun unsafe CK_FUNCTION_LIST.C_SetAttributeValue as setAttributeValue'+ {`FunctionListPtr',+ `SessionHandle',+ `ObjectHandle',+ `LlAttributePtr',+ `CULong'} -> `Rv'+#}++{#enum define MechType {+ CKM_RSA_PKCS_KEY_PAIR_GEN as RsaPkcsKeyPairGen,+ CKM_RSA_PKCS as RsaPkcs,+ CKM_RSA_9796 as Rsa9796,+ CKM_RSA_X_509 as RsaX509,+ CKM_MD2_RSA_PKCS as Md2RsaPkcs,-- 0x00000004+ CKM_MD5_RSA_PKCS as Md5RsaPkcs,-- 0x00000005+ CKM_SHA1_RSA_PKCS as Sha1RsaPkcs,-- 0x00000006+ CKM_RIPEMD128_RSA_PKCS as RipeMd128RsaPkcs,-- 0x00000007+ CKM_RIPEMD160_RSA_PKCS as RipeMd160RsaPkcs,-- 0x00000008+ CKM_RSA_PKCS_OAEP as RsaPkcsOaep,-- 0x00000009+ CKM_RSA_X9_31_KEY_PAIR_GEN as RsaX931KeyPairGen,-- 0x0000000A+ CKM_RSA_X9_31 as RsaX931,-- 0x0000000B+ CKM_SHA1_RSA_X9_31 as Sha1RsaX931,-- 0x0000000C+ CKM_RSA_PKCS_PSS as RsaPkcsPss,-- 0x0000000D+ CKM_SHA1_RSA_PKCS_PSS as Sha1RsaPkcsPss,-- 0x0000000E+ CKM_DSA_KEY_PAIR_GEN as DsaKeyPairGen,-- 0x00000010+ CKM_DSA as Dsa,-- 0x00000011+ CKM_DSA_SHA1 as DsaSha1,-- 0x00000012+ CKM_DH_PKCS_KEY_PAIR_GEN as DhPkcsKeyPairGen,-- 0x00000020+ CKM_DH_PKCS_DERIVE as DhPkcsDerive,-- 0x00000021+ CKM_X9_42_DH_KEY_PAIR_GEN as X942DhKeyPairGen,-- 0x00000030+ CKM_X9_42_DH_DERIVE as X942DhDerive,-- 0x00000031+ CKM_X9_42_DH_HYBRID_DERIVE as X942DhHybridDerive,-- 0x00000032+ CKM_X9_42_MQV_DERIVE as X942MqvDerive,-- 0x00000033+ CKM_SHA256_RSA_PKCS as Sha256RsaPkcs,-- 0x00000040+ CKM_SHA384_RSA_PKCS as Sha384RsaPkcs,-- 0x00000041+ CKM_SHA512_RSA_PKCS as Sha512RsaPkcs,-- 0x00000042+ CKM_SHA256_RSA_PKCS_PSS as Sha256RsaPkcsPss,-- 0x00000043+ CKM_SHA384_RSA_PKCS_PSS as Sha384RsaPkcsPss,-- 0x00000044+ CKM_SHA512_RSA_PKCS_PSS as Sha512RsaPkcsPss,-- 0x00000045++ -- SHA-224 RSA mechanisms are new for PKCS #11 v2.20 amendment 3+ CKM_SHA224_RSA_PKCS as Sha224RsaPkcs,-- 0x00000046+ CKM_SHA224_RSA_PKCS_PSS as Sha224RsaPkcsPss,-- 0x00000047++ CKM_RC2_KEY_GEN as Rc2KeyGen,-- 0x00000100+ CKM_RC2_ECB as Rc2Ecb,-- 0x00000101+ CKM_RC2_CBC as Rc2Cbc,-- 0x00000102+ CKM_RC2_MAC as Rc2Mac,-- 0x00000103++ -- CKM_RC2_MAC_GENERAL and CKM_RC2_CBC_PAD are new for v2.0+ CKM_RC2_MAC_GENERAL as Rc2MacGeneral,-- 0x00000104+ CKM_RC2_CBC_PAD as Rc2CbcPad,--0x00000105++ CKM_RC4_KEY_GEN as Rc4KeyGen,--0x00000110+ CKM_RC4 as Rc4,--0x00000111+ CKM_DES_KEY_GEN as DesKeyGen,--0x00000120+ CKM_DES_ECB as DesEcb,--0x00000121+ CKM_DES_CBC as DesCbc,--0x00000122+ CKM_DES_MAC as DesMac,--0x00000123++ -- CKM_DES_MAC_GENERAL and CKM_DES_CBC_PAD are new for v2.0+ CKM_DES_MAC_GENERAL as DesMacGeneral,--0x00000124+ CKM_DES_CBC_PAD as DesCbcPad,--0x00000125++ CKM_DES2_KEY_GEN as Des2KeyGen,--0x00000130+ CKM_DES3_KEY_GEN as Des3KeyGen,--0x00000131+ CKM_DES3_ECB as Des3Ecb,--0x00000132+ CKM_DES3_CBC as Des3Cbc,--0x00000133+ CKM_DES3_MAC as Des3Mac,--0x00000134++ -- CKM_DES3_MAC_GENERAL, CKM_DES3_CBC_PAD, CKM_CDMF_KEY_GEN,+ -- CKM_CDMF_ECB, CKM_CDMF_CBC, CKM_CDMF_MAC,+ -- CKM_CDMF_MAC_GENERAL, and CKM_CDMF_CBC_PAD are new for v2.0+ CKM_DES3_MAC_GENERAL as Des3MacGeneral,--0x00000135+ CKM_DES3_CBC_PAD as Des3CbcPad,--0x00000136+ CKM_CDMF_KEY_GEN as CdmfKeyGen,--0x00000140+ CKM_CDMF_ECB as CdmfEcb,--0x00000141+ CKM_CDMF_CBC as CdmfCbc,--0x00000142+ CKM_CDMF_MAC as CdmfMac,--0x00000143+ CKM_CDMF_MAC_GENERAL as CdmfMacGeneral,--0x00000144+ CKM_CDMF_CBC_PAD as CdmfCbcPad,--0x00000145++ -- the following four DES mechanisms are new for v2.20+ CKM_DES_OFB64 as DesOfb64,--0x00000150+ CKM_DES_OFB8 as DesOfb8,--0x00000151+ CKM_DES_CFB64 as DesCfb64,--0x00000152+ CKM_DES_CFB8 as DesCfb8,--0x00000153++ CKM_MD2 as Md2,--0x00000200++ -- CKM_MD2_HMAC and CKM_MD2_HMAC_GENERAL are new for v2.0+ CKM_MD2_HMAC as Md2Hmac,--0x00000201+ CKM_MD2_HMAC_GENERAL as Md2HmacGeneral,--0x00000202++ CKM_MD5 as Md5,--0x00000210++ -- CKM_MD5_HMAC and CKM_MD5_HMAC_GENERAL are new for v2.0+ CKM_MD5_HMAC as Md5Hmac,--0x00000211+ CKM_MD5_HMAC_GENERAL as Md5HmacGeneral,--0x00000212++ CKM_SHA_1 as Sha1,--0x00000220++ -- CKM_SHA_1_HMAC and CKM_SHA_1_HMAC_GENERAL are new for v2.0+ CKM_SHA_1_HMAC as Sha1Hmac,--0x00000221+ CKM_SHA_1_HMAC_GENERAL as Sha1HmacGeneral,--0x00000222++ -- CKM_RIPEMD128, CKM_RIPEMD128_HMAC,+ -- CKM_RIPEMD128_HMAC_GENERAL, CKM_RIPEMD160, CKM_RIPEMD160_HMAC,+ -- and CKM_RIPEMD160_HMAC_GENERAL are new for v2.10+ CKM_RIPEMD128 as RipeMd128,--0x00000230+ CKM_RIPEMD128_HMAC as RipeMd128Hmac,--0x00000231+ CKM_RIPEMD128_HMAC_GENERAL as RipeMd128HmacGeneral,--0x00000232+ CKM_RIPEMD160 as Ripe160,--0x00000240+ CKM_RIPEMD160_HMAC as Ripe160Hmac,--0x00000241+ CKM_RIPEMD160_HMAC_GENERAL as Ripe160HmacGeneral,--0x00000242++ -- CKM_SHA256/384/512 are new for v2.20+ CKM_SHA256 as Sha256,--0x00000250+ CKM_SHA256_HMAC as Sha256Hmac,--0x00000251+ CKM_SHA256_HMAC_GENERAL as Sha256HmacGeneral,--0x00000252++ -- SHA-224 is new for PKCS #11 v2.20 amendment 3+ CKM_SHA224 as Sha224,--0x00000255+ CKM_SHA224_HMAC as Sha224Hmac,--0x00000256+ CKM_SHA224_HMAC_GENERAL as Sha224HmacGeneral,--0x00000257++ CKM_SHA384 as Sha384,--0x00000260+ CKM_SHA384_HMAC as Sha384Hmac,--0x00000261+ CKM_SHA384_HMAC_GENERAL as Sha384HmacGeneral,--0x00000262+ CKM_SHA512 as Sha512,--0x00000270+ CKM_SHA512_HMAC as Sha512Hmac,--0x00000271+ CKM_SHA512_HMAC_GENERAL as Sha512HmacGeneral,--0x00000272++ -- SecurID is new for PKCS #11 v2.20 amendment 1+ --CKM_SECURID_KEY_GEN 0x00000280+ --CKM_SECURID 0x00000282++ -- HOTP is new for PKCS #11 v2.20 amendment 1+ --CKM_HOTP_KEY_GEN 0x00000290+ --CKM_HOTP 0x00000291++ -- ACTI is new for PKCS #11 v2.20 amendment 1+ --CKM_ACTI 0x000002A0+ --CKM_ACTI_KEY_GEN 0x000002A1++ -- All of the following mechanisms are new for v2.0+ -- Note that CAST128 and CAST5 are the same algorithm+ CKM_CAST_KEY_GEN as CastKeyGen,--0x00000300+ CKM_CAST_ECB as CastEcb,--0x00000301+ CKM_CAST_CBC as CastCbc,--0x00000302+ CKM_CAST_MAC as CastMac,--0x00000303+ CKM_CAST_MAC_GENERAL as CastMacGeneral,--0x00000304+ CKM_CAST_CBC_PAD as CastCbcPad,--0x00000305+ CKM_CAST3_KEY_GEN as Cast3KeyGen,--0x00000310+ CKM_CAST3_ECB as Cast3Ecb,--0x00000311+ CKM_CAST3_CBC as Cast3Cbc,--0x00000312+ CKM_CAST3_MAC as Cast3Mac,--0x00000313+ CKM_CAST3_MAC_GENERAL as Cast3MacGeneral,--0x00000314+ CKM_CAST3_CBC_PAD as Cast3CbcPad,--0x00000315+ CKM_CAST5_KEY_GEN as Cast5KeyGen,--0x00000320+ CKM_CAST128_KEY_GEN as Cast128KeyGen,--0x00000320+ CKM_CAST5_ECB as Cast5Ecb,--0x00000321+ CKM_CAST128_ECB as Cast128Ecb,--0x00000321+ CKM_CAST5_CBC as Cast5Cbc,--0x00000322+ CKM_CAST128_CBC as Cast128Cbc,--0x00000322+ CKM_CAST5_MAC as Cast5Mac,--0x00000323+ CKM_CAST128_MAC as Cast128Mac,--0x00000323+ CKM_CAST5_MAC_GENERAL as Cast5MacGeneral,--0x00000324+ CKM_CAST128_MAC_GENERAL as Cast128MacGeneral,--0x00000324+ CKM_CAST5_CBC_PAD as Cast5CbcPad,--0x00000325+ CKM_CAST128_CBC_PAD as Cast128CbcPad,--0x00000325+ CKM_RC5_KEY_GEN as Rc5KeyGen,--0x00000330+ CKM_RC5_ECB as Rc5Ecb,--0x00000331+ CKM_RC5_CBC as Rc5Cbc,--0x00000332+ CKM_RC5_MAC as Rc5Mac,--0x00000333+ CKM_RC5_MAC_GENERAL as Rc5MacGeneral,--0x00000334+ CKM_RC5_CBC_PAD as Rc5CbcPad,--0x00000335+ CKM_IDEA_KEY_GEN as IdeaKeyGen,--0x00000340+ CKM_IDEA_ECB as IdeaEcb,--0x00000341+ CKM_IDEA_CBC as IdeaCbc,--0x00000342+ CKM_IDEA_MAC as IdeaMac,--0x00000343+ CKM_IDEA_MAC_GENERAL as IdeaMacGeneral,--0x00000344+ CKM_IDEA_CBC_PAD as IdeaCbcPad,--0x00000345+ CKM_GENERIC_SECRET_KEY_GEN as GeneralSecretKeyGen,--0x00000350+ CKM_CONCATENATE_BASE_AND_KEY as ConcatenateBaseAndKey,--0x00000360+ CKM_CONCATENATE_BASE_AND_DATA as ConcatenateBaseAndData,--0x00000362+ CKM_CONCATENATE_DATA_AND_BASE as ConcatenateDataAndBase,--0x00000363+ CKM_XOR_BASE_AND_DATA as XorBaseAndData,--0x00000364+ CKM_EXTRACT_KEY_FROM_KEY as ExtractKeyFromKey,--0x00000365+ CKM_SSL3_PRE_MASTER_KEY_GEN as Ssl3PreMasterKeyGen,--0x00000370+ CKM_SSL3_MASTER_KEY_DERIVE as Ssl3MasterKeyDerive,--0x00000371+ CKM_SSL3_KEY_AND_MAC_DERIVE as Ssl3KeyAndMacDerive,--0x00000372++ -- CKM_SSL3_MASTER_KEY_DERIVE_DH, CKM_TLS_PRE_MASTER_KEY_GEN,+ -- CKM_TLS_MASTER_KEY_DERIVE, CKM_TLS_KEY_AND_MAC_DERIVE, and+ -- CKM_TLS_MASTER_KEY_DERIVE_DH are new for v2.11+ --CKM_SSL3_MASTER_KEY_DERIVE_DH 0x00000373+ --CKM_TLS_PRE_MASTER_KEY_GEN 0x00000374+ --CKM_TLS_MASTER_KEY_DERIVE 0x00000375+ --CKM_TLS_KEY_AND_MAC_DERIVE 0x00000376+ --CKM_TLS_MASTER_KEY_DERIVE_DH 0x00000377++ -- CKM_TLS_PRF is new for v2.20+ --CKM_TLS_PRF 0x00000378++ --CKM_SSL3_MD5_MAC 0x00000380+ --CKM_SSL3_SHA1_MAC 0x00000381+ --CKM_MD5_KEY_DERIVATION 0x00000390+ --CKM_MD2_KEY_DERIVATION 0x00000391+ --CKM_SHA1_KEY_DERIVATION 0x00000392++ -- CKM_SHA256/384/512 are new for v2.20+ --CKM_SHA256_KEY_DERIVATION 0x00000393+ --CKM_SHA384_KEY_DERIVATION 0x00000394+ --CKM_SHA512_KEY_DERIVATION 0x00000395++ -- SHA-224 key derivation is new for PKCS #11 v2.20 amendment 3+ CKM_SHA224_KEY_DERIVATION as Sha224KeyDerivation,--0x00000396++ CKM_PBE_MD2_DES_CBC as PbeMd2DesCbc,--0x000003A0+ CKM_PBE_MD5_DES_CBC as PbeMd5DesCbc,--0x000003A1+ CKM_PBE_MD5_CAST_CBC as PbeMd5CastCbc,--0x000003A2+ CKM_PBE_MD5_CAST3_CBC as PbeMd5Cast3Cbc,--0x000003A3+ CKM_PBE_MD5_CAST5_CBC as PbeMd5Cast5Cbc,--0x000003A4+ CKM_PBE_MD5_CAST128_CBC as PbeMd5Cast128Cbc,--0x000003A4+ CKM_PBE_SHA1_CAST5_CBC as PbeSha1Cast5Cbc,--0x000003A5+ CKM_PBE_SHA1_CAST128_CBC as PbeSha1Cast128Cbc,--0x000003A5+ CKM_PBE_SHA1_RC4_128 as PbeSha1Rc4128,--0x000003A6+ CKM_PBE_SHA1_RC4_40 as PbeSha1Rc440,--0x000003A7+ CKM_PBE_SHA1_DES3_EDE_CBC as PbeSha1Des3EdeCbc,--0x000003A8+ CKM_PBE_SHA1_DES2_EDE_CBC as PbeSha1Des2EdeCbc,--0x000003A9+ CKM_PBE_SHA1_RC2_128_CBC as PbeSha1Rc2128Cbc,--0x000003AA+ CKM_PBE_SHA1_RC2_40_CBC as PbeSha1Rc240Cbc,--0x000003AB++ -- CKM_PKCS5_PBKD2 is new for v2.10+ CKM_PKCS5_PBKD2 as Pkcs5Pbkd2,--0x000003B0++ CKM_PBA_SHA1_WITH_SHA1_HMAC as PbaSha1WithSha1Hmac,--0x000003C0++ -- WTLS mechanisms are new for v2.20+ --CKM_WTLS_PRE_MASTER_KEY_GEN 0x000003D0+ --CKM_WTLS_MASTER_KEY_DERIVE 0x000003D1+ --CKM_WTLS_MASTER_KEY_DERIVE_DH_ECC 0x000003D2+ --CKM_WTLS_PRF 0x000003D3+ --CKM_WTLS_SERVER_KEY_AND_MAC_DERIVE 0x000003D4+ --CKM_WTLS_CLIENT_KEY_AND_MAC_DERIVE 0x000003D5++ --CKM_KEY_WRAP_LYNKS 0x00000400+ --CKM_KEY_WRAP_SET_OAEP 0x00000401++ -- CKM_CMS_SIG is new for v2.20+ --CKM_CMS_SIG 0x00000500++ -- CKM_KIP mechanisms are new for PKCS #11 v2.20 amendment 2+ --CKM_KIP_DERIVE 0x00000510+ --CKM_KIP_WRAP 0x00000511+ --CKM_KIP_MAC 0x00000512++ -- Camellia is new for PKCS #11 v2.20 amendment 3+ --CKM_CAMELLIA_KEY_GEN 0x00000550+ --CKM_CAMELLIA_ECB 0x00000551+ --CKM_CAMELLIA_CBC 0x00000552+ --CKM_CAMELLIA_MAC 0x00000553+ --CKM_CAMELLIA_MAC_GENERAL 0x00000554+ --CKM_CAMELLIA_CBC_PAD 0x00000555+ --CKM_CAMELLIA_ECB_ENCRYPT_DATA 0x00000556+ --CKM_CAMELLIA_CBC_ENCRYPT_DATA 0x00000557+ --CKM_CAMELLIA_CTR 0x00000558++ -- ARIA is new for PKCS #11 v2.20 amendment 3+ --CKM_ARIA_KEY_GEN 0x00000560+ --CKM_ARIA_ECB 0x00000561+ --CKM_ARIA_CBC 0x00000562+ --CKM_ARIA_MAC 0x00000563+ --CKM_ARIA_MAC_GENERAL 0x00000564+ --CKM_ARIA_CBC_PAD 0x00000565+ --CKM_ARIA_ECB_ENCRYPT_DATA 0x00000566+ --CKM_ARIA_CBC_ENCRYPT_DATA 0x00000567++ -- Fortezza mechanisms+ --CKM_SKIPJACK_KEY_GEN 0x00001000+ --CKM_SKIPJACK_ECB64 0x00001001+ --CKM_SKIPJACK_CBC64 0x00001002+ --CKM_SKIPJACK_OFB64 0x00001003+ --CKM_SKIPJACK_CFB64 0x00001004+ --CKM_SKIPJACK_CFB32 0x00001005+ --CKM_SKIPJACK_CFB16 0x00001006+ --CKM_SKIPJACK_CFB8 0x00001007+ --CKM_SKIPJACK_WRAP 0x00001008+ --CKM_SKIPJACK_PRIVATE_WRAP 0x00001009+ --CKM_SKIPJACK_RELAYX 0x0000100a+ --CKM_KEA_KEY_PAIR_GEN 0x00001010+ --CKM_KEA_KEY_DERIVE 0x00001011+ --CKM_FORTEZZA_TIMESTAMP 0x00001020+ --CKM_BATON_KEY_GEN 0x00001030+ --CKM_BATON_ECB128 0x00001031+ --CKM_BATON_ECB96 0x00001032+ --CKM_BATON_CBC128 0x00001033+ --CKM_BATON_COUNTER 0x00001034+ --CKM_BATON_SHUFFLE 0x00001035+ --CKM_BATON_WRAP 0x00001036++ -- CKM_ECDSA_KEY_PAIR_GEN is deprecated in v2.11,+ -- CKM_EC_KEY_PAIR_GEN is preferred+ CKM_ECDSA_KEY_PAIR_GEN as EcdsaKeyPairGen,--0x00001040+ CKM_EC_KEY_PAIR_GEN as EcKeyPairGen,--0x00001040++ CKM_ECDSA as Ecdsa,--0x00001041+ CKM_ECDSA_SHA1 as EcdsaSha1,--0x00001042++ -- CKM_ECDH1_DERIVE, CKM_ECDH1_COFACTOR_DERIVE, and CKM_ECMQV_DERIVE+ -- are new for v2.11+ CKM_ECDH1_DERIVE as Ecdh1Derive,--0x00001050+ CKM_ECDH1_COFACTOR_DERIVE as Ecdh1CofactorDerive,--0x00001051+ CKM_ECMQV_DERIVE as DcmqvDerive,--0x00001052++ CKM_JUNIPER_KEY_GEN as JuniperKeyGen,--0x00001060+ CKM_JUNIPER_ECB128 as JuniperEcb128,--0x00001061+ CKM_JUNIPER_CBC128 as JuniperCbc128,--0x00001062+ CKM_JUNIPER_COUNTER as JuniperCounter,--0x00001063+ CKM_JUNIPER_SHUFFLE as JuniperShuffle,--0x00001064+ CKM_JUNIPER_WRAP as JuniperWrap,--0x00001065+ CKM_FASTHASH as FastHash,--0x00001070++ -- CKM_AES_KEY_GEN, CKM_AES_ECB, CKM_AES_CBC, CKM_AES_MAC,+ -- CKM_AES_MAC_GENERAL, CKM_AES_CBC_PAD, CKM_DSA_PARAMETER_GEN,+ -- CKM_DH_PKCS_PARAMETER_GEN, and CKM_X9_42_DH_PARAMETER_GEN are+ -- new for v2.11+ CKM_AES_KEY_GEN as AesKeyGen,--0x00001080+ CKM_AES_ECB as AesEcb,+ CKM_AES_CBC as AesCbc,+ CKM_AES_MAC as AesMac,+ CKM_AES_MAC_GENERAL as AesMacGeneral,+ CKM_AES_CBC_PAD as AesCbcPad,++ -- AES counter mode is new for PKCS #11 v2.20 amendment 3+ CKM_AES_CTR as AesCtr,++ CKM_AES_GCM as AesGcm,--0x00001087+ CKM_AES_CCM as AesCcm,--0x00001088+ CKM_AES_KEY_WRAP as AesKeyWrap,--0x00001090+ CKM_AES_KEY_WRAP_PAD as AesKeyWrapPad,--0x00001091++ -- BlowFish and TwoFish are new for v2.20+ CKM_BLOWFISH_KEY_GEN as BlowfishKeyGen,+ CKM_BLOWFISH_CBC as BlowfishCbc,+ CKM_TWOFISH_KEY_GEN as TwoFishKeyGen,+ CKM_TWOFISH_CBC as TwoFishCbc,++ -- CKM_xxx_ENCRYPT_DATA mechanisms are new for v2.20+ CKM_DES_ECB_ENCRYPT_DATA as DesEcbEncryptData,+ CKM_DES_CBC_ENCRYPT_DATA as DesCbcEncryptData,+ CKM_DES3_ECB_ENCRYPT_DATA as Des3EcbEncryptData,+ CKM_DES3_CBC_ENCRYPT_DATA as Des3CbcEncryptData,+ CKM_AES_ECB_ENCRYPT_DATA as AesEcbEncryptData,+ CKM_AES_CBC_ENCRYPT_DATA as AesCbcEncryptData,++ CKM_DSA_PARAMETER_GEN as DsaParameterGen,+ CKM_DH_PKCS_PARAMETER_GEN as DhPkcsParameterGen,+ CKM_X9_42_DH_PARAMETER_GEN as X9_42DhParameterGen,++ CKM_VENDOR_DEFINED as VendorDefined+ } deriving (Eq,Show) #}+++{#fun unsafe CK_FUNCTION_LIST.C_DecryptInit as decryptInit'+ {`FunctionListPtr',+ `SessionHandle',+ with* `Mech',+ `ObjectHandle'} -> `Rv'+#}++{#fun unsafe CK_FUNCTION_LIST.C_Decrypt as decrypt'+ {`FunctionListPtr',+ `SessionHandle',+ castPtr `Ptr CUChar',+ `CULong',+ castPtr `Ptr CUChar',+ with* `CULong' peek*} -> `Rv'+#}+++{#fun unsafe CK_FUNCTION_LIST.C_EncryptInit as encryptInit'+ {`FunctionListPtr',+ `SessionHandle',+ with* `Mech',+ `ObjectHandle'} -> `Rv'+#}++{#fun unsafe CK_FUNCTION_LIST.C_Encrypt as encrypt'+ {`FunctionListPtr',+ `SessionHandle',+ castPtr `Ptr CUChar',+ `CULong',+ castPtr `Ptr CUChar',+ with* `CULong' peek*} -> `Rv'+#}++{#fun unsafe CK_FUNCTION_LIST.C_EncryptUpdate as encryptUpdate'+ {`FunctionListPtr',+ `SessionHandle',+ castPtr `Ptr CUChar',+ `CULong',+ castPtr `Ptr CUChar',+ with* `CULong' peek*} -> `Rv'+#}++{#fun unsafe CK_FUNCTION_LIST.C_EncryptFinal as encryptFinal'+ {`FunctionListPtr',+ `SessionHandle',+ castPtr `Ptr CUChar',+ with* `CULong' peek*} -> `Rv'+#}+++{#fun unsafe CK_FUNCTION_LIST.C_DigestInit as digestInit'+ {`FunctionListPtr',+ `SessionHandle',+ with* `Mech'} -> `Rv'+#}++{#fun unsafe CK_FUNCTION_LIST.C_Digest as digest'+ {`FunctionListPtr',+ `SessionHandle',+ castPtr `Ptr CUChar',+ `CULong',+ castPtr `Ptr CUChar',+ with* `CULong' peek*} -> `Rv'+#}++{#fun unsafe CK_FUNCTION_LIST.C_SignInit as signInit'+ {`FunctionListPtr',+ `SessionHandle',+ with* `Mech',+ `ObjectHandle'} -> `Rv'+#}++{#fun unsafe CK_FUNCTION_LIST.C_Sign as sign'+ {`FunctionListPtr',+ `SessionHandle',+ castPtr `Ptr CUChar',+ `CULong',+ castPtr `Ptr CUChar',+ with* `CULong' peek*} -> `Rv'+#}+++{#fun unsafe CK_FUNCTION_LIST.C_SignRecoverInit as signRecoverInit'+ {`FunctionListPtr',+ `SessionHandle',+ with* `Mech',+ `ObjectHandle'} -> `Rv'+#}+++{#fun unsafe CK_FUNCTION_LIST.C_SignRecover as signRecover'+ {`FunctionListPtr',+ `SessionHandle',+ castPtr `Ptr CUChar',+ `CULong',+ castPtr `Ptr CUChar',+ with* `CULong' peek*} -> `Rv'+#}+++{#fun unsafe CK_FUNCTION_LIST.C_VerifyInit as verifyInit'+ {`FunctionListPtr',+ `SessionHandle',+ with* `Mech',+ `ObjectHandle'} -> `Rv'+#}++{#fun unsafe CK_FUNCTION_LIST.C_Verify as verify'+ {`FunctionListPtr',+ `SessionHandle',+ castPtr `Ptr CUChar',+ `CULong',+ castPtr `Ptr CUChar',+ `CULong'} -> `Rv'+#}++{#fun unsafe CK_FUNCTION_LIST.C_UnwrapKey as unwrapKey'+ {`FunctionListPtr',+ `SessionHandle',+ with* `Mech',+ `ObjectHandle',+ castPtr `Ptr CUChar',+ `CULong',+ `LlAttributePtr',+ `CULong',+ alloca- `ObjectHandle' peek*} -> `Rv'+#}++{#fun unsafe CK_FUNCTION_LIST.C_WrapKey as wrapKey'+ {`FunctionListPtr',+ `SessionHandle',+ with* `Mech',+ `ObjectHandle',+ `ObjectHandle',+ castPtr `Ptr CUChar',+ with* `CULong' peek*} -> `Rv'+#}+++{#fun unsafe CK_FUNCTION_LIST.C_SeedRandom as seedRandom'+ {`FunctionListPtr',+ `SessionHandle',+ castPtr `Ptr CUChar',+ `CULong'} -> `Rv'+#}+++{#fun unsafe CK_FUNCTION_LIST.C_GenerateRandom as generateRandom'+ {`FunctionListPtr',+ `SessionHandle',+ castPtr `Ptr CUChar',+ `CULong'} -> `Rv'+#}
− src/System/Crypto/Pkcs11.chs
@@ -1,2097 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface #-}-module System.Crypto.Pkcs11 (- -- * Library- Library,- loadLibrary,- releaseLibrary,-- -- ** Reading library information- getInfo,- LibraryInfo,- infoCryptokiVersion,- infoManufacturerId,- infoFlags,- infoLibraryDescription,- infoLibraryVersion,- Version,- versionMajor,- versionMinor,-- -- * Slots- SlotId,- getSlotNum,- getSlotList,-- -- ** Reading slot information- getSlotInfo,- SlotInfo,- slotInfoDescription,- slotInfoManufacturerId,- slotInfoFlags,- slotInfoHardwareVersion,- slotInfoFirmwareVersion,-- -- ** Working with tokens- TokenInfo,- getTokenInfo,- tokenInfoLabel,- tokenInfoManufacturerId,- tokenInfoModel,- tokenInfoSerialNumber,- tokenInfoFlags,- initToken,- initPin,- setPin,-- -- * Mechanisms- getMechanismList,- getMechanismInfo,- MechType(RsaPkcsKeyPairGen,RsaPkcs,Rsa9796,AesEcb,AesCbc,AesMac,AesMacGeneral,AesCbcPad,AesCtr,AesKeyGen,Sha256,- DhPkcsKeyPairGen,DhPkcsParameterGen,DhPkcsDerive),- MechInfo,- mechInfoMinKeySize,- mechInfoMaxKeySize,- mechInfoFlags,- Mech,- simpleMech,-- -- * Session management- Session,- withSession,- login,- UserType(User,SecurityOfficer,ContextSpecific),- logout,- closeAllSessions,- getSessionInfo,- SessionInfo,- sessionInfoSlotId,- sessionInfoState,- sessionInfoFlags,- sessionInfoDeviceError,- SessionState(ROPublicSession,ROUserFunctions,RWPublicSession,RWUserFunctions,RWSOFunctions),- getOperationState,-- -- * Object attributes- ObjectHandle,- Attribute(Class,Label,KeyType,Modulus,ModulusBits,PrimeBits,PublicExponent,Prime,Base,Token,Decrypt,ValueLen,- Extractable,Value),- ClassType(Data,Certificate,PublicKey,PrivateKey,SecretKey,HWFeature,DomainParameters,Mechanism),- KeyTypeValue(RSA,DSA,DH,ECDSA,EC,AES),- destroyObject,- createObject,- copyObject,- getObjectSize,- -- ** Searching objects- findObjects,- -- ** Reading object attributes- getTokenFlag,- getPrivateFlag,- getSensitiveFlag,- getEncryptFlag,- getDecryptFlag,- getWrapFlag,- getUnwrapFlag,- getSignFlag,- getModulus,- getPublicExponent,- getPrime,- getBase,- -- ** Writing attributes- setAttributes,-- -- * Key generation- generateKey,- generateKeyPair,- deriveKey,-- -- * Key wrapping/unwrapping- wrapKey,- unwrapKey,-- -- * Encryption/decryption- decrypt,- encrypt,- -- ** Multipart operations- decryptInit,- encryptInit,- encryptUpdate,- encryptFinal,-- -- * Digest- digest,- digestInit,-- -- * Signing- sign,- verify,- signRecover,- signInit,- verifyInit,- signRecoverInit,-- -- * Random- seedRandom,- generateRandom,-) where-import Foreign-import Foreign.Marshal.Utils-import Foreign.Marshal.Alloc-import Foreign.C-import Foreign.Ptr-import System.Posix.DynamicLinker-import Control.Monad-import Control.Exception-import qualified Data.ByteString.UTF8 as BU8-import qualified Data.ByteString as BS-import Data.ByteString.Unsafe-import Data.List--#include "pkcs11import.h"--{-- Currently cannot use c2hs structure alignment and offset detector since it does not support pragma pack- which is required by PKCS11, which is using 1 byte packing- https://github.com/haskell/c2hs/issues/172--}--_serialSession = {#const CKF_SERIAL_SESSION#} :: Int-_rwSession = {#const CKF_RW_SESSION#} :: Int--rsaPkcsKeyPairGen = {#const CKM_RSA_PKCS_KEY_PAIR_GEN#} :: Int---- | Used to reference an object-type ObjectHandle = {#type CK_OBJECT_HANDLE#}-{#typedef CK_OBJECT_HANDLE ObjectHandle#}-{#default in `ObjectHandle' [CK_OBJECT_HANDLE] fromIntegral#}-{#default out `ObjectHandle' [CK_OBJECT_HANDLE] fromIntegral#}--type SlotId = {#type CK_SLOT_ID#}-{#typedef CK_SLOT_ID SlotId#}-{#default in `SlotId' [CK_SLOT_ID] fromIntegral#}-{#default out `SlotId' [CK_SLOT_ID] fromIntegral#}-type Rv = {#type CK_RV#}-{#typedef CK_RV Rv#}-{#default out `Rv' [CK_RV] fromIntegral#}-type CK_BBOOL = {#type CK_BBOOL#}-type CK_BYTE = {#type CK_BYTE#}-type CK_FLAGS = {#type CK_FLAGS#}-type GetFunctionListFunPtr = {#type CK_C_GetFunctionList#}-type NotifyFunPtr = {#type CK_NOTIFY#}-type SessionHandle = {#type CK_SESSION_HANDLE#}-{#typedef CK_SESSION_HANDLE SessionHandle#}-{#default in `SessionHandle' [CK_SESSION_HANDLE] fromIntegral#}-{#default out `SessionHandle' [CK_SESSION_HANDLE] fromIntegral#}--{#pointer *CK_FUNCTION_LIST as FunctionListPtr#}-{#pointer *CK_INFO as LibraryInfoPtr -> LibraryInfo#}-{#pointer *CK_SLOT_INFO as SlotInfoPtr -> SlotInfo#}-{#pointer *CK_TOKEN_INFO as TokenInfoPtr -> TokenInfo#}-{#pointer *CK_SESSION_INFO as SessionInfoPtr -> SessionInfo#}-{#pointer *CK_ATTRIBUTE as LlAttributePtr -> LlAttribute#}-{#pointer *CK_MECHANISM_INFO as MechInfoPtr -> MechInfo#}-{#pointer *CK_MECHANISM as MechPtr -> Mech#}---- defined this one manually because I don't know how to make c2hs to define it yet-type GetFunctionListFun = (C2HSImp.Ptr (FunctionListPtr)) -> (IO C2HSImp.CULong)--foreign import ccall unsafe "dynamic"- getFunctionList'_ :: GetFunctionListFunPtr -> GetFunctionListFun--data Version = Version {- versionMajor :: Int,- versionMinor :: Int-} deriving (Show)--instance Storable Version where- sizeOf _ = {#sizeof CK_VERSION#}- alignment _ = {#alignof CK_VERSION#}- peek p = Version- <$> liftM fromIntegral ({#get CK_VERSION->major#} p)- <*> liftM fromIntegral ({#get CK_VERSION->minor#} p)- poke p x = do- {#set CK_VERSION->major#} p (fromIntegral $ versionMajor x)- {#set CK_VERSION->minor#} p (fromIntegral $ versionMinor x)---- | Represents general library information. Returned by 'getInfo' function.-data LibraryInfo = LibraryInfo {- -- | Cryptoki interface version number, for compatibility with future revisions of this interface- infoCryptokiVersion :: Version,- -- | ID of the Cryptoki library manufacturer- infoManufacturerId :: String,- -- | bit flags reserved for future versions. Must be zero for this version- infoFlags :: Int,- infoLibraryDescription :: String,- -- | Cryptoki library version number- infoLibraryVersion :: Version-} deriving (Show)--instance Storable LibraryInfo where- sizeOf _ = (2+32+4+32+10+2)- alignment _ = 1- peek p = do- ver <- peek (p `plusPtr` {#offsetof CK_INFO->cryptokiVersion#}) :: IO Version- manufacturerId <- peekCStringLen ((p `plusPtr` 2), 32)- flags <- (\ptr -> do {C2HSImp.peekByteOff ptr (2+32) :: IO C2HSImp.CULong}) p- --flags <- {#get CK_INFO->flags#} p- libraryDescription <- peekCStringLen ((p `plusPtr` (2+32+4+10)), 32)- --libraryDescription <- {# get CK_INFO->libraryDescription #} p- libVer <- peek (p `plusPtr` (2+32+4+32+10)) :: IO Version- return LibraryInfo {infoCryptokiVersion=ver,- infoManufacturerId=manufacturerId,- infoFlags=fromIntegral flags,- infoLibraryDescription=libraryDescription,- infoLibraryVersion=libVer- }- poke p v = do- error "not implemented"---data SlotInfo = SlotInfo {- slotInfoDescription :: String,- slotInfoManufacturerId :: String,- -- | bit flags indicating capabilities and status of the slot as defined in https://www.cryptsoft.com/pkcs11doc/v220/pkcs11__all_8h.html#aCK_SLOT_INFO- slotInfoFlags :: Int,- slotInfoHardwareVersion :: Version,- slotInfoFirmwareVersion :: Version-} deriving (Show)--instance Storable SlotInfo where- sizeOf _ = (64+32+4+2+2)- alignment _ = 1- peek p = do- description <- peekCStringLen ((p `plusPtr` 0), 64)- manufacturerId <- peekCStringLen ((p `plusPtr` 64), 32)- flags <- C2HSImp.peekByteOff p (64+32) :: IO C2HSImp.CULong- hwVer <- peek (p `plusPtr` (64+32+4)) :: IO Version- fwVer <- peek (p `plusPtr` (64+32+4+2)) :: IO Version- return SlotInfo {slotInfoDescription=description,- slotInfoManufacturerId=manufacturerId,- slotInfoFlags=fromIntegral flags,- slotInfoHardwareVersion=hwVer,- slotInfoFirmwareVersion=fwVer- }- poke p v = do- error "not implemented"---data TokenInfo = TokenInfo {- tokenInfoLabel :: String,- tokenInfoManufacturerId :: String,- tokenInfoModel :: String,- tokenInfoSerialNumber :: String,- -- | bit flags indicating capabilities and status of the device as defined in https://www.cryptsoft.com/pkcs11doc/v220/pkcs11__all_8h.html#aCK_TOKEN_INFO- tokenInfoFlags :: Int--,- --tokenInfoHardwareVersion :: Version,- --tokenInfoFirmwareVersion :: Version-} deriving (Show)--instance Storable TokenInfo where- sizeOf _ = (64+32+4+2+2)- alignment _ = 1- peek p = do- label <- peekCStringLen ((p `plusPtr` 0), 32)- manufacturerId <- peekCStringLen ((p `plusPtr` 32), 32)- model <- peekCStringLen ((p `plusPtr` (32+32)), 16)- serialNumber <- peekCStringLen ((p `plusPtr` (32+32+16)), 16)- flags <- C2HSImp.peekByteOff p (32+32+16+16) :: IO C2HSImp.CULong- --hwVer <- peek (p `plusPtr` (64+32+4)) :: IO Version- --fwVer <- peek (p `plusPtr` (64+32+4+2)) :: IO Version- return TokenInfo {tokenInfoLabel=label,- tokenInfoManufacturerId=manufacturerId,- tokenInfoModel=model,- tokenInfoSerialNumber=serialNumber,- tokenInfoFlags=fromIntegral flags--,- --tokenInfoHardwareVersion=hwVer,- --tokenInfoFirmwareVersion=fwVer- }-- poke p v = do- error "not implemented"----- | Represent information about a mechanism. Returned by 'getMechanismInfo' function.-data MechInfo = MechInfo {- -- | Minimum size of a key in bits or bytes depending on the mechanism.- mechInfoMinKeySize :: Int,- -- | Maximum size of a key in bits or bytes depending on the mechanism.- mechInfoMaxKeySize :: Int,- -- | Mechanism's flags as described in https://www.cryptsoft.com/pkcs11doc/v220/pkcs11__all_8h.html#aCK_MECHANISM_INFO- mechInfoFlags :: Int-} deriving (Show)--instance Storable MechInfo where- sizeOf _ = {#sizeof CK_MECHANISM_INFO#}- alignment _ = 1- peek p = MechInfo- <$> liftM fromIntegral ({#get CK_MECHANISM_INFO->ulMinKeySize#} p)- <*> liftM fromIntegral ({#get CK_MECHANISM_INFO->ulMaxKeySize#} p)- <*> liftM fromIntegral ({#get CK_MECHANISM_INFO->flags#} p)- poke p x = do- {#set CK_MECHANISM_INFO->ulMinKeySize#} p (fromIntegral $ mechInfoMinKeySize x)- {#set CK_MECHANISM_INFO->ulMaxKeySize#} p (fromIntegral $ mechInfoMaxKeySize x)- {#set CK_MECHANISM_INFO->flags#} p (fromIntegral $ mechInfoFlags x)----- | Represents mechanism with parameters to be used in cryptographic operation. Parameterless mechanism can be--- created with 'simpleMech' function. Few example operations using this data structure are 'encrypt', 'generateKey'.-data Mech = Mech {- mechType :: MechType,- mechParamPtr :: Ptr (),- mechParamSize :: Int-}---- | Return parameterless mechanism which can be used in cryptographic operation.-simpleMech :: MechType -> Mech-simpleMech mechType = Mech mechType nullPtr 0--instance Storable Mech where- sizeOf _ = {#sizeof CK_MECHANISM_TYPE#} + {#sizeof CK_VOID_PTR#} + {#sizeof CK_ULONG#}- alignment _ = 1- peek p = do- error "not implemented"- poke p x = do- poke (p `plusPtr` 0) (fromEnum $ mechType x)- poke (p `plusPtr` {#sizeof CK_MECHANISM_TYPE#}) (mechParamPtr x :: {#type CK_VOID_PTR#})- poke (p `plusPtr` ({#sizeof CK_MECHANISM_TYPE#} + {#sizeof CK_VOID_PTR#})) (mechParamSize x)----- | Represent session information. Returned by 'getSessionInfo' function.-data SessionInfo = SessionInfo {- -- | Slot for which session is open- sessionInfoSlotId :: SlotId,- -- | State of the session, e.g. 'ROPublicSession', 'RWUserFunctions'.- sessionInfoState :: SessionState,- -- | Session flags as described in https://www.cryptsoft.com/pkcs11doc/v220/pkcs11__all_8h.html#aCK_SESSION_INFO.- sessionInfoFlags :: CULong,- -- | Device specific error code.- sessionInfoDeviceError :: CULong-} deriving (Show)---instance Storable SessionInfo where- sizeOf _ = {#sizeof CK_SESSION_INFO#}- alignment _ = 1- peek p = SessionInfo- <$> liftM fromIntegral ({#get CK_SESSION_INFO->slotID#} p)- <*> liftM culong2sessState ({#get CK_SESSION_INFO->state#} p)- <*> {#get CK_SESSION_INFO->flags#} p- <*> {#get CK_SESSION_INFO->ulDeviceError#} p- where culong2sessState val = toEnum $ fromIntegral val- poke p x = do- error "not implemented"---{#fun unsafe CK_FUNCTION_LIST.C_Initialize as initialize- {`FunctionListPtr',- alloca- `()' } -> `Rv' fromIntegral#}--{#fun unsafe CK_FUNCTION_LIST.C_GetInfo as getInfo'- {`FunctionListPtr',- alloca- `LibraryInfo' peek* } -> `Rv' fromIntegral#}--{#fun unsafe CK_FUNCTION_LIST.C_GetSlotList as getSlotList'- {`FunctionListPtr',- `Bool',- castPtr `Ptr SlotId',- `CULong' peek*} -> `Rv'-#}---- | Return number of slots in the system.-getSlotNum :: Library -- ^ Library to be used for operation.- -> Bool -- ^ If True will return only slots with tokens in them.- -> IO (CULong) -- ^ Number of slots.-getSlotNum (Library _ functionListPtr) active = do- (rv, outNum) <- getSlotList' functionListPtr active nullPtr 0- if rv /= 0- then fail $ "failed to get number of slots " ++ (rvToStr rv)- else return outNum---- | Get a list of slot IDs in the system. Can filter for slots with attached tokens.------ > slotsIds <- getSlotList lib True 10------ In this example retrieves list of, at most 10 (third parameter) slot identifiers with tokens present (second parameter is set to True)-getSlotList :: Library -- ^ Library to be used for operation.- -> Bool -- ^ If True will return only slots with tokens in them.- -> Int -- ^ Maximum number of slot IDs to be returned.- -> IO [SlotId]-getSlotList (Library _ functionListPtr) active num = do- allocaArray num $ \array -> do- (rv, outNum) <- getSlotList' functionListPtr active array (fromIntegral num)- if rv /= 0- then fail $ "failed to get list of slots " ++ (rvToStr rv)- else peekArray (fromIntegral outNum) array---initToken' :: FunctionListPtr -> SlotId -> BU8.ByteString -> String -> IO (Rv)-initToken' funcListPtr slotId pin label = do- unsafeUseAsCStringLen pin $ \(pinPtr, pinLen) -> do- allocaArray 32 $ \labelArray -> do- pokeArray labelArray (map CUChar (BS.unpack $ BU8.fromString label))- res <- {#call unsafe CK_FUNCTION_LIST.C_InitToken#} funcListPtr (fromIntegral slotId) (castPtr pinPtr) (fromIntegral pinLen) labelArray- return (fromIntegral res)---initPin' :: FunctionListPtr -> CULong -> BU8.ByteString -> IO (Rv)-initPin' funcListPtr sessHandle pin = do- unsafeUseAsCStringLen pin $ \(pinPtr, pinLen) -> do- res <- {#call unsafe CK_FUNCTION_LIST.C_InitPIN#} funcListPtr sessHandle (castPtr pinPtr) (fromIntegral pinLen)- return (fromIntegral res)---setPin' :: FunctionListPtr -> CULong -> BU8.ByteString -> BU8.ByteString -> IO (Rv)-setPin' funcListPtr sessHandle oldPin newPin = do- unsafeUseAsCStringLen oldPin $ \(oldPinPtr, oldPinLen) -> do- unsafeUseAsCStringLen newPin $ \(newPinPtr, newPinLen) -> do- res <- {#call unsafe CK_FUNCTION_LIST.C_SetPIN#} funcListPtr sessHandle (castPtr oldPinPtr)- (fromIntegral oldPinLen) (castPtr newPinPtr) (fromIntegral newPinLen)- return (fromIntegral res)---{#fun unsafe CK_FUNCTION_LIST.C_GetSessionInfo as getSessionInfo'- {`FunctionListPtr',- `SessionHandle',- alloca- `SessionInfo' peek* } -> `Rv' fromIntegral-#}---getSessionInfo (Session sessHandle funListPtr) = do- (rv, sessInfo) <- getSessionInfo' funListPtr sessHandle- if rv /= 0- then fail $ "failed to get session info: " ++ (rvToStr rv)- else return sessInfo---{#fun unsafe CK_FUNCTION_LIST.C_GetSlotInfo as getSlotInfo'- {`FunctionListPtr',- `SlotId',- alloca- `SlotInfo' peek* } -> `Rv' fromIntegral-#}---{#fun unsafe CK_FUNCTION_LIST.C_GetTokenInfo as getTokenInfo'- {`FunctionListPtr',- `SlotId',- alloca- `TokenInfo' peek* } -> `Rv' fromIntegral-#}---openSession' functionListPtr slotId flags =- alloca $ \slotIdPtr -> do- res <- {#call unsafe CK_FUNCTION_LIST.C_OpenSession#} functionListPtr (fromIntegral slotId) (fromIntegral flags) nullPtr nullFunPtr slotIdPtr- slotId <- peek slotIdPtr- return (fromIntegral res, fromIntegral slotId)---{#fun unsafe CK_FUNCTION_LIST.C_CloseSession as closeSession'- {`FunctionListPtr',- `SessionHandle' } -> `Rv' fromIntegral#}---{#fun unsafe CK_FUNCTION_LIST.C_CloseAllSessions as closeAllSessions'- {`FunctionListPtr',- `SlotId' } -> `Rv' fromIntegral#}--closeAllSessions (Library _ funcListPtr) slotId = do- rv <- closeAllSessions' funcListPtr slotId- if rv /= 0- then fail $ "failed to close sessions: " ++ (rvToStr rv)- else return ()---{#fun unsafe CK_FUNCTION_LIST.C_Finalize as finalize- {`FunctionListPtr',- alloca- `()' } -> `Rv' fromIntegral#}---getFunctionList :: GetFunctionListFunPtr -> IO ((Rv), (FunctionListPtr))-getFunctionList getFunctionListPtr =- alloca $ \funcListPtrPtr -> do- res <- (getFunctionList'_ getFunctionListPtr) funcListPtrPtr- funcListPtr <- peek funcListPtrPtr- return (fromIntegral res, funcListPtr)---findObjectsInit' functionListPtr session attribs = do- _withAttribs attribs $ \attribsPtr -> do- res <- {#call unsafe CK_FUNCTION_LIST.C_FindObjectsInit#} functionListPtr session attribsPtr (fromIntegral $ length attribs)- return (fromIntegral res)---findObjects' functionListPtr session maxObjects = do- alloca $ \arrayLenPtr -> do- poke arrayLenPtr (fromIntegral 0)- allocaArray maxObjects $ \array -> do- res <- {#call unsafe CK_FUNCTION_LIST.C_FindObjects#} functionListPtr session array (fromIntegral maxObjects) arrayLenPtr- arrayLen <- peek arrayLenPtr- objectHandles <- peekArray (fromIntegral arrayLen) array- return (fromIntegral res, objectHandles)---{#fun unsafe CK_FUNCTION_LIST.C_FindObjectsFinal as findObjectsFinal'- {`FunctionListPtr',- `CULong' } -> `Rv' fromIntegral#}---{#enum define UserType {CKU_USER as User, CKU_SO as SecurityOfficer, CKU_CONTEXT_SPECIFIC as ContextSpecific} deriving (Eq) #}--{#enum define SessionState {- CKS_RO_PUBLIC_SESSION as ROPublicSession,- CKS_RO_USER_FUNCTIONS as ROUserFunctions,- CKS_RW_PUBLIC_SESSION as RWPublicSession,- CKS_RW_USER_FUNCTIONS as RWUserFunctions,- CKS_RW_SO_FUNCTIONS as RWSOFunctions- } deriving (Eq,Show)-#}---{#fun unsafe CK_FUNCTION_LIST.C_GetOperationState as getOperationState'- {`FunctionListPtr',- `SessionHandle',- castPtr `Ptr CUChar',- `CULong' peek*} -> `Rv'#}--getOperationState (Session sessHandle funcListPtr) maxSize = do- allocaBytes (fromIntegral maxSize) $ \bytesPtr -> do- (rv, resSize) <- getOperationState' funcListPtr sessHandle bytesPtr maxSize- if rv /= 0- then fail $ "failed to get operation state: " ++ (rvToStr rv)- else BS.packCStringLen (castPtr bytesPtr, fromIntegral resSize)---_login :: FunctionListPtr -> SessionHandle -> UserType -> BU8.ByteString -> IO (Rv)-_login functionListPtr session userType pin = do- unsafeUseAsCStringLen pin $ \(pinPtr, pinLen) -> do- res <- {#call unsafe CK_FUNCTION_LIST.C_Login#} functionListPtr session (fromIntegral $ fromEnum userType) (castPtr pinPtr) (fromIntegral pinLen)- return (fromIntegral res)---{#fun unsafe CK_FUNCTION_LIST.C_DestroyObject as destroyObject'- {`FunctionListPtr',- `SessionHandle',- `ObjectHandle'} -> `Rv'#}---- | Deletes an object from token or session.-destroyObject (Session sessHandle funcListPtr) objectHandle = do- rv <- destroyObject' funcListPtr sessHandle objectHandle- if rv /= 0- then fail $ "failed to destroy object: " ++ (rvToStr rv)- else return ()---generateKey' :: FunctionListPtr -> SessionHandle -> Mech -> [Attribute] -> IO (Rv, ObjectHandle)-generateKey' funcListPtr sessHandle mech attribs = do- alloca $ \keyHandlePtr -> do- with mech $ \mechPtr -> do- _withAttribs attribs $ \attribsPtr -> do- res <- {#call unsafe CK_FUNCTION_LIST.C_GenerateKey#} funcListPtr sessHandle mechPtr attribsPtr (fromIntegral $ length attribs) keyHandlePtr- keyHandle <- peek keyHandlePtr- return (fromIntegral res, fromIntegral keyHandle)---- {#fun unsafe CK_FUNCTION_LIST.C_GenerateKey as generateKey'--- {`FunctionListPtr',--- `SessionHandle',--- `MechType',--- _withAttribs* `[Attribute]'&,--- alloca- `ObjectHandle'} -> `Rv' fromIntegral#}----- | Generates a symmetric key using provided mechanism and applies provided attributes to resulting key object.------ Examples:------ Generate 128-bit AES key:------ > keyHandle <- generateKey sess (simpleMech AesKeyGen) [ValueLen 16]------ Generate 1024-bit Diffie-Hellman domain parameters using PKCS#3 mechanism:------ > dhParamsHandle <- generateKey sess (simpleMech DhPkcsParameterGen) [PrimeBits 1028]-generateKey :: Session -> Mech -> [Attribute] -> IO ObjectHandle-generateKey (Session sessHandle funcListPtr) mech attribs = do- (rv, keyHandle) <- generateKey' funcListPtr sessHandle mech attribs- if rv /= 0- then fail $ "failed to generate key: " ++ (rvToStr rv)- else return keyHandle---_generateKeyPair :: FunctionListPtr- -> SessionHandle- -> Mech- -> [Attribute]- -> [Attribute]- -> IO (Rv, ObjectHandle, ObjectHandle)-_generateKeyPair functionListPtr session mech pubAttrs privAttrs = do- alloca $ \pubKeyHandlePtr -> do- alloca $ \privKeyHandlePtr -> do- with mech $ \mechPtr -> do- _withAttribs pubAttrs $ \pubAttrsPtr -> do- _withAttribs privAttrs $ \privAttrsPtr -> do- res <- {#call unsafe CK_FUNCTION_LIST.C_GenerateKeyPair#} functionListPtr session mechPtr pubAttrsPtr (fromIntegral $ length pubAttrs) privAttrsPtr (fromIntegral $ length privAttrs) pubKeyHandlePtr privKeyHandlePtr- pubKeyHandle <- peek pubKeyHandlePtr- privKeyHandle <- peek privKeyHandlePtr- return (fromIntegral res, fromIntegral pubKeyHandle, fromIntegral privKeyHandle)----_getMechanismList :: FunctionListPtr -> SlotId -> Int -> IO (Rv, [Int])-_getMechanismList functionListPtr slotId maxMechanisms = do- alloca $ \arrayLenPtr -> do- poke arrayLenPtr (fromIntegral maxMechanisms)- allocaArray maxMechanisms $ \array -> do- res <- {#call unsafe CK_FUNCTION_LIST.C_GetMechanismList#} functionListPtr (fromIntegral slotId) array arrayLenPtr- arrayLen <- peek arrayLenPtr- objectHandles <- peekArray (fromIntegral arrayLen) array- return (fromIntegral res, map (fromIntegral) objectHandles)---{#fun unsafe CK_FUNCTION_LIST.C_GetMechanismInfo as _getMechanismInfo- {`FunctionListPtr',- `SlotId',- `Int',- alloca- `MechInfo' peek* } -> `Rv' fromIntegral-#}---rvToStr :: Rv -> String-rvToStr {#const CKR_OK#} = "ok"-rvToStr {#const CKR_ARGUMENTS_BAD#} = "bad arguments"-rvToStr {#const CKR_ATTRIBUTE_READ_ONLY#} = "attribute is read-only"-rvToStr {#const CKR_ATTRIBUTE_TYPE_INVALID#} = "invalid attribute type specified in template"-rvToStr {#const CKR_ATTRIBUTE_VALUE_INVALID#} = "invalid attribute value specified in template"-rvToStr {#const CKR_BUFFER_TOO_SMALL#} = "buffer too small"-rvToStr {#const CKR_CRYPTOKI_NOT_INITIALIZED#} = "cryptoki not initialized"-rvToStr {#const CKR_DATA_INVALID#} = "data invalid"-rvToStr {#const CKR_DEVICE_ERROR#} = "device error"-rvToStr {#const CKR_DEVICE_MEMORY#} = "device memory"-rvToStr {#const CKR_DEVICE_REMOVED#} = "device removed"-rvToStr {#const CKR_DOMAIN_PARAMS_INVALID#} = "invalid domain parameters"-rvToStr {#const CKR_ENCRYPTED_DATA_INVALID#} = "encrypted data is invalid"-rvToStr {#const CKR_ENCRYPTED_DATA_LEN_RANGE#} = "encrypted data length not in range"-rvToStr {#const CKR_FUNCTION_CANCELED#} = "function canceled"-rvToStr {#const CKR_FUNCTION_FAILED#} = "function failed"-rvToStr {#const CKR_FUNCTION_NOT_SUPPORTED#} = "function not supported"-rvToStr {#const CKR_GENERAL_ERROR#} = "general error"-rvToStr {#const CKR_HOST_MEMORY#} = "host memory"-rvToStr {#const CKR_KEY_FUNCTION_NOT_PERMITTED#} = "key function not permitted"-rvToStr {#const CKR_KEY_HANDLE_INVALID#} = "key handle invalid"-rvToStr {#const CKR_KEY_SIZE_RANGE#} = "key size range"-rvToStr {#const CKR_KEY_TYPE_INCONSISTENT#} = "key type inconsistent"-rvToStr {#const CKR_MECHANISM_INVALID#} = "invalid mechanism"-rvToStr {#const CKR_MECHANISM_PARAM_INVALID#} = "invalid mechanism parameter"-rvToStr {#const CKR_OPERATION_ACTIVE#} = "there is already an active operation in-progress"-rvToStr {#const CKR_OPERATION_NOT_INITIALIZED#} = "operation was not initialized"-rvToStr {#const CKR_PIN_EXPIRED#} = "PIN is expired, you need to setup a new PIN"-rvToStr {#const CKR_PIN_INCORRECT#} = "PIN is incorrect, authentication failed"-rvToStr {#const CKR_PIN_LOCKED#} = "PIN is locked, authentication failed"-rvToStr {#const CKR_SESSION_CLOSED#} = "session was closed in a middle of operation"-rvToStr {#const CKR_SESSION_COUNT#} = "session count"-rvToStr {#const CKR_SESSION_HANDLE_INVALID#} = "session handle is invalid"-rvToStr {#const CKR_SESSION_PARALLEL_NOT_SUPPORTED#} = "parallel session not supported"-rvToStr {#const CKR_SESSION_READ_ONLY#} = "session is read-only"-rvToStr {#const CKR_SESSION_READ_ONLY_EXISTS#} = "read-only session exists, SO cannot login"-rvToStr {#const CKR_SESSION_READ_WRITE_SO_EXISTS#} = "read-write SO session exists"-rvToStr {#const CKR_SLOT_ID_INVALID#} = "slot id invalid"-rvToStr {#const CKR_TEMPLATE_INCOMPLETE#} = "provided template is incomplete"-rvToStr {#const CKR_TEMPLATE_INCONSISTENT#} = "provided template is inconsistent"-rvToStr {#const CKR_TOKEN_NOT_PRESENT#} = "token not present"-rvToStr {#const CKR_TOKEN_NOT_RECOGNIZED#} = "token not recognized"-rvToStr {#const CKR_TOKEN_WRITE_PROTECTED#} = "token is write protected"-rvToStr {#const CKR_UNWRAPPING_KEY_HANDLE_INVALID#} = "unwrapping key handle invalid"-rvToStr {#const CKR_UNWRAPPING_KEY_SIZE_RANGE#} = "unwrapping key size not in range"-rvToStr {#const CKR_UNWRAPPING_KEY_TYPE_INCONSISTENT#} = "unwrapping key type inconsistent"-rvToStr {#const CKR_USER_NOT_LOGGED_IN#} = "user needs to be logged in to perform this operation"-rvToStr {#const CKR_USER_ALREADY_LOGGED_IN#} = "user already logged in"-rvToStr {#const CKR_USER_ANOTHER_ALREADY_LOGGED_IN#} = "another user already logged in, first another user should be logged out"-rvToStr {#const CKR_USER_PIN_NOT_INITIALIZED#} = "user PIN not initialized, need to setup PIN first"-rvToStr {#const CKR_USER_TOO_MANY_TYPES#} = "cannot login user, somebody should logout first"-rvToStr {#const CKR_USER_TYPE_INVALID#} = "invalid value for user type"-rvToStr {#const CKR_WRAPPED_KEY_INVALID#} = "wrapped key invalid"-rvToStr {#const CKR_WRAPPED_KEY_LEN_RANGE#} = "wrapped key length not in range"-rvToStr {#const CKR_KEY_UNEXTRACTABLE#} = "key unextractable"-rvToStr rv = "unknown value for error " ++ (show rv)----- Attributes--{#enum define ClassType {- CKO_DATA as Data,- CKO_CERTIFICATE as Certificate,- CKO_PUBLIC_KEY as PublicKey, -- ^ asymmetric public key, e.g. RSA public key- CKO_PRIVATE_KEY as PrivateKey, -- ^ asymmetric private key, e.g. RSA private key- CKO_SECRET_KEY as SecretKey, -- ^ symmetric key, e.g. AES key- CKO_HW_FEATURE as HWFeature,- CKO_DOMAIN_PARAMETERS as DomainParameters, -- ^ e.g. parameters for Diffie-Hellman- CKO_MECHANISM as Mechanism-} deriving (Show, Eq)-#}--{#enum define KeyTypeValue {- CKK_RSA as RSA,- CKK_DSA as DSA,- CKK_DH as DH,- CKK_ECDSA as ECDSA,- CKK_EC as EC,- CKK_AES as AES- } deriving (Show, Eq) #}--{#enum define AttributeType {- CKA_CLASS as ClassType,- CKA_TOKEN as TokenType,- CKA_PRIVATE as PrivateType,- CKA_LABEL as LabelType,- CKA_APPLICATION as ApplicationType,- CKA_VALUE as ValueType,- CKA_OBJECT_ID as ObjectType,- CKA_CERTIFICATE_TYPE as CertificateType,- CKA_ISSUER as IssuerType,- CKA_SERIAL_NUMBER as SerialNumberType,- CKA_AC_ISSUER as AcIssuerType,- CKA_OWNER as OwnerType,- CKA_ATTR_TYPES as AttrTypesType,- CKA_TRUSTED as TrustedType,- CKA_CERTIFICATE_CATEGORY as CertificateCategoryType,- CKA_JAVA_MIDP_SECURITY_DOMAIN as JavaMidpSecurityDomainType,- CKA_URL as UrlType,- CKA_HASH_OF_SUBJECT_PUBLIC_KEY as HashOfSubjectPublicKeyType,- CKA_HASH_OF_ISSUER_PUBLIC_KEY as HashOfIssuerPublicKeyType,- CKA_CHECK_VALUE as CheckValueType,-- CKA_KEY_TYPE as KeyTypeType,- CKA_SUBJECT as SubjectType,- CKA_ID as IdType,- CKA_SENSITIVE as SensitiveType,- CKA_ENCRYPT as EncryptType,- CKA_DECRYPT as DecryptType,- CKA_WRAP as WrapType,- CKA_UNWRAP as UnwrapType,- CKA_SIGN as SignType,- CKA_SIGN_RECOVER as SignRecoverType,- CKA_VERIFY as VerifyType,- CKA_VERIFY_RECOVER as VerifyRecoverType,- CKA_DERIVE as DeriveType,- CKA_START_DATE as StartDateType,- CKA_END_DATE as EndDataType,- CKA_PUBLIC_EXPONENT as PublicExponentType,- CKA_PRIVATE_EXPONENT as PrivateExponentType,- CKA_MODULUS as ModulusType,- CKA_MODULUS_BITS as ModulusBitsType,- CKA_PRIME_1 as Prime1Type,- CKA_PRIME_2 as Prime2Type,- CKA_EXPONENT_1 as Exponent1Type,- CKA_EXPONENT_2 as Exponent2Type,- CKA_COEFFICIENT as CoefficientType,- CKA_PRIME as PrimeType,- CKA_SUBPRIME as SubPrimeType,- CKA_BASE as BaseType,-- CKA_PRIME_BITS as PrimeBitsType,- CKA_SUBPRIME_BITS as SubPrimeBitsType,-- CKA_VALUE_BITS as ValueBitsType,- CKA_VALUE_LEN as ValueLenType,- CKA_EXTRACTABLE as ExtractableType,- CKA_LOCAL as LocalType,- CKA_NEVER_EXTRACTABLE as NeverExtractableType,- CKA_ALWAYS_SENSITIVE as AlwaysSensitiveType,- CKA_KEY_GEN_MECHANISM as KeyGenMechanismType,-- CKA_MODIFIABLE as ModifiableType,-- -- CKA_ECDSA_PARAMS is deprecated in v2.11,- -- CKA_EC_PARAMS is preferred.- CKA_ECDSA_PARAMS as EcdsaParamsType,- CKA_EC_PARAMS as EcParamsType,-- CKA_EC_POINT as EcPointType,-- -- CKA_SECONDARY_AUTH, CKA_AUTH_PIN_FLAGS,- -- are new for v2.10. Deprecated in v2.11 and onwards.- CKA_SECONDARY_AUTH as SecondaryAuthType,- CKA_AUTH_PIN_FLAGS as AuthPinFlagsType,-- CKA_ALWAYS_AUTHENTICATE as AlwaysAuthenticateType,-- CKA_WRAP_WITH_TRUSTED as WrapWithTrustedType,- CKA_WRAP_TEMPLATE as WrapTemplateType,- CKA_UNWRAP_TEMPLATE as UnwrapTemplateType,- CKA_DERIVE_TEMPLATE as DeriveTemplateType,-- CKA_OTP_FORMAT as OtpFormatType,- CKA_OTP_LENGTH as OtpLengthType,- CKA_OTP_TIME_INTERVAL as OtpTimeIntervalType,- CKA_OTP_USER_FRIENDLY_MODE as OtpUserFriendlyModeType,- CKA_OTP_CHALLENGE_REQUIREMENT as OtpChallengeRequirementType,- CKA_OTP_TIME_REQUIREMENT as OtpTimeRequirementType,- CKA_OTP_COUNTER_REQUIREMENT as OtpCounterRequirementType,- CKA_OTP_PIN_REQUIREMENT as OtpPinRequirementType,- CKA_OTP_COUNTER as OtpCounterType,- CKA_OTP_TIME as OtpTimeType,- CKA_OTP_USER_IDENTIFIER as OtpUserIdentifierType,- CKA_OTP_SERVICE_IDENTIFIER as OtpServiceIdentifierType,- CKA_OTP_SERVICE_LOGO as OtpServiceLogoType,- CKA_OTP_SERVICE_LOGO_TYPE as OtpServiceLogoTypeType,-- CKA_GOSTR3410_PARAMS as GostR3410ParamsType,- CKA_GOSTR3411_PARAMS as GostR3411ParamsType,- CKA_GOST28147_PARAMS as Gost28147ParamsType,-- CKA_HW_FEATURE_TYPE as HwFeatureTypeType,- CKA_RESET_ON_INIT as ResetOnInitType,- CKA_HAS_RESET as HasResetType,-- CKA_PIXEL_X as PixelXType,- CKA_PIXEL_Y as PixelYType,- CKA_RESOLUTION as ResolutionType,- CKA_CHAR_ROWS as CharRowsType,- CKA_CHAR_COLUMNS as CharColumnsType,- CKA_COLOR as ColorType,- CKA_BITS_PER_PIXEL as BitPerPixelType,- CKA_CHAR_SETS as CharSetsType,- CKA_ENCODING_METHODS as EncodingMethodsType,- CKA_MIME_TYPES as MimeTypesType,- CKA_MECHANISM_TYPE as MechanismTypeType,- CKA_REQUIRED_CMS_ATTRIBUTES as RequiredCmsAttributesType,- CKA_DEFAULT_CMS_ATTRIBUTES as DefaultCmsAttributesType,- CKA_SUPPORTED_CMS_ATTRIBUTES as SupportedCmsAttributesType,- CKA_ALLOWED_MECHANISMS as AllowedMechanismsType,-- CKA_VENDOR_DEFINED as VendorDefinedType- } deriving (Show, Eq) #}---- | Represents an attribute of an object-data Attribute = Class ClassType -- ^ class of an object, e.g. 'PrivateKey', 'SecretKey'- | KeyType KeyTypeValue -- ^ e.g. 'RSA' or 'AES'- | Label String -- ^ object's label- | Token Bool -- ^ whether object is stored on the token or is a temporary session object- | Decrypt Bool -- ^ allow/deny encryption function for an object- | Sign Bool -- ^ allow/deny signing function for an object- | ModulusBits Int -- ^ number of bits used by modulus, for example in RSA public key- | Modulus Integer -- ^ modulus value, used by RSA keys- | PublicExponent Integer -- ^ value of public exponent, used by RSA public keys- | PrimeBits Int -- ^ number of bits used by prime in classic Diffie-Hellman- | Prime Integer -- ^ value of prime modulus, used in classic Diffie-Hellman- | Base Integer -- ^ value of generator, used in classic Diffie-Hellman- | ValueLen Int -- ^ length in bytes of the corresponding 'Value' attribute- | Value BS.ByteString -- ^ object's value attribute, for example it is a DER encoded certificate for certificate objects- | Extractable Bool -- ^ allows or denys extraction of certain attributes of private keys- deriving (Show)--data LlAttribute = LlAttribute {- attributeType :: AttributeType,- attributeValuePtr :: Ptr (),- attributeSize :: {#type CK_ULONG#}-}--instance Storable LlAttribute where- sizeOf _ = {#sizeof CK_ATTRIBUTE_TYPE#} + {#sizeof CK_VOID_PTR#} + {#sizeof CK_ULONG#}- alignment _ = 1- poke p x = do- poke (p `plusPtr` 0) (fromEnum $ attributeType x)- poke (p `plusPtr` {#sizeof CK_ATTRIBUTE_TYPE#}) (attributeValuePtr x :: {#type CK_VOID_PTR#})- poke (p `plusPtr` ({#sizeof CK_ATTRIBUTE_TYPE#} + {#sizeof CK_VOID_PTR#})) (attributeSize x)- peek p = do- attrType <- peek (p `plusPtr` 0) :: IO {#type CK_ATTRIBUTE_TYPE#}- valPtr <- peek (p `plusPtr` {#sizeof CK_ATTRIBUTE_TYPE#})- valSize <- peek (p `plusPtr` ({#sizeof CK_ATTRIBUTE_TYPE#} + {#sizeof CK_VOID_PTR#}))- return $ LlAttribute (toEnum $ fromIntegral attrType) valPtr valSize---_attrType :: Attribute -> AttributeType-_attrType (Class _) = ClassType-_attrType (KeyType _) = KeyTypeType-_attrType (Label _) = LabelType-_attrType (ModulusBits _) = ModulusBitsType-_attrType (PrimeBits _) = PrimeBitsType-_attrType (Token _) = TokenType-_attrType (ValueLen _) = ValueLenType-_attrType (Extractable _) = ExtractableType-_attrType (Value _) = ValueType-_attrType (Prime _) = PrimeType-_attrType (Base _) = BaseType---_valueSize :: Attribute -> Int-_valueSize (Class _) = {#sizeof CK_OBJECT_CLASS#}-_valueSize (KeyType _) = {#sizeof CK_KEY_TYPE#}-_valueSize (Label l) = BU8.length $ BU8.fromString l-_valueSize (ModulusBits _) = {#sizeof CK_ULONG#}-_valueSize (PrimeBits _) = {#sizeof CK_ULONG#}-_valueSize (Token _) = {#sizeof CK_BBOOL#}-_valueSize (ValueLen _) = {#sizeof CK_ULONG#}-_valueSize (Extractable _) = {#sizeof CK_BBOOL#}-_valueSize (Value bs) = BS.length bs-_valueSize (Prime p) = _bigIntLen p-_valueSize (Base b) = _bigIntLen b---_pokeValue :: Attribute -> Ptr () -> IO ()-_pokeValue (Class c) ptr = poke (castPtr ptr :: Ptr {#type CK_OBJECT_CLASS#}) (fromIntegral $ fromEnum c)-_pokeValue (KeyType k) ptr = poke (castPtr ptr :: Ptr {#type CK_KEY_TYPE#}) (fromIntegral $ fromEnum k)-_pokeValue (Label l) ptr = unsafeUseAsCStringLen (BU8.fromString l) $ \(src, len) -> copyBytes ptr (castPtr src :: Ptr ()) len-_pokeValue (ModulusBits l) ptr = poke (castPtr ptr :: Ptr {#type CK_ULONG#}) (fromIntegral l)-_pokeValue (PrimeBits l) ptr = poke (castPtr ptr :: Ptr {#type CK_ULONG#}) (fromIntegral l)-_pokeValue (Token b) ptr = poke (castPtr ptr :: Ptr {#type CK_BBOOL#}) (fromBool b :: {#type CK_BBOOL#})-_pokeValue (ValueLen l) ptr = poke (castPtr ptr :: Ptr {#type CK_ULONG#}) (fromIntegral l :: {#type CK_ULONG#})-_pokeValue (Extractable b) ptr = poke (castPtr ptr :: Ptr {#type CK_BBOOL#}) (fromBool b :: {#type CK_BBOOL#})-_pokeValue (Value bs) ptr = unsafeUseAsCStringLen bs $ \(src, len) -> copyBytes ptr (castPtr src :: Ptr ()) len-_pokeValue (Prime p) ptr = _pokeBigInt p (castPtr ptr)-_pokeValue (Base b) ptr = _pokeBigInt b (castPtr ptr)---_pokeValues :: [Attribute] -> Ptr () -> IO ()-_pokeValues [] p = return ()-_pokeValues (a:rem) p = do- _pokeValue a p- _pokeValues rem (p `plusPtr` (_valueSize a))---_valuesSize :: [Attribute] -> Int-_valuesSize attribs = foldr (+) 0 (map (_valueSize) attribs)---_makeLowLevelAttrs :: [Attribute] -> Ptr () -> [LlAttribute]-_makeLowLevelAttrs [] valuePtr = []-_makeLowLevelAttrs (a:rem) valuePtr =- let valuePtr' = valuePtr `plusPtr` (_valueSize a)- llAttr = LlAttribute {attributeType=_attrType a, attributeValuePtr=valuePtr, attributeSize=(fromIntegral $ _valueSize a)}- in- llAttr:(_makeLowLevelAttrs rem valuePtr')---_withAttribs :: [Attribute] -> (Ptr LlAttribute -> IO a) -> IO a-_withAttribs attribs f = do- allocaBytes (_valuesSize attribs) $ \valuesPtr -> do- _pokeValues attribs valuesPtr- allocaArray (length attribs) $ \attrsPtr -> do- pokeArray attrsPtr (_makeLowLevelAttrs attribs valuesPtr)- f attrsPtr----- from http://hackage.haskell.org/package/binary-0.5.0.2/docs/src/Data-Binary.html#unroll-unroll :: Integer -> [Word8]-unroll = unfoldr step- where- step 0 = Nothing- step i = Just (fromIntegral i, i `shiftR` 8)---_bigIntLen i = length $ unroll i---_pokeBigInt i ptr = pokeArray ptr (unroll i)---_peekBigInt :: Ptr () -> CULong -> IO Integer-_peekBigInt ptr len = do- arr <- peekArray (fromIntegral len) (castPtr ptr :: Ptr Word8)- return $ foldl (\acc v -> (fromIntegral v) + (acc * 256)) 0 arr---_llAttrToAttr :: LlAttribute -> IO Attribute-_llAttrToAttr (LlAttribute ClassType ptr len) = do- val <- peek (castPtr ptr :: Ptr {#type CK_OBJECT_CLASS#})- return (Class $ toEnum $ fromIntegral val)-_llAttrToAttr (LlAttribute ModulusType ptr len) = do- val <- _peekBigInt ptr len- return (Modulus val)-_llAttrToAttr (LlAttribute PublicExponentType ptr len) = do- val <- _peekBigInt ptr len- return (PublicExponent val)-_llAttrToAttr (LlAttribute PrimeType ptr len) = do- val <- _peekBigInt ptr len- return (Prime val)-_llAttrToAttr (LlAttribute BaseType ptr len) = do- val <- _peekBigInt ptr len- return (Base val)-_llAttrToAttr (LlAttribute DecryptType ptr len) = do- val <- peek (castPtr ptr :: Ptr {#type CK_BBOOL#})- return $ Decrypt(val /= 0)-_llAttrToAttr (LlAttribute SignType ptr len) = do- val <- peek (castPtr ptr :: Ptr {#type CK_BBOOL#})- return $ Sign(val /= 0)----- High level API starts here---- | Represents a PKCS#11 library.-data Library = Library {- libraryHandle :: DL,- functionListPtr :: FunctionListPtr-}----- | Represent session. Created by 'withSession' function.-data Session = Session SessionHandle FunctionListPtr----- | Load PKCS#11 dynamically linked library from given path------ > lib <- loadLibrary "/path/to/dll.so"-loadLibrary :: String -> IO Library-loadLibrary libraryPath = do- lib <- dlopen libraryPath []- getFunctionListFunPtr <- dlsym lib "C_GetFunctionList"- (rv, functionListPtr) <- getFunctionList getFunctionListFunPtr- if rv /= 0- then fail $ "failed to get list of functions " ++ (rvToStr rv)- else do- rv <- initialize functionListPtr- if rv /= 0- then fail $ "failed to initialize library " ++ (rvToStr rv)- else return Library { libraryHandle = lib, functionListPtr = functionListPtr }----- | Releases resources used by loaded library-releaseLibrary lib = do- rv <- finalize $ functionListPtr lib- dlclose $ libraryHandle lib----- | Get general information about Cryptoki library-getInfo :: Library -> IO LibraryInfo-getInfo (Library _ functionListPtr) = do- (rv, info) <- getInfo' functionListPtr- if rv /= 0- then fail $ "failed to get library information " ++ (rvToStr rv)- else return info----- | Initialize a token in a given slot. All objects created by user on the token are destroyed.-initToken :: Library -- ^ PKCS#11 library- -> SlotId -- ^ slot id in which to initialize token- -> BU8.ByteString -- ^ token's security officer password- -> String -- ^ new label for the token- -> IO ()-initToken (Library _ funcListPtr) slotId pin label = do- rv <- initToken' funcListPtr slotId pin label- if rv /= 0- then fail $ "failed to initialize token " ++ (rvToStr rv)- else return ()----- | Obtains information about a particular slot in the system------ > slotInfo <- getSlotInfo lib slotId-getSlotInfo :: Library -> SlotId -> IO SlotInfo-getSlotInfo (Library _ functionListPtr) slotId = do- (rv, slotInfo) <- getSlotInfo' functionListPtr slotId- if rv /= 0- then fail $ "failed to get slot information " ++ (rvToStr rv)- else return slotInfo----- | Obtains information about a particular token in the system------ > tokenInfo <- getTokenInfo lib slotId-getTokenInfo :: Library -> SlotId -> IO TokenInfo-getTokenInfo (Library _ functionListPtr) slotId = do- (rv, slotInfo) <- getTokenInfo' functionListPtr slotId- if rv /= 0- then fail $ "failed to get token information " ++ (rvToStr rv)- else return slotInfo---_openSessionEx :: Library -> SlotId -> Int -> IO Session-_openSessionEx (Library _ functionListPtr) slotId flags = do- (rv, sessionHandle) <- openSession' functionListPtr slotId flags- if rv /= 0- then fail $ "failed to open slot: " ++ (rvToStr rv)- else return $ Session sessionHandle functionListPtr---_closeSessionEx :: Session -> IO ()-_closeSessionEx (Session sessionHandle functionListPtr) = do- rv <- closeSession' functionListPtr sessionHandle- if rv /= 0- then fail $ "failed to close slot: " ++ (rvToStr rv)- else return ()----- | Opens a read-only or read-write session with a token in a given slot and then closes it after callback function is finished.-withSession :: Library -- ^ Library to use.- -> SlotId -- ^ Slot ID for which to open session.- -> Bool -- ^ If True will open writable session, otherwise will open read-only session.- -> (Session -> IO a) -- ^ Callback function which is executed while session is open.- -> IO a -- ^ Returns a result of callback function.-withSession lib slotId writable f = do- let flags = if writable then _rwSession else 0- bracket- (_openSessionEx lib slotId (flags .|. _serialSession))- (_closeSessionEx)- (f)----_findObjectsInitEx :: Session -> [Attribute] -> IO ()-_findObjectsInitEx (Session sessionHandle functionListPtr) attribs = do- rv <- findObjectsInit' functionListPtr sessionHandle attribs- if rv /= 0- then fail $ "failed to initialize search: " ++ (rvToStr rv)- else return ()---_findObjectsEx :: Session -> IO [ObjectHandle]-_findObjectsEx (Session sessionHandle functionListPtr) = do- (rv, objectsHandles) <- findObjects' functionListPtr sessionHandle 10- if rv /= 0- then fail $ "failed to execute search: " ++ (rvToStr rv)- else return objectsHandles---_findObjectsFinalEx :: Session -> IO ()-_findObjectsFinalEx (Session sessionHandle functionListPtr) = do- rv <- findObjectsFinal' functionListPtr sessionHandle- if rv /= 0- then fail $ "failed to finalize search: " ++ (rvToStr rv)- else return ()----- | Searches current session for objects matching provided attributes list, returns a list of matching object handles-findObjects :: Session -> [Attribute] -> IO [ObjectHandle]-findObjects session attribs = do- _findObjectsInitEx session attribs- finally (_findObjectsEx session) (_findObjectsFinalEx session)----- | Generates an asymmetric key pair using provided mechanism.------ Examples:------ Generate an 2048-bit RSA key:------ > (pubKey, privKey) <- generateKeyPair sess (simpleMech RsaPkcsKeyPairGen) [ModulusBits 2048] []-generateKeyPair :: Session -- ^ session in which to generate key- -> Mech -- ^ a mechanism to use for key generation, for example 'simpleMech RsaPkcs'- -> [Attribute] -- ^ attributes applied to generated public key object- -> [Attribute] -- ^ attributes applied to generated private key object- -> IO (ObjectHandle, ObjectHandle) -- ^ created objects references, first is public key, second is private key-generateKeyPair (Session sessionHandle functionListPtr) mech pubKeyAttrs privKeyAttrs = do- (rv, pubKeyHandle, privKeyHandle) <- _generateKeyPair functionListPtr sessionHandle mech pubKeyAttrs privKeyAttrs- if rv /= 0- then fail $ "failed to generate key pair: " ++ (rvToStr rv)- else return (pubKeyHandle, privKeyHandle)---{#fun unsafe CK_FUNCTION_LIST.C_DeriveKey as deriveKey'- {`FunctionListPtr',- `SessionHandle',- with* `Mech',- `ObjectHandle',- `LlAttributePtr',- `CULong',- alloca- `ObjectHandle' peek*} -> `Rv'-#}---- | Derives a key from a base key using provided mechanism and applies provided attributes to a resulting key.--- Can be used to derive symmetric key using Diffie-Hellman key exchange.-deriveKey (Session sessHandle funcListPtr) mech baseKeyHandle attribs = do- _withAttribs attribs $ \attribsPtr -> do- (rv, createdHandle) <- deriveKey' funcListPtr sessHandle mech baseKeyHandle attribsPtr (fromIntegral $ length attribs)- if rv /= 0- then fail $ "failed to derive key: " ++ (rvToStr rv)- else return createdHandle---{#fun unsafe CK_FUNCTION_LIST.C_CreateObject as createObject'- {`FunctionListPtr',- `SessionHandle',- `LlAttributePtr',- `CULong',- alloca- `ObjectHandle' peek*} -> `Rv'-#}---- | Creates an object from given list of attributes and returns a reference to created object.-createObject (Session sessHandle funcListPtr) attribs = do- _withAttribs attribs $ \attribsPtr -> do- (rv, createdHandle) <- createObject' funcListPtr sessHandle attribsPtr (fromIntegral $ length attribs)- if rv /= 0- then fail $ "failed to create object: " ++ (rvToStr rv)- else return createdHandle---{#fun unsafe CK_FUNCTION_LIST.C_CopyObject as copyObject'- {`FunctionListPtr',- `SessionHandle',- `ObjectHandle',- `LlAttributePtr',- `CULong',- alloca- `ObjectHandle' peek*} -> `Rv'-#}---- | Makes a copy of an object and changes attributes of copied object, returns a reference to new object.-copyObject (Session sessHandle funcListPtr) objHandle attribs = do- _withAttribs attribs $ \attribsPtr -> do- (rv, createdHandle) <- copyObject' funcListPtr sessHandle objHandle attribsPtr (fromIntegral $ length attribs)- if rv /= 0- then fail $ "failed to copy object: " ++ (rvToStr rv)- else return createdHandle---{#fun unsafe CK_FUNCTION_LIST.C_GetObjectSize as getObjectSize'- {`FunctionListPtr',- `SessionHandle',- `ObjectHandle',- alloca- `CULong' peek*} -> `Rv'-#}---- | Returns an approximate amount of space occupied by an object in bytes.-getObjectSize (Session sessHandle funcListPtr) objHandle = do- (rv, objSize) <- getObjectSize' funcListPtr sessHandle objHandle- if rv /= 0- then fail $ "failed to get object size: " ++ (rvToStr rv)- else return objSize---_getAttr :: Session -> ObjectHandle -> AttributeType -> Ptr x -> IO ()-_getAttr (Session sessionHandle functionListPtr) objHandle attrType valPtr = do- alloca $ \attrPtr -> do- poke attrPtr (LlAttribute attrType (castPtr valPtr) (fromIntegral $ sizeOf valPtr))- rv <- {#call unsafe CK_FUNCTION_LIST.C_GetAttributeValue#} functionListPtr sessionHandle objHandle attrPtr 1- if rv /= 0- then fail $ "failed to get attribute: " ++ (rvToStr rv)- else return ()---getBoolAttr :: Session -> ObjectHandle -> AttributeType -> IO Bool-getBoolAttr sess objHandle attrType = do- alloca $ \valuePtr -> do- _getAttr sess objHandle attrType (valuePtr :: Ptr CK_BBOOL)- val <- peek valuePtr- return $ toBool val---getObjectAttr :: Session -> ObjectHandle -> AttributeType -> IO Attribute-getObjectAttr (Session sessionHandle functionListPtr) objHandle attrType = do- alloca $ \attrPtr -> do- poke attrPtr (LlAttribute attrType nullPtr 0)- rv <- {#call unsafe CK_FUNCTION_LIST.C_GetAttributeValue#} functionListPtr sessionHandle objHandle attrPtr 1- attrWithLen <- peek attrPtr- allocaBytes (fromIntegral $ attributeSize attrWithLen) $ \attrVal -> do- poke attrPtr (LlAttribute attrType attrVal (attributeSize attrWithLen))- rv <- {#call unsafe CK_FUNCTION_LIST.C_GetAttributeValue#} functionListPtr sessionHandle objHandle attrPtr 1- if rv /= 0- then fail $ "failed to get attribute: " ++ (rvToStr rv)- else do- llAttr <- peek attrPtr- _llAttrToAttr llAttr---getTokenFlag sess objHandle = getBoolAttr sess objHandle TokenType-getPrivateFlag sess objHandle = getBoolAttr sess objHandle PrivateType-getSensitiveFlag sess objHandle = getBoolAttr sess objHandle SensitiveType-getEncryptFlag sess objHandle = getBoolAttr sess objHandle EncryptType-getDecryptFlag sess objHandle = getBoolAttr sess objHandle DecryptType-getWrapFlag sess objHandle = getBoolAttr sess objHandle WrapType-getUnwrapFlag sess objHandle = getBoolAttr sess objHandle UnwrapType-getSignFlag sess objHandle = getBoolAttr sess objHandle SignType--getModulus :: Session -> ObjectHandle -> IO Integer-getModulus sess objHandle = do- (Modulus m) <- getObjectAttr sess objHandle ModulusType- return m--getPublicExponent :: Session -> ObjectHandle -> IO Integer-getPublicExponent sess objHandle = do- (PublicExponent v) <- getObjectAttr sess objHandle PublicExponentType- return v--getPrime sess objHandle = do- (Prime p) <- getObjectAttr sess objHandle PrimeType- return p--getBase sess objHandle = do- (Base p) <- getObjectAttr sess objHandle BaseType- return p---{#fun unsafe CK_FUNCTION_LIST.C_SetAttributeValue as setAttributeValue'- {`FunctionListPtr',- `SessionHandle',- `ObjectHandle',- `LlAttributePtr',- `CULong'} -> `Rv'-#}---- | Modifies attributes of an object.-setAttributes (Session sessHandle funcListPtr) objHandle attribs = do- _withAttribs attribs $ \attribsPtr -> do- rv <- setAttributeValue' funcListPtr sessHandle objHandle attribsPtr (fromIntegral $ length attribs)- if rv /= 0- then fail $ "failed to set attributes: " ++ (rvToStr rv)- else return ()----- | Initializes normal user's PIN. Session should be logged in by SO user in other words it should be in--- 'RWSOFunctions' state.-initPin :: Session -> BU8.ByteString -> IO ()-initPin (Session sessHandle funcListPtr) pin = do- rv <- initPin' funcListPtr sessHandle pin- if rv /= 0- then fail $ "initPin failed: " ++ (rvToStr rv)- else return ()----- | Changes PIN of a currently logged in user.-setPin :: Session -- ^ session to act on- -> BU8.ByteString -- ^ old PIN- -> BU8.ByteString -- ^ new PIN- -> IO ()-setPin (Session sessHandle funcListPtr) oldPin newPin = do- rv <- setPin' funcListPtr sessHandle oldPin newPin- if rv /= 0- then fail $ "setPin failed: " ++ (rvToStr rv)- else return ()----- | Logs a user into a token.-login :: Session -- ^ session to act on- -> UserType -- ^ type of user to login- -> BU8.ByteString -- ^ user's PIN- -> IO ()-login (Session sessionHandle functionListPtr) userType pin = do- rv <- _login functionListPtr sessionHandle userType pin- if rv /= 0- then fail $ "login failed: " ++ (rvToStr rv)- else return ()----- | Logs a user out from a token.-logout :: Session -> IO ()-logout (Session sessionHandle functionListPtr) = do- rv <- {#call unsafe CK_FUNCTION_LIST.C_Logout#} functionListPtr sessionHandle- if rv /= 0- then fail $ "logout failed: " ++ (rvToStr rv)- else return ()---{#enum define MechType {- CKM_RSA_PKCS_KEY_PAIR_GEN as RsaPkcsKeyPairGen,- CKM_RSA_PKCS as RsaPkcs,- CKM_RSA_9796 as Rsa9796,- CKM_RSA_X_509 as RsaX509,- CKM_MD2_RSA_PKCS as Md2RsaPkcs,-- 0x00000004- CKM_MD5_RSA_PKCS as Md5RsaPkcs,-- 0x00000005- CKM_SHA1_RSA_PKCS as Sha1RsaPkcs,-- 0x00000006- CKM_RIPEMD128_RSA_PKCS as RipeMd128RsaPkcs,-- 0x00000007- CKM_RIPEMD160_RSA_PKCS as RipeMd160RsaPkcs,-- 0x00000008- CKM_RSA_PKCS_OAEP as RsaPkcsOaep,-- 0x00000009- CKM_RSA_X9_31_KEY_PAIR_GEN as RsaX931KeyPairGen,-- 0x0000000A- CKM_RSA_X9_31 as RsaX931,-- 0x0000000B- CKM_SHA1_RSA_X9_31 as Sha1RsaX931,-- 0x0000000C- CKM_RSA_PKCS_PSS as RsaPkcsPss,-- 0x0000000D- CKM_SHA1_RSA_PKCS_PSS as Sha1RsaPkcsPss,-- 0x0000000E- CKM_DSA_KEY_PAIR_GEN as DsaKeyPairGen,-- 0x00000010- CKM_DSA as Dsa,-- 0x00000011- CKM_DSA_SHA1 as DsaSha1,-- 0x00000012- CKM_DH_PKCS_KEY_PAIR_GEN as DhPkcsKeyPairGen,-- 0x00000020- CKM_DH_PKCS_DERIVE as DhPkcsDerive,-- 0x00000021- CKM_X9_42_DH_KEY_PAIR_GEN as X942DhKeyPairGen,-- 0x00000030- CKM_X9_42_DH_DERIVE as X942DhDerive,-- 0x00000031- CKM_X9_42_DH_HYBRID_DERIVE as X942DhHybridDerive,-- 0x00000032- CKM_X9_42_MQV_DERIVE as X942MqvDerive,-- 0x00000033- CKM_SHA256_RSA_PKCS as Sha256RsaPkcs,-- 0x00000040- CKM_SHA384_RSA_PKCS as Sha384RsaPkcs,-- 0x00000041- CKM_SHA512_RSA_PKCS as Sha512RsaPkcs,-- 0x00000042- CKM_SHA256_RSA_PKCS_PSS as Sha256RsaPkcsPss,-- 0x00000043- CKM_SHA384_RSA_PKCS_PSS as Sha384RsaPkcsPss,-- 0x00000044- CKM_SHA512_RSA_PKCS_PSS as Sha512RsaPkcsPss,-- 0x00000045-- -- SHA-224 RSA mechanisms are new for PKCS #11 v2.20 amendment 3- CKM_SHA224_RSA_PKCS as Sha224RsaPkcs,-- 0x00000046- CKM_SHA224_RSA_PKCS_PSS as Sha224RsaPkcsPss,-- 0x00000047-- CKM_RC2_KEY_GEN as Rc2KeyGen,-- 0x00000100- CKM_RC2_ECB as Rc2Ecb,-- 0x00000101- CKM_RC2_CBC as Rc2Cbc,-- 0x00000102- CKM_RC2_MAC as Rc2Mac,-- 0x00000103-- -- CKM_RC2_MAC_GENERAL and CKM_RC2_CBC_PAD are new for v2.0- CKM_RC2_MAC_GENERAL as Rc2MacGeneral,-- 0x00000104- CKM_RC2_CBC_PAD as Rc2CbcPad,--0x00000105-- CKM_RC4_KEY_GEN as Rc4KeyGen,--0x00000110- CKM_RC4 as Rc4,--0x00000111- CKM_DES_KEY_GEN as DesKeyGen,--0x00000120- CKM_DES_ECB as DesEcb,--0x00000121- CKM_DES_CBC as DesCbc,--0x00000122- CKM_DES_MAC as DesMac,--0x00000123-- -- CKM_DES_MAC_GENERAL and CKM_DES_CBC_PAD are new for v2.0- CKM_DES_MAC_GENERAL as DesMacGeneral,--0x00000124- CKM_DES_CBC_PAD as DesCbcPad,--0x00000125-- CKM_DES2_KEY_GEN as Des2KeyGen,--0x00000130- CKM_DES3_KEY_GEN as Des3KeyGen,--0x00000131- CKM_DES3_ECB as Des3Ecb,--0x00000132- CKM_DES3_CBC as Des3Cbc,--0x00000133- CKM_DES3_MAC as Des3Mac,--0x00000134-- -- CKM_DES3_MAC_GENERAL, CKM_DES3_CBC_PAD, CKM_CDMF_KEY_GEN,- -- CKM_CDMF_ECB, CKM_CDMF_CBC, CKM_CDMF_MAC,- -- CKM_CDMF_MAC_GENERAL, and CKM_CDMF_CBC_PAD are new for v2.0- CKM_DES3_MAC_GENERAL as Des3MacGeneral,--0x00000135- CKM_DES3_CBC_PAD as Des3CbcPad,--0x00000136- CKM_CDMF_KEY_GEN as CdmfKeyGen,--0x00000140- CKM_CDMF_ECB as CdmfEcb,--0x00000141- CKM_CDMF_CBC as CdmfCbc,--0x00000142- CKM_CDMF_MAC as CdmfMac,--0x00000143- CKM_CDMF_MAC_GENERAL as CdmfMacGeneral,--0x00000144- CKM_CDMF_CBC_PAD as CdmfCbcPad,--0x00000145-- -- the following four DES mechanisms are new for v2.20- CKM_DES_OFB64 as DesOfb64,--0x00000150- CKM_DES_OFB8 as DesOfb8,--0x00000151- CKM_DES_CFB64 as DesCfb64,--0x00000152- CKM_DES_CFB8 as DesCfb8,--0x00000153-- CKM_MD2 as Md2,--0x00000200-- -- CKM_MD2_HMAC and CKM_MD2_HMAC_GENERAL are new for v2.0- CKM_MD2_HMAC as Md2Hmac,--0x00000201- CKM_MD2_HMAC_GENERAL as Md2HmacGeneral,--0x00000202-- CKM_MD5 as Md5,--0x00000210-- -- CKM_MD5_HMAC and CKM_MD5_HMAC_GENERAL are new for v2.0- CKM_MD5_HMAC as Md5Hmac,--0x00000211- CKM_MD5_HMAC_GENERAL as Md5HmacGeneral,--0x00000212-- CKM_SHA_1 as Sha1,--0x00000220-- -- CKM_SHA_1_HMAC and CKM_SHA_1_HMAC_GENERAL are new for v2.0- CKM_SHA_1_HMAC as Sha1Hmac,--0x00000221- CKM_SHA_1_HMAC_GENERAL as Sha1HmacGeneral,--0x00000222-- -- CKM_RIPEMD128, CKM_RIPEMD128_HMAC,- -- CKM_RIPEMD128_HMAC_GENERAL, CKM_RIPEMD160, CKM_RIPEMD160_HMAC,- -- and CKM_RIPEMD160_HMAC_GENERAL are new for v2.10- CKM_RIPEMD128 as RipeMd128,--0x00000230- CKM_RIPEMD128_HMAC as RipeMd128Hmac,--0x00000231- CKM_RIPEMD128_HMAC_GENERAL as RipeMd128HmacGeneral,--0x00000232- CKM_RIPEMD160 as Ripe160,--0x00000240- CKM_RIPEMD160_HMAC as Ripe160Hmac,--0x00000241- CKM_RIPEMD160_HMAC_GENERAL as Ripe160HmacGeneral,--0x00000242-- -- CKM_SHA256/384/512 are new for v2.20- CKM_SHA256 as Sha256,--0x00000250- CKM_SHA256_HMAC as Sha256Hmac,--0x00000251- CKM_SHA256_HMAC_GENERAL as Sha256HmacGeneral,--0x00000252-- -- SHA-224 is new for PKCS #11 v2.20 amendment 3- CKM_SHA224 as Sha224,--0x00000255- CKM_SHA224_HMAC as Sha224Hmac,--0x00000256- CKM_SHA224_HMAC_GENERAL as Sha224HmacGeneral,--0x00000257-- CKM_SHA384 as Sha384,--0x00000260- CKM_SHA384_HMAC as Sha384Hmac,--0x00000261- CKM_SHA384_HMAC_GENERAL as Sha384HmacGeneral,--0x00000262- CKM_SHA512 as Sha512,--0x00000270- CKM_SHA512_HMAC as Sha512Hmac,--0x00000271- CKM_SHA512_HMAC_GENERAL as Sha512HmacGeneral,--0x00000272-- -- SecurID is new for PKCS #11 v2.20 amendment 1- --CKM_SECURID_KEY_GEN 0x00000280- --CKM_SECURID 0x00000282-- -- HOTP is new for PKCS #11 v2.20 amendment 1- --CKM_HOTP_KEY_GEN 0x00000290- --CKM_HOTP 0x00000291-- -- ACTI is new for PKCS #11 v2.20 amendment 1- --CKM_ACTI 0x000002A0- --CKM_ACTI_KEY_GEN 0x000002A1-- -- All of the following mechanisms are new for v2.0- -- Note that CAST128 and CAST5 are the same algorithm- CKM_CAST_KEY_GEN as CastKeyGen,--0x00000300- CKM_CAST_ECB as CastEcb,--0x00000301- CKM_CAST_CBC as CastCbc,--0x00000302- CKM_CAST_MAC as CastMac,--0x00000303- CKM_CAST_MAC_GENERAL as CastMacGeneral,--0x00000304- CKM_CAST_CBC_PAD as CastCbcPad,--0x00000305- CKM_CAST3_KEY_GEN as Cast3KeyGen,--0x00000310- CKM_CAST3_ECB as Cast3Ecb,--0x00000311- CKM_CAST3_CBC as Cast3Cbc,--0x00000312- CKM_CAST3_MAC as Cast3Mac,--0x00000313- CKM_CAST3_MAC_GENERAL as Cast3MacGeneral,--0x00000314- CKM_CAST3_CBC_PAD as Cast3CbcPad,--0x00000315- CKM_CAST5_KEY_GEN as Cast5KeyGen,--0x00000320- CKM_CAST128_KEY_GEN as Cast128KeyGen,--0x00000320- CKM_CAST5_ECB as Cast5Ecb,--0x00000321- CKM_CAST128_ECB as Cast128Ecb,--0x00000321- CKM_CAST5_CBC as Cast5Cbc,--0x00000322- CKM_CAST128_CBC as Cast128Cbc,--0x00000322- CKM_CAST5_MAC as Cast5Mac,--0x00000323- CKM_CAST128_MAC as Cast128Mac,--0x00000323- CKM_CAST5_MAC_GENERAL as Cast5MacGeneral,--0x00000324- CKM_CAST128_MAC_GENERAL as Cast128MacGeneral,--0x00000324- CKM_CAST5_CBC_PAD as Cast5CbcPad,--0x00000325- CKM_CAST128_CBC_PAD as Cast128CbcPad,--0x00000325- CKM_RC5_KEY_GEN as Rc5KeyGen,--0x00000330- CKM_RC5_ECB as Rc5Ecb,--0x00000331- CKM_RC5_CBC as Rc5Cbc,--0x00000332- CKM_RC5_MAC as Rc5Mac,--0x00000333- CKM_RC5_MAC_GENERAL as Rc5MacGeneral,--0x00000334- CKM_RC5_CBC_PAD as Rc5CbcPad,--0x00000335- CKM_IDEA_KEY_GEN as IdeaKeyGen,--0x00000340- CKM_IDEA_ECB as IdeaEcb,--0x00000341- CKM_IDEA_CBC as IdeaCbc,--0x00000342- CKM_IDEA_MAC as IdeaMac,--0x00000343- CKM_IDEA_MAC_GENERAL as IdeaMacGeneral,--0x00000344- CKM_IDEA_CBC_PAD as IdeaCbcPad,--0x00000345- CKM_GENERIC_SECRET_KEY_GEN as GeneralSecretKeyGen,--0x00000350- CKM_CONCATENATE_BASE_AND_KEY as ConcatenateBaseAndKey,--0x00000360- CKM_CONCATENATE_BASE_AND_DATA as ConcatenateBaseAndData,--0x00000362- CKM_CONCATENATE_DATA_AND_BASE as ConcatenateDataAndBase,--0x00000363- CKM_XOR_BASE_AND_DATA as XorBaseAndData,--0x00000364- CKM_EXTRACT_KEY_FROM_KEY as ExtractKeyFromKey,--0x00000365- CKM_SSL3_PRE_MASTER_KEY_GEN as Ssl3PreMasterKeyGen,--0x00000370- CKM_SSL3_MASTER_KEY_DERIVE as Ssl3MasterKeyDerive,--0x00000371- CKM_SSL3_KEY_AND_MAC_DERIVE as Ssl3KeyAndMacDerive,--0x00000372-- -- CKM_SSL3_MASTER_KEY_DERIVE_DH, CKM_TLS_PRE_MASTER_KEY_GEN,- -- CKM_TLS_MASTER_KEY_DERIVE, CKM_TLS_KEY_AND_MAC_DERIVE, and- -- CKM_TLS_MASTER_KEY_DERIVE_DH are new for v2.11- --CKM_SSL3_MASTER_KEY_DERIVE_DH 0x00000373- --CKM_TLS_PRE_MASTER_KEY_GEN 0x00000374- --CKM_TLS_MASTER_KEY_DERIVE 0x00000375- --CKM_TLS_KEY_AND_MAC_DERIVE 0x00000376- --CKM_TLS_MASTER_KEY_DERIVE_DH 0x00000377-- -- CKM_TLS_PRF is new for v2.20- --CKM_TLS_PRF 0x00000378-- --CKM_SSL3_MD5_MAC 0x00000380- --CKM_SSL3_SHA1_MAC 0x00000381- --CKM_MD5_KEY_DERIVATION 0x00000390- --CKM_MD2_KEY_DERIVATION 0x00000391- --CKM_SHA1_KEY_DERIVATION 0x00000392-- -- CKM_SHA256/384/512 are new for v2.20- --CKM_SHA256_KEY_DERIVATION 0x00000393- --CKM_SHA384_KEY_DERIVATION 0x00000394- --CKM_SHA512_KEY_DERIVATION 0x00000395-- -- SHA-224 key derivation is new for PKCS #11 v2.20 amendment 3- CKM_SHA224_KEY_DERIVATION as Sha224KeyDerivation,--0x00000396-- CKM_PBE_MD2_DES_CBC as PbeMd2DesCbc,--0x000003A0- CKM_PBE_MD5_DES_CBC as PbeMd5DesCbc,--0x000003A1- CKM_PBE_MD5_CAST_CBC as PbeMd5CastCbc,--0x000003A2- CKM_PBE_MD5_CAST3_CBC as PbeMd5Cast3Cbc,--0x000003A3- CKM_PBE_MD5_CAST5_CBC as PbeMd5Cast5Cbc,--0x000003A4- CKM_PBE_MD5_CAST128_CBC as PbeMd5Cast128Cbc,--0x000003A4- CKM_PBE_SHA1_CAST5_CBC as PbeSha1Cast5Cbc,--0x000003A5- CKM_PBE_SHA1_CAST128_CBC as PbeSha1Cast128Cbc,--0x000003A5- CKM_PBE_SHA1_RC4_128 as PbeSha1Rc4128,--0x000003A6- CKM_PBE_SHA1_RC4_40 as PbeSha1Rc440,--0x000003A7- CKM_PBE_SHA1_DES3_EDE_CBC as PbeSha1Des3EdeCbc,--0x000003A8- CKM_PBE_SHA1_DES2_EDE_CBC as PbeSha1Des2EdeCbc,--0x000003A9- CKM_PBE_SHA1_RC2_128_CBC as PbeSha1Rc2128Cbc,--0x000003AA- CKM_PBE_SHA1_RC2_40_CBC as PbeSha1Rc240Cbc,--0x000003AB-- -- CKM_PKCS5_PBKD2 is new for v2.10- CKM_PKCS5_PBKD2 as Pkcs5Pbkd2,--0x000003B0-- CKM_PBA_SHA1_WITH_SHA1_HMAC as PbaSha1WithSha1Hmac,--0x000003C0-- -- WTLS mechanisms are new for v2.20- --CKM_WTLS_PRE_MASTER_KEY_GEN 0x000003D0- --CKM_WTLS_MASTER_KEY_DERIVE 0x000003D1- --CKM_WTLS_MASTER_KEY_DERIVE_DH_ECC 0x000003D2- --CKM_WTLS_PRF 0x000003D3- --CKM_WTLS_SERVER_KEY_AND_MAC_DERIVE 0x000003D4- --CKM_WTLS_CLIENT_KEY_AND_MAC_DERIVE 0x000003D5-- --CKM_KEY_WRAP_LYNKS 0x00000400- --CKM_KEY_WRAP_SET_OAEP 0x00000401-- -- CKM_CMS_SIG is new for v2.20- --CKM_CMS_SIG 0x00000500-- -- CKM_KIP mechanisms are new for PKCS #11 v2.20 amendment 2- --CKM_KIP_DERIVE 0x00000510- --CKM_KIP_WRAP 0x00000511- --CKM_KIP_MAC 0x00000512-- -- Camellia is new for PKCS #11 v2.20 amendment 3- --CKM_CAMELLIA_KEY_GEN 0x00000550- --CKM_CAMELLIA_ECB 0x00000551- --CKM_CAMELLIA_CBC 0x00000552- --CKM_CAMELLIA_MAC 0x00000553- --CKM_CAMELLIA_MAC_GENERAL 0x00000554- --CKM_CAMELLIA_CBC_PAD 0x00000555- --CKM_CAMELLIA_ECB_ENCRYPT_DATA 0x00000556- --CKM_CAMELLIA_CBC_ENCRYPT_DATA 0x00000557- --CKM_CAMELLIA_CTR 0x00000558-- -- ARIA is new for PKCS #11 v2.20 amendment 3- --CKM_ARIA_KEY_GEN 0x00000560- --CKM_ARIA_ECB 0x00000561- --CKM_ARIA_CBC 0x00000562- --CKM_ARIA_MAC 0x00000563- --CKM_ARIA_MAC_GENERAL 0x00000564- --CKM_ARIA_CBC_PAD 0x00000565- --CKM_ARIA_ECB_ENCRYPT_DATA 0x00000566- --CKM_ARIA_CBC_ENCRYPT_DATA 0x00000567-- -- Fortezza mechanisms- --CKM_SKIPJACK_KEY_GEN 0x00001000- --CKM_SKIPJACK_ECB64 0x00001001- --CKM_SKIPJACK_CBC64 0x00001002- --CKM_SKIPJACK_OFB64 0x00001003- --CKM_SKIPJACK_CFB64 0x00001004- --CKM_SKIPJACK_CFB32 0x00001005- --CKM_SKIPJACK_CFB16 0x00001006- --CKM_SKIPJACK_CFB8 0x00001007- --CKM_SKIPJACK_WRAP 0x00001008- --CKM_SKIPJACK_PRIVATE_WRAP 0x00001009- --CKM_SKIPJACK_RELAYX 0x0000100a- --CKM_KEA_KEY_PAIR_GEN 0x00001010- --CKM_KEA_KEY_DERIVE 0x00001011- --CKM_FORTEZZA_TIMESTAMP 0x00001020- --CKM_BATON_KEY_GEN 0x00001030- --CKM_BATON_ECB128 0x00001031- --CKM_BATON_ECB96 0x00001032- --CKM_BATON_CBC128 0x00001033- --CKM_BATON_COUNTER 0x00001034- --CKM_BATON_SHUFFLE 0x00001035- --CKM_BATON_WRAP 0x00001036-- -- CKM_ECDSA_KEY_PAIR_GEN is deprecated in v2.11,- -- CKM_EC_KEY_PAIR_GEN is preferred- CKM_ECDSA_KEY_PAIR_GEN as EcdsaKeyPairGen,--0x00001040- CKM_EC_KEY_PAIR_GEN as EcKeyPairGen,--0x00001040-- CKM_ECDSA as Ecdsa,--0x00001041- CKM_ECDSA_SHA1 as EcdsaSha1,--0x00001042-- -- CKM_ECDH1_DERIVE, CKM_ECDH1_COFACTOR_DERIVE, and CKM_ECMQV_DERIVE- -- are new for v2.11- CKM_ECDH1_DERIVE as Ecdh1Derive,--0x00001050- CKM_ECDH1_COFACTOR_DERIVE as Ecdh1CofactorDerive,--0x00001051- CKM_ECMQV_DERIVE as DcmqvDerive,--0x00001052-- CKM_JUNIPER_KEY_GEN as JuniperKeyGen,--0x00001060- CKM_JUNIPER_ECB128 as JuniperEcb128,--0x00001061- CKM_JUNIPER_CBC128 as JuniperCbc128,--0x00001062- CKM_JUNIPER_COUNTER as JuniperCounter,--0x00001063- CKM_JUNIPER_SHUFFLE as JuniperShuffle,--0x00001064- CKM_JUNIPER_WRAP as JuniperWrap,--0x00001065- CKM_FASTHASH as FastHash,--0x00001070-- -- CKM_AES_KEY_GEN, CKM_AES_ECB, CKM_AES_CBC, CKM_AES_MAC,- -- CKM_AES_MAC_GENERAL, CKM_AES_CBC_PAD, CKM_DSA_PARAMETER_GEN,- -- CKM_DH_PKCS_PARAMETER_GEN, and CKM_X9_42_DH_PARAMETER_GEN are- -- new for v2.11- CKM_AES_KEY_GEN as AesKeyGen,--0x00001080- CKM_AES_ECB as AesEcb,- CKM_AES_CBC as AesCbc,- CKM_AES_MAC as AesMac,- CKM_AES_MAC_GENERAL as AesMacGeneral,- CKM_AES_CBC_PAD as AesCbcPad,-- -- AES counter mode is new for PKCS #11 v2.20 amendment 3- CKM_AES_CTR as AesCtr,-- CKM_AES_GCM as AesGcm,--0x00001087- CKM_AES_CCM as AesCcm,--0x00001088- CKM_AES_KEY_WRAP as AesKeyWrap,--0x00001090- CKM_AES_KEY_WRAP_PAD as AesKeyWrapPad,--0x00001091-- -- BlowFish and TwoFish are new for v2.20- CKM_BLOWFISH_KEY_GEN as BlowfishKeyGen,- CKM_BLOWFISH_CBC as BlowfishCbc,- CKM_TWOFISH_KEY_GEN as TwoFishKeyGen,- CKM_TWOFISH_CBC as TwoFishCbc,-- -- CKM_xxx_ENCRYPT_DATA mechanisms are new for v2.20- CKM_DES_ECB_ENCRYPT_DATA as DesEcbEncryptData,- CKM_DES_CBC_ENCRYPT_DATA as DesCbcEncryptData,- CKM_DES3_ECB_ENCRYPT_DATA as Des3EcbEncryptData,- CKM_DES3_CBC_ENCRYPT_DATA as Des3CbcEncryptData,- CKM_AES_ECB_ENCRYPT_DATA as AesEcbEncryptData,- CKM_AES_CBC_ENCRYPT_DATA as AesCbcEncryptData,-- CKM_DSA_PARAMETER_GEN as DsaParameterGen,- CKM_DH_PKCS_PARAMETER_GEN as DhPkcsParameterGen,- CKM_X9_42_DH_PARAMETER_GEN as X9_42DhParameterGen,-- CKM_VENDOR_DEFINED as VendorDefined- } deriving (Eq,Show) #}----- | Initialize a multi-part decryption operation using provided mechanism and key.-decryptInit :: Mech -> Session -> ObjectHandle -> IO ()-decryptInit mech (Session sessionHandle functionListPtr) obj = do- with mech $ \mechPtr -> do- rv <- {#call unsafe CK_FUNCTION_LIST.C_DecryptInit#} functionListPtr sessionHandle mechPtr obj- if rv /= 0- then fail $ "failed to initiate decryption: " ++ (rvToStr rv)- else return ()----- | Decrypt data using provided mechanism and key handle.------ Example AES ECB decryption.------ > decData <- decrypt (simpleMech AesEcb) sess aesKeyHandle encData 1000-decrypt :: Mech -- ^ Mechanism used for decryption.- -> Session -- ^ Session on which key resides.- -> ObjectHandle -- ^ Key handle used for decryption.- -> BS.ByteString -- ^ Encrypted data to be decrypted.- -> CULong -- ^ Maximum number of bytes to be returned.- -> IO BS.ByteString -- ^ Decrypted data-decrypt mech (Session sessionHandle functionListPtr) keyHandle encData outLen = do- decryptInit mech (Session sessionHandle functionListPtr) keyHandle- unsafeUseAsCStringLen encData $ \(encDataPtr, encDataLen) -> do- allocaBytes (fromIntegral outLen) $ \outDataPtr -> do- with outLen $ \outDataLenPtr -> do- rv <- {#call unsafe CK_FUNCTION_LIST.C_Decrypt#} functionListPtr sessionHandle (castPtr encDataPtr) (fromIntegral encDataLen) outDataPtr outDataLenPtr- if rv /= 0- then fail $ "failed to decrypt: " ++ (rvToStr rv)- else do- outDataLen <- peek outDataLenPtr- BS.packCStringLen (castPtr outDataPtr, fromIntegral outDataLen)----- | Initialize multi-part encryption operation.-encryptInit :: Mech -- ^ Mechanism to use for encryption.- -> Session -- ^ Session in which to perform operation.- -> ObjectHandle -- ^ Key handle.- -> IO ()-encryptInit mech (Session sessionHandle functionListPtr) obj = do- with mech $ \mechPtr -> do- rv <- {#call unsafe CK_FUNCTION_LIST.C_EncryptInit#} functionListPtr sessionHandle mechPtr obj- if rv /= 0- then fail $ "failed to initiate decryption: " ++ (rvToStr rv)- else return ()----- | Encrypt data using provided mechanism and key handle.-encrypt :: Mech -- ^ Mechanism to use for encryption.- -> Session -- ^ Session in which to perform operation.- -> ObjectHandle -- ^ Key handle.- -> BS.ByteString -- ^ Data to be encrypted.- -> CULong -- ^ Maximum number of bytes to be returned.- -> IO BS.ByteString -- ^ Encrypted data.-encrypt mech (Session sessionHandle functionListPtr) keyHandle encData outLen = do- encryptInit mech (Session sessionHandle functionListPtr) keyHandle- unsafeUseAsCStringLen encData $ \(encDataPtr, encDataLen) -> do- allocaBytes (fromIntegral outLen) $ \outDataPtr -> do- with outLen $ \outDataLenPtr -> do- rv <- {#call unsafe CK_FUNCTION_LIST.C_Encrypt#} functionListPtr sessionHandle (castPtr encDataPtr) (fromIntegral encDataLen) outDataPtr outDataLenPtr- if rv /= 0- then fail $ "failed to decrypt: " ++ (rvToStr rv)- else do- outDataLen <- peek outDataLenPtr- res <- BS.packCStringLen (castPtr outDataPtr, fromIntegral outDataLen)- return res---{#fun unsafe CK_FUNCTION_LIST.C_EncryptUpdate as encryptUpdate'- {`FunctionListPtr',- `SessionHandle',- unsafeUseAsCUCharPtr* `BS.ByteString',- `CULong',- castPtr `Ptr CUChar',- with* `CULong' peek*} -> `Rv'-#}--encryptUpdate (Session sessHandle funcListPtr) inData outLen = do- allocaBytes (fromIntegral outLen) $ \outPtr -> do- (rv, outResLen) <- encryptUpdate' funcListPtr sessHandle inData (fromIntegral $ BS.length inData) outPtr outLen- if rv /= 0- then fail $ "failed to encrypt part: " ++ (rvToStr rv)- else BS.packCStringLen (castPtr outPtr, fromIntegral outResLen)--{#fun unsafe CK_FUNCTION_LIST.C_EncryptFinal as encryptFinal'- {`FunctionListPtr',- `SessionHandle',- castPtr `Ptr CUChar',- with* `CULong' peek*} -> `Rv'-#}--encryptFinal (Session sessHandle funcListPtr) outLen = do- allocaBytes (fromIntegral outLen) $ \outPtr -> do- (rv, outResLen) <- encryptFinal' funcListPtr sessHandle outPtr outLen- if rv /= 0- then fail $ "failed to complete encryption: " ++ (rvToStr rv)- else BS.packCStringLen (castPtr outPtr, fromIntegral outResLen)---{#fun unsafe CK_FUNCTION_LIST.C_DigestInit as digestInit'- {`FunctionListPtr',- `SessionHandle',- with* `Mech'} -> `Rv'-#}--digestInit :: Mech -> Session -> IO ()-digestInit mech (Session sessHandle funcListPtr) = do- rv <- digestInit' funcListPtr sessHandle mech- if rv /= 0- then fail $ "failed to initialize digest operation: " ++ (rvToStr rv)- else return ()--{#fun unsafe CK_FUNCTION_LIST.C_Digest as digest'- {`FunctionListPtr',- `SessionHandle',- unsafeUseAsCUCharPtr* `BS.ByteString',- `CULong',- castPtr `Ptr CUChar',- with* `CULong' peek*} -> `Rv'-#}---- | Calculates digest aka hash of a data using provided mechanism.------ Example calculating SHA256 hash:------ >>> digest (simpleMech Sha256) sess (replicate 16 0) 1000--- "7G\b\255\247q\157\213\151\158\200u\213l\210(om<\247\236\&1z;%c*\171(\236\&7\187"-digest :: Mech -- ^ Digest mechanism.- -> Session -- ^ Session to be used for digesting.- -> BS.ByteString -- ^ Data to be digested.- -> CULong -- ^ Maximum number of bytes to be returned.- -> IO (BS.ByteString) -- ^ Resulting digest.-digest mech (Session sessHandle funcListPtr) digestData outLen = do- digestInit mech (Session sessHandle funcListPtr)- allocaBytes (fromIntegral outLen) $ \outPtr -> do- (rv, outResLen) <- digest' funcListPtr sessHandle digestData (fromIntegral $ BS.length digestData) outPtr outLen- if rv /= 0- then fail $ "failed to digest: " ++ (rvToStr rv)- else BS.packCStringLen (castPtr outPtr, fromIntegral outResLen)----{#fun unsafe CK_FUNCTION_LIST.C_SignInit as signInit'- {`FunctionListPtr',- `SessionHandle',- with* `Mech',- `ObjectHandle'} -> `Rv'-#}---unsafeUseAsCUCharPtr :: BS.ByteString -> (Ptr CUChar -> IO b) -> IO b-unsafeUseAsCUCharPtr bs fn =- unsafeUseAsCString bs $ \cstrptr -> do- fn (castPtr cstrptr)--{#fun unsafe CK_FUNCTION_LIST.C_Sign as sign'- {`FunctionListPtr',- `SessionHandle',- unsafeUseAsCUCharPtr* `BS.ByteString',- `CULong',- castPtr `Ptr CUChar',- with* `CULong' peek*} -> `Rv'-#}---signInit :: Mech -> Session -> ObjectHandle -> IO ()-signInit mech (Session sessHandle funcListPtr) objHandle = do- rv <- signInit' funcListPtr sessHandle mech objHandle- if rv /= 0- then fail $ "failed to initialize signing operation: " ++ (rvToStr rv)- else return ()---- | Signs data using provided mechanism and key.------ Example signing with RSA PKCS#1------ > signature <- sign (simpleMech RsaPkcs) sess privKeyHandle signedData 1000-sign :: Mech -- ^ Mechanism to use for signing.- -> Session -- ^ Session to work in.- -> ObjectHandle -- ^ Key handle.- -> BS.ByteString -- ^ Data to be signed.- -> CULong -- ^ Maximum number of bytes to be returned.- -> IO (BS.ByteString) -- ^ Signature.-sign mech (Session sessHandle funcListPtr) key signData outLen = do- signInit mech (Session sessHandle funcListPtr) key- with outLen $ \outLenPtr -> do- allocaBytes (fromIntegral outLen) $ \outPtr -> do- (rv, outResLen) <- sign' funcListPtr sessHandle signData (fromIntegral $ BS.length signData) outPtr outLen- if rv /= 0- then fail $ "failed to sign: " ++ (rvToStr rv)- else BS.packCStringLen (castPtr outPtr, fromIntegral outResLen)---{#fun unsafe CK_FUNCTION_LIST.C_SignRecoverInit as signRecoverInit'- {`FunctionListPtr',- `SessionHandle',- with* `Mech',- `ObjectHandle'} -> `Rv'-#}--signRecoverInit :: Mech -> Session -> ObjectHandle -> IO ()-signRecoverInit mech (Session sessHandle funcListPtr) objHandle = do- rv <- signRecoverInit' funcListPtr sessHandle mech objHandle- if rv /= 0- then fail $ "failed to initialize signing with recovery operation: " ++ (rvToStr rv)- else return ()---{#fun unsafe CK_FUNCTION_LIST.C_SignRecover as signRecover'- {`FunctionListPtr',- `SessionHandle',- unsafeUseAsCUCharPtr* `BS.ByteString',- `CULong',- castPtr `Ptr CUChar',- with* `CULong' peek*} -> `Rv'-#}--signRecover (Session sessHandle funcListPtr) signData outLen = do- with outLen $ \outLenPtr -> do- allocaBytes (fromIntegral outLen) $ \outPtr -> do- (rv, outResLen) <- signRecover' funcListPtr sessHandle signData (fromIntegral $ BS.length signData) outPtr outLen- if rv /= 0- then fail $ "failed to sign with recovery: " ++ (rvToStr rv)- else BS.packCStringLen (castPtr outPtr, fromIntegral outResLen)---{#fun unsafe CK_FUNCTION_LIST.C_VerifyInit as verifyInit'- {`FunctionListPtr',- `SessionHandle',- with* `Mech',- `ObjectHandle'} -> `Rv'-#}--{#fun unsafe CK_FUNCTION_LIST.C_Verify as verify'- {`FunctionListPtr',- `SessionHandle',- unsafeUseAsCUCharPtr* `BS.ByteString',- `CULong',- unsafeUseAsCUCharPtr* `BS.ByteString',- `CULong'} -> `Rv'-#}--verifyInit :: Session -> Mech -> ObjectHandle -> IO ()-verifyInit (Session sessHandle funcListPtr) mech objHandle = do- rv <- verifyInit' funcListPtr sessHandle mech objHandle- if rv /= 0- then fail $ "failed to initialize verify operation: " ++ (rvToStr rv)- else return ()---- | Verifies signature using provided mechanism and key.------ Example signature verification using RSA public key:------ >>> verify (simpleMech RsaPkcs) sess pubKeyHandle signedData signature--- True-verify :: Mech -- ^ Mechanism to be used for signature validation.- -> Session -- ^ Session to be used.- -> ObjectHandle -- ^ Key handle.- -> BS.ByteString -- ^ Signed data.- -> BS.ByteString -- ^ Signature.- -> IO (Bool) -- ^ True is signature is valid, False otherwise.-verify mech (Session sessHandle funcListPtr) keyHandle signData signatureData = do- verifyInit (Session sessHandle funcListPtr) mech keyHandle- rv <- verify' funcListPtr sessHandle signData (fromIntegral $ BS.length signData) signatureData (fromIntegral $ BS.length signatureData)- case rv of 0 -> return True- {#const CKR_SIGNATURE_INVALID#} -> return False- _ -> fail $ "failed to verify: " ++ (rvToStr rv)---{#fun unsafe CK_FUNCTION_LIST.C_WrapKey as wrapKey'- {`FunctionListPtr',- `SessionHandle',- with* `Mech',- `ObjectHandle',- `ObjectHandle',- castPtr `Ptr CUChar',- with* `CULong' peek*} -> `Rv'-#}---- | Wrap a key using provided wrapping key and return opaque byte array representing wrapped key. This byte array--- can be stored in user application and can be used later to recreate wrapped key using 'unwrapKey' function.------ Example wrapping AES key using RSA public key:------ > wrappedAesKey <- wrapKey (simpleMech RsaPkcs) sess pubRsaKeyHandle aesKeyHandle 300-wrapKey :: Mech -- ^ Mechanism used to wrap key (to encrypt)- -> Session -- ^ Session in which both keys reside.- -> ObjectHandle -- ^ Key which will be used to wrap (encrypt) another key- -> ObjectHandle -- ^ Key to be wrapped- -> CULong -- ^ Maximum size in bytes of a resulting byte array- -> IO BS.ByteString -- ^ Resulting opaque wrapped key-wrapKey mech (Session sessHandle funcListPtr) wrappingKey key dataLen = do- allocaBytes (fromIntegral dataLen) $ \dataPtr -> do- (rv, outDataLen) <- wrapKey' funcListPtr sessHandle mech wrappingKey key dataPtr dataLen- if rv /= 0- then fail $ "failed to wrap key: " ++ (rvToStr rv)- else BS.packCStringLen (castPtr dataPtr, fromIntegral outDataLen)----- | Unwrap a key from opaque byte string and apply attributes to a resulting key object.------ Example unwrapping AES key using RSA private key:------ > unwrappedAesKey <- unwrapKey (simpleMech RsaPkcs) sess privRsaKeyHandle wrappedAesKey [Class SecretKey, KeyType AES]-unwrapKey :: Mech -- ^ Mechanism to use for unwrapping (decryption).- -> Session -- ^ Session in which to perform operation.- -> ObjectHandle -- ^ Handle to a key which will be used to unwrap (decrypt) key.- -> BS.ByteString -- ^ Key to be unwrapped.- -> [Attribute] -- ^ Attributes applied to unwrapped key object.- -> IO ObjectHandle -- ^ Unwrapped key handle.-unwrapKey mech (Session sessionHandle functionListPtr) key wrappedKey template = do- _withAttribs template $ \attribsPtr -> do- with mech $ \mechPtr -> do- unsafeUseAsCStringLen wrappedKey $ \(wrappedKeyPtr, wrappedKeyLen) -> do- alloca $ \unwrappedKeyPtr -> do- rv <- {#call unsafe CK_FUNCTION_LIST.C_UnwrapKey#} functionListPtr sessionHandle mechPtr key (castPtr wrappedKeyPtr) (fromIntegral wrappedKeyLen) attribsPtr (fromIntegral $ length template) unwrappedKeyPtr- if rv /= 0- then fail $ "failed to unwrap key: " ++ (rvToStr rv)- else do- unwrappedKey <- peek unwrappedKeyPtr- return unwrappedKey---{#fun unsafe CK_FUNCTION_LIST.C_SeedRandom as seedRandom'- {`FunctionListPtr',- `SessionHandle',- unsafeUseAsCUCharPtr* `BS.ByteString',- `CULong'} -> `Rv'-#}---- | Mixes provided seed data with token's seed-seedRandom (Session sessHandle funcListPtr) seedData = do- rv <- seedRandom' funcListPtr sessHandle seedData (fromIntegral $ BS.length seedData)- if rv /= 0- then fail $ "failed to seed random: " ++ (rvToStr rv)- else return ()---{#fun unsafe CK_FUNCTION_LIST.C_GenerateRandom as generateRandom'- {`FunctionListPtr',- `SessionHandle',- castPtr `Ptr CUChar',- `CULong'} -> `Rv'-#}---- | Generates random data using token's RNG.-generateRandom :: Session -- ^ Session to work on.- -> CULong -- ^ Number of bytes to generate.- -> IO BS.ByteString -- ^ Generated random bytes.-generateRandom (Session sessHandle funcListPtr) randLen = do- allocaBytes (fromIntegral randLen) $ \randPtr -> do- rv <- generateRandom' funcListPtr sessHandle randPtr randLen- if rv /= 0- then fail $ "failed to generate random data: " ++ (rvToStr rv)- else BS.packCStringLen (castPtr randPtr, fromIntegral randLen)----- | Obtains a list of mechanism types supported by a token-getMechanismList :: Library -> SlotId -> Int -> IO [Int]-getMechanismList (Library _ functionListPtr) slotId maxMechanisms = do- (rv, types) <- _getMechanismList functionListPtr slotId maxMechanisms- if rv /= 0- then fail $ "failed to get list of mechanisms: " ++ (rvToStr rv)- else return $ map (fromIntegral) types----- | Obtains information about a particular mechanism possibly supported by a token-getMechanismInfo :: Library -> SlotId -> MechType -> IO MechInfo-getMechanismInfo (Library _ functionListPtr) slotId mechId = do- (rv, types) <- _getMechanismInfo functionListPtr slotId (fromEnum mechId)- if rv /= 0- then fail $ "failed to get mechanism information: " ++ (rvToStr rv)- else return types
+ src/System/Crypto/Pkcs11.hs view
@@ -0,0 +1,763 @@+-- | This is the main module that contains bindings for PKCS#11 interface.+module System.Crypto.Pkcs11+ -- * Library+ ( Library+ , loadLibrary+ , releaseLibrary+ -- ** Reading library information+ , getInfo+ , LibraryInfo+ , infoCryptokiVersion+ , infoManufacturerId+ , infoFlags+ , infoLibraryDescription+ , infoLibraryVersion+ , Version+ , versionMajor+ , versionMinor+ -- * Slots+ , SlotId+ , getSlotNum+ , getSlotList+ -- ** Reading slot information+ , getSlotInfo+ , SlotInfo+ , slotInfoDescription+ , slotInfoManufacturerId+ , slotInfoFlags+ , slotInfoHardwareVersion+ , slotInfoFirmwareVersion+ -- ** Working with tokens+ , TokenInfo+ , getTokenInfo+ , tokenInfoLabel+ , tokenInfoManufacturerId+ , tokenInfoModel+ , tokenInfoSerialNumber+ , tokenInfoFlags+ , initToken+ , initPin+ , setPin+ -- * Mechanisms+ , getMechanismList+ , getMechanismInfo+ , MechType(..)+ , MechInfo+ , mechInfoMinKeySize+ , mechInfoMaxKeySize+ , mechInfoFlags+ , Mech+ , simpleMech+ -- * Session management+ , Session+ , withSession+ , login+ , UserType(..)+ , logout+ , closeAllSessions+ , getSessionInfo+ , SessionInfo+ , sessionInfoSlotId+ , sessionInfoState+ , sessionInfoFlags+ , sessionInfoDeviceError+ , SessionState(..)+ , getOperationState+ -- * Object attributes+ , Object+ , Attribute(..)+ , ClassType(..)+ , KeyTypeValue(..)+ , destroyObject+ , createObject+ , copyObject+ , getObjectSize+ -- ** Searching objects+ , findObjects+ -- ** Reading object attributes+ , getTokenFlag+ , getPrivateFlag+ , getSensitiveFlag+ , getEncryptFlag+ , getDecryptFlag+ , getWrapFlag+ , getUnwrapFlag+ , getSignFlag+ , getModulus+ , getPublicExponent+ , getPrime+ , getBase+ , getEcdsaParams+ , getEcPoint+ -- ** Writing attributes+ , setAttributes+ -- * Key generation+ , generateKey+ , generateKeyPair+ , deriveKey+ -- * Key wrapping/unwrapping+ , wrapKey+ , unwrapKey+ -- * Encryption/decryption+ , decrypt+ , encrypt+ -- ** Multipart operations+ , decryptInit+ , encryptInit+ , encryptUpdate+ , encryptFinal+ -- * Digest+ , digest+ , digestInit+ -- * Signing+ , sign+ , verify+ , signRecover+ , signInit+ , verifyInit+ , signRecoverInit+ -- * Random+ , seedRandom+ , generateRandom+ ) where++import Bindings.Pkcs11+import Control.Exception+import Control.Monad+import Data.Bits+import qualified Data.ByteString as BS+import qualified Data.ByteString.UTF8 as BU8+import Data.ByteString.Unsafe+import Foreign.C.Types+import Foreign.Marshal.Alloc+import Foreign.Marshal.Array+import Foreign.Marshal.Utils+import Foreign.Ptr+import Foreign.Storable+import System.Posix.DynamicLinker++-- | Represents a PKCS#11 library.+data Library = Library+ { libraryHandle :: DL+ , functionListPtr :: FunctionListPtr+ }++data Object =+ Object FunctionListPtr+ SessionHandle+ ObjectHandle+ deriving (Show)++-- | Return parameterless mechanism which can be used in cryptographic operation.+simpleMech :: MechType -> Mech+simpleMech mechType = Mech mechType nullPtr 0++getFunctionList :: GetFunctionListFunPtr -> IO (Rv, FunctionListPtr)+getFunctionList getFunctionListPtr =+ alloca $ \funcListPtrPtr -> do+ res <- getFunctionList'_ getFunctionListPtr funcListPtrPtr+ funcListPtr <- peek funcListPtrPtr+ return (fromIntegral res, funcListPtr)++-- | Return number of slots in the system.+getSlotNum ::+ Library -- ^ Library to be used for operation.+ -> Bool -- ^ If True will return only slots with tokens in them.+ -> IO CULong -- ^ Number of slots.+getSlotNum (Library _ functionListPtr) active = do+ (rv, outNum) <- getSlotList' functionListPtr active nullPtr 0+ if rv /= 0+ then fail $ "failed to get number of slots " ++ rvToStr rv+ else return outNum++-- | Get a list of slot IDs in the system. Can filter for slots with attached tokens.+--+-- > slotsIds <- getSlotList lib True 10+--+-- In this example retrieves list of, at most 10 (third parameter) slot identifiers with tokens present (second parameter is set to True)+getSlotList ::+ Library -- ^ Library to be used for operation.+ -> Bool -- ^ If True will return only slots with tokens in them.+ -> Int -- ^ Maximum number of slot IDs to be returned.+ -> IO [SlotId]+getSlotList (Library _ functionListPtr) active num =+ allocaArray num $ \array -> do+ (rv, outNum) <- getSlotList' functionListPtr active array (fromIntegral num)+ if rv /= 0+ then fail $ "failed to get list of slots " ++ rvToStr rv+ else peekArray (fromIntegral outNum) array++getSessionInfo (Session sessHandle funListPtr) = do+ (rv, sessInfo) <- getSessionInfo' funListPtr sessHandle+ if rv /= 0+ then fail $ "failed to get session info: " ++ rvToStr rv+ else return sessInfo++closeAllSessions (Library _ funcListPtr) slotId = do+ rv <- closeAllSessions' funcListPtr slotId+ when (rv /= 0) $ fail $ "failed to close sessions: " ++ rvToStr rv++getOperationState (Session sessHandle funcListPtr) maxSize =+ allocaBytes (fromIntegral maxSize) $ \bytesPtr -> do+ (rv, resSize) <- getOperationState' funcListPtr sessHandle bytesPtr maxSize+ if rv /= 0+ then fail $ "failed to get operation state: " ++ rvToStr rv+ else BS.packCStringLen (castPtr bytesPtr, fromIntegral resSize)++-- | Deletes an object from token or session.+destroyObject (Object funcListPtr sessHandle objectHandle) = do+ rv <- destroyObject' funcListPtr sessHandle objectHandle+ when (rv /= 0) $ fail $ "failed to destroy object: " ++ rvToStr rv++-- | Generates a symmetric key using provided mechanism and applies provided attributes to resulting key object.+--+-- Examples:+--+-- Generate 128-bit AES key:+--+-- > keyHandle <- generateKey sess (simpleMech AesKeyGen) [ValueLen 16]+--+-- Generate 1024-bit Diffie-Hellman domain parameters using PKCS#3 mechanism:+--+-- > dhParamsHandle <- generateKey sess (simpleMech DhPkcsParameterGen) [PrimeBits 1028]+generateKey :: Mech -> [Attribute] -> Session -> IO Object+generateKey mech attribs (Session sessHandle funcListPtr) =+ _withAttribs attribs $ \attrPtr -> do+ (rv, keyHandle) <- generateKey' funcListPtr sessHandle mech attrPtr (fromIntegral $ length attribs)+ if rv /= 0+ then fail $ "failed to generate key: " ++ rvToStr rv+ else return $ Object funcListPtr sessHandle keyHandle++-- | Represent session. Created by 'withSession' function.+data Session =+ Session SessionHandle+ FunctionListPtr++-- | Load PKCS#11 dynamically linked library from given path+--+-- > lib <- loadLibrary "/path/to/dll.so"+loadLibrary :: String -> IO Library+loadLibrary libraryPath = do+ lib <- dlopen libraryPath []+ getFunctionListFunPtr <- dlsym lib "C_GetFunctionList"+ (rv, functionListPtr) <- getFunctionList getFunctionListFunPtr+ if rv /= 0+ then fail $ "failed to get list of functions " ++ rvToStr rv+ else do+ rv <- initialize functionListPtr+ if rv /= 0+ then fail $ "failed to initialize library " ++ rvToStr rv+ else return Library {libraryHandle = lib, functionListPtr = functionListPtr}++-- | Releases resources used by loaded library+releaseLibrary lib = do+ rv <- finalize $ functionListPtr lib+ dlclose $ libraryHandle lib++-- | Get general information about Cryptoki library+getInfo :: Library -> IO LibraryInfo+getInfo (Library _ functionListPtr) = do+ (rv, info) <- getInfo' functionListPtr+ if rv /= 0+ then fail $ "failed to get library information " ++ rvToStr rv+ else return info++_openSessionEx :: Library -> SlotId -> Int -> IO Session+_openSessionEx (Library _ functionListPtr) slotId flags = do+ (rv, sessionHandle) <- openSession' functionListPtr slotId flags+ if rv /= 0+ then fail $ "failed to open slot: " ++ rvToStr rv+ else return $ Session sessionHandle functionListPtr++_closeSessionEx :: Session -> IO ()+_closeSessionEx (Session sessionHandle functionListPtr) = do+ rv <- closeSession' functionListPtr sessionHandle+ when (rv /= 0) $ fail $ "failed to close slot: " ++ rvToStr rv++-- | Opens a read-only or read-write session with a token in a given slot and then closes it after callback function is finished.+withSession ::+ Library -- ^ Library to use.+ -> SlotId -- ^ Slot ID for which to open session.+ -> Bool -- ^ If True will open writable session, otherwise will open read-only session.+ -> (Session -> IO a) -- ^ Callback function which is executed while session is open.+ -> IO a -- ^ Returns a result of callback function.+withSession lib slotId writable f = do+ let flags =+ if writable+ then _rwSession+ else 0+ bracket (_openSessionEx lib slotId (flags .|. _serialSession)) _closeSessionEx f++_findObjectsInit :: Session -> [Attribute] -> IO ()+_findObjectsInit (Session sessionHandle functionListPtr) attribs =+ _withAttribs attribs $ \attribsPtr -> do+ rv <- findObjectsInit' functionListPtr sessionHandle attribsPtr (fromIntegral $ length attribs)+ when (rv /= 0) $ fail $ "failed to initialize search: " ++ rvToStr rv++_findObjectsEx :: Session -> IO [Object]+_findObjectsEx (Session sessionHandle functionListPtr) = do+ (rv, objectsHandles) <- findObjects' functionListPtr sessionHandle 10+ if rv /= 0+ then fail $ "failed to execute search: " ++ rvToStr rv+ else return $ map (Object functionListPtr sessionHandle) objectsHandles++_findObjectsFinalEx :: Session -> IO ()+_findObjectsFinalEx (Session sessionHandle functionListPtr) = do+ rv <- findObjectsFinal' functionListPtr sessionHandle+ when (rv /= 0) $ fail $ "failed to finalize search: " ++ rvToStr rv++-- | Searches current session for objects matching provided attributes list, returns a list of matching object handles+findObjects :: Session -> [Attribute] -> IO [Object]+findObjects session attribs = do+ _findObjectsInit session attribs+ finally (_findObjectsEx session) (_findObjectsFinalEx session)++-- | Generates an asymmetric key pair using provided mechanism.+--+-- Examples:+--+-- Generate an 2048-bit RSA key:+--+-- > (pubKey, privKey) <- generateKeyPair sess (simpleMech RsaPkcsKeyPairGen) [ModulusBits 2048] []+generateKeyPair ::+ Mech -- ^ a mechanism to use for key generation, for example 'simpleMech RsaPkcs'+ -> [Attribute] -- ^ attributes applied to generated public key object+ -> [Attribute] -- ^ attributes applied to generated private key object+ -> Session -- ^ session in which to generate key+ -> IO (Object, Object) -- ^ created objects references, first is public key, second is private key+generateKeyPair mech pubKeyAttrs privKeyAttrs (Session sessionHandle functionListPtr) = do+ (rv, pubKeyHandle, privKeyHandle) <- _generateKeyPair functionListPtr sessionHandle mech pubKeyAttrs privKeyAttrs+ if rv /= 0+ then fail $ "failed to generate key pair: " ++ rvToStr rv+ else return (Object functionListPtr sessionHandle pubKeyHandle, Object functionListPtr sessionHandle privKeyHandle)++-- | Initialize a token in a given slot. All objects created by user on the token are destroyed.+initToken ::+ Library -- ^ PKCS#11 library+ -> SlotId -- ^ slot id in which to initialize token+ -> BU8.ByteString -- ^ token's security officer password+ -> String -- ^ new label for the token+ -> IO ()+initToken (Library _ funcListPtr) slotId pin label = do+ rv <- initToken' funcListPtr slotId pin label+ when (rv /= 0) $ fail $ "failed to initialize token " ++ rvToStr rv++-- | Obtains information about a particular slot in the system+--+-- > slotInfo <- getSlotInfo lib slotId+getSlotInfo :: Library -> SlotId -> IO SlotInfo+getSlotInfo (Library _ functionListPtr) slotId = do+ (rv, slotInfo) <- getSlotInfo' functionListPtr slotId+ if rv /= 0+ then fail $ "failed to get slot information " ++ rvToStr rv+ else return slotInfo++-- | Obtains information about a particular token in the system+--+-- > tokenInfo <- getTokenInfo lib slotId+getTokenInfo :: Library -> SlotId -> IO TokenInfo+getTokenInfo (Library _ functionListPtr) slotId = do+ (rv, slotInfo) <- getTokenInfo' functionListPtr slotId+ if rv /= 0+ then fail $ "failed to get token information " ++ rvToStr rv+ else return slotInfo++-- | Derives a key from a base key using provided mechanism and applies provided attributes to a resulting key.+-- Can be used to derive symmetric key using Diffie-Hellman key exchange.+deriveKey (Session sessHandle funcListPtr) mech baseKeyHandle attribs =+ _withAttribs attribs $ \attribsPtr -> do+ (rv, createdHandle) <-+ deriveKey' funcListPtr sessHandle mech baseKeyHandle attribsPtr (fromIntegral $ length attribs)+ if rv /= 0+ then fail $ "failed to derive key: " ++ rvToStr rv+ else return createdHandle++-- | Creates an object from given list of attributes and returns a reference to created object.+createObject (Session sessHandle funcListPtr) attribs =+ _withAttribs attribs $ \attribsPtr -> do+ (rv, createdHandle) <- createObject' funcListPtr sessHandle attribsPtr (fromIntegral $ length attribs)+ if rv /= 0+ then fail $ "failed to create object: " ++ rvToStr rv+ else return createdHandle++-- | Makes a copy of an object and changes attributes of copied object, returns a reference to new object.+copyObject (Object funcListPtr sessHandle objHandle) attribs =+ _withAttribs attribs $ \attribsPtr -> do+ (rv, createdHandle) <- copyObject' funcListPtr sessHandle objHandle attribsPtr (fromIntegral $ length attribs)+ if rv /= 0+ then fail $ "failed to copy object: " ++ rvToStr rv+ else return createdHandle++-- | Returns an approximate amount of space occupied by an object in bytes.+getObjectSize (Object funcListPtr sessHandle objHandle) = do+ (rv, objSize) <- getObjectSize' funcListPtr sessHandle objHandle+ if rv /= 0+ then fail $ "failed to get object size: " ++ rvToStr rv+ else return objSize++getBoolAttr :: AttributeType -> Object -> IO Bool+getBoolAttr attrType (Object funcListPtr sessHandle objHandle) =+ alloca $ \valuePtr -> do+ _getAttr funcListPtr sessHandle objHandle attrType (valuePtr :: Ptr CK_BBOOL)+ val <- peek valuePtr+ return $ toBool val++getTokenFlag = getBoolAttr TokenType++getPrivateFlag = getBoolAttr PrivateType++getSensitiveFlag = getBoolAttr SensitiveType++getEncryptFlag = getBoolAttr EncryptType++getDecryptFlag = getBoolAttr DecryptType++getWrapFlag = getBoolAttr WrapType++getUnwrapFlag = getBoolAttr UnwrapType++getSignFlag = getBoolAttr SignType++getModulus :: Object -> IO Integer+getModulus (Object funcListPtr sessHandle objHandle) = do+ (Modulus m) <- getObjectAttr' funcListPtr sessHandle objHandle ModulusType+ return m++getPublicExponent :: Object -> IO Integer+getPublicExponent (Object funcListPtr sessHandle objHandle) = do+ (PublicExponent v) <- getObjectAttr' funcListPtr sessHandle objHandle PublicExponentType+ return v++getPrime (Object funcListPtr sessHandle objHandle) = do+ (Prime p) <- getObjectAttr' funcListPtr sessHandle objHandle PrimeType+ return p++getBase (Object funcListPtr sessHandle objHandle) = do+ (Base p) <- getObjectAttr' funcListPtr sessHandle objHandle BaseType+ return p++getEcdsaParams (Object funcListPtr sessHandle objHandle) = do+ (EcdsaParams bs) <- getObjectAttr' funcListPtr sessHandle objHandle EcParamsType+ return bs++getEcPoint (Object funcListPtr sessHandle objHandle) = do+ (EcPoint bs) <- getObjectAttr' funcListPtr sessHandle objHandle EcPointType+ return bs++-- | Modifies attributes of an object.+setAttributes (Object funcListPtr sessHandle objHandle) attribs =+ _withAttribs attribs $ \attribsPtr -> do+ rv <- setAttributeValue' funcListPtr sessHandle objHandle attribsPtr (fromIntegral $ length attribs)+ when (rv /= 0) $ fail $ "failed to set attributes: " ++ rvToStr rv++-- | Initializes normal user's PIN. Session should be logged in by SO user in other words it should be in+-- 'RWSOFunctions' state.+initPin :: Session -> BU8.ByteString -> IO ()+initPin (Session sessHandle funcListPtr) pin = do+ rv <- initPin' funcListPtr sessHandle pin+ when (rv /= 0) $ fail $ "initPin failed: " ++ rvToStr rv++-- | Changes PIN of a currently logged in user.+setPin ::+ Session -- ^ session to act on+ -> BU8.ByteString -- ^ old PIN+ -> BU8.ByteString -- ^ new PIN+ -> IO ()+setPin (Session sessHandle funcListPtr) oldPin newPin = do+ rv <- setPin' funcListPtr sessHandle oldPin newPin+ when (rv /= 0) $ fail $ "setPin failed: " ++ rvToStr rv++-- | Logs a user into a token.+login ::+ Session -- ^ session to act on+ -> UserType -- ^ type of user to login+ -> BU8.ByteString -- ^ user's PIN+ -> IO ()+login (Session sessionHandle functionListPtr) userType pin = do+ rv <- _login functionListPtr sessionHandle userType pin+ when (rv /= 0) $ fail $ "login failed: " ++ rvToStr rv++-- | Logs a user out from a token.+logout :: Session -> IO ()+logout (Session sessionHandle functionListPtr) = do+ rv <- logout' functionListPtr sessionHandle+ when (rv /= 0) $ fail $ "logout failed: " ++ rvToStr rv++-- | Initialize a multi-part decryption operation using provided mechanism and key.+decryptInit :: Mech -> Object -> IO ()+decryptInit mech (Object funcListPtr sessionHandle objHandle) = do+ rv <- decryptInit' funcListPtr sessionHandle mech objHandle+ when (rv /= 0) $ fail $ "failed to initiate decryption: " ++ rvToStr rv++varLenGet :: Maybe CULong -> ((Ptr CUChar, CULong) -> IO (Rv, CULong)) -> IO (Rv, BS.ByteString)+varLenGet Nothing func = do+ (rv, needLen) <- func (nullPtr, 0)+ if rv /= 0+ then fail $ "failed to query resulting size for operation" ++ rvToStr rv+ else allocaBytes (fromIntegral needLen) $ \outDataPtr -> do+ (rv, actualLen) <- func (outDataPtr, needLen)+ if rv == errBufferTooSmall+ then fail "function returned CKR_BUFFER_TOO_SMALL when it shoudln't"+ else if rv /= 0+ then return (rv, BS.empty)+ else do+ resBs <- BS.packCStringLen (castPtr outDataPtr, fromIntegral actualLen)+ return (rv, resBs)+varLenGet (Just len) func =+ allocaBytes (fromIntegral len) $ \outDataPtr -> do+ (rv, actualLen) <- func (outDataPtr, len)+ if rv /= 0+ then return (rv, BS.empty)+ else do+ resBs <- BS.packCStringLen (castPtr outDataPtr, fromIntegral actualLen)+ return (rv, resBs)++-- | Decrypt data using provided mechanism and key handle.+--+-- Example AES ECB decryption.+--+-- > decData <- decrypt (simpleMech AesEcb) sess aesKeyHandle encData Nothing+decrypt ::+ Mech -- ^ Mechanism used for decryption.+ -> Object -- ^ Key object used for decryption.+ -> BS.ByteString -- ^ Encrypted data to be decrypted.+ -> Maybe CULong -- ^ Maximum number of bytes to be returned.+ -> IO BS.ByteString -- ^ Decrypted data+decrypt mech (Object functionListPtr sessionHandle keyHandle) encData maybeOutLen = do+ decryptInit mech (Object functionListPtr sessionHandle keyHandle)+ unsafeUseAsCStringLen encData $ \(encDataPtr, encDataLen) -> do+ (rv, bs) <-+ varLenGet maybeOutLen $ \(ptr, len) ->+ decrypt' functionListPtr sessionHandle (castPtr encDataPtr) (fromIntegral encDataLen) (castPtr ptr) len+ if rv /= 0+ then fail $ "failed to decrypt: " ++ rvToStr rv+ else return bs++-- | Initialize multi-part encryption operation.+encryptInit ::+ Mech -- ^ Mechanism to use for encryption.+ -> Object -- ^ Encryption key.+ -> IO ()+encryptInit mech (Object functionListPtr sessionHandle obj) = do+ rv <- encryptInit' functionListPtr sessionHandle mech obj+ when (rv /= 0) $ fail $ "failed to initiate decryption: " ++ rvToStr rv++-- | Encrypt data using provided mechanism and key handle.+encrypt ::+ Mech -- ^ Mechanism to use for encryption.+ -> Object -- ^ Encryption key.+ -> BS.ByteString -- ^ Data to be encrypted.+ -> Maybe CULong -- ^ Maximum number of bytes to be returned.+ -> IO BS.ByteString -- ^ Encrypted data.+encrypt mech (Object functionListPtr sessionHandle keyHandle) encData maybeOutLen = do+ encryptInit mech (Object functionListPtr sessionHandle keyHandle)+ unsafeUseAsCStringLen encData $ \(encDataPtr, encDataLen) -> do+ (rv, bs) <-+ varLenGet maybeOutLen $+ uncurry (encrypt' functionListPtr sessionHandle (castPtr encDataPtr) (fromIntegral encDataLen))+ if rv /= 0+ then fail $ "failed to decrypt: " ++ rvToStr rv+ else return bs++encryptUpdate (Session sessHandle funcListPtr) inData maybeOutLen =+ unsafeUseAsCStringLen inData $ \(inDataPtr, inDataLen) -> do+ (rv, bs) <-+ varLenGet maybeOutLen $+ uncurry (encryptUpdate' funcListPtr sessHandle (castPtr inDataPtr) (fromIntegral inDataLen))+ if rv /= 0+ then fail $ "failed to encrypt part: " ++ rvToStr rv+ else return bs++encryptFinal (Session sessHandle funcListPtr) maybeOutLen = do+ (rv, bs) <- varLenGet maybeOutLen $ uncurry (encryptFinal' funcListPtr sessHandle)+ if rv /= 0+ then fail $ "failed to complete encryption: " ++ rvToStr rv+ else return bs++digestInit :: Mech -> Session -> IO ()+digestInit mech (Session sessHandle funcListPtr) = do+ rv <- digestInit' funcListPtr sessHandle mech+ when (rv /= 0) $ fail $ "failed to initialize digest operation: " ++ rvToStr rv++-- | Calculates digest aka hash of a data using provided mechanism.+--+-- Example calculating SHA256 hash:+--+-- >>> digest (simpleMech Sha256) sess (replicate 16 0) Nothing+-- "7G\b\255\247q\157\213\151\158\200u\213l\210(om<\247\236\&1z;%c*\171(\236\&7\187"+digest ::+ Mech -- ^ Digest mechanism.+ -> Session -- ^ Session to be used for digesting.+ -> BS.ByteString -- ^ Data to be digested.+ -> Maybe CULong -- ^ Maximum number of bytes to be returned.+ -> IO BS.ByteString -- ^ Resulting digest.+digest mech (Session sessHandle funcListPtr) digestData maybeOutLen = do+ digestInit mech (Session sessHandle funcListPtr)+ unsafeUseAsCStringLen digestData $ \(digestDataPtr, digestDataLen) -> do+ (rv, bs) <-+ varLenGet maybeOutLen $+ uncurry (digest' funcListPtr sessHandle (castPtr digestDataPtr) (fromIntegral digestDataLen))+ if rv /= 0+ then fail $ "failed to digest: " ++ rvToStr rv+ else return bs++signInit :: Mech -> Object -> IO ()+signInit mech (Object funcListPtr sessHandle objHandle) = do+ rv <- signInit' funcListPtr sessHandle mech objHandle+ when (rv /= 0) $ fail $ "failed to initialize signing operation: " ++ rvToStr rv++-- | Signs data using provided mechanism and key.+--+-- Example signing with RSA PKCS#1+--+-- > signature <- sign (simpleMech RsaPkcs) sess privKeyHandle signedData Nothing+sign ::+ Mech -- ^ Mechanism to use for signing.+ -> Object -- ^ Signing key (usually private key).+ -> BS.ByteString -- ^ Data to be signed.+ -> Maybe CULong -- ^ Maximum number of bytes to be returned.+ -> IO BS.ByteString -- ^ Signature.+sign mech (Object funcListPtr sessHandle key) signData maybeOutLen = do+ signInit mech (Object funcListPtr sessHandle key)+ unsafeUseAsCStringLen signData $ \(signDataPtr, signDataLen) -> do+ (rv, bs) <-+ varLenGet maybeOutLen $ uncurry (sign' funcListPtr sessHandle (castPtr signDataPtr) (fromIntegral signDataLen))+ if rv /= 0+ then fail $ "failed to sign: " ++ rvToStr rv+ else return bs++signRecoverInit :: Mech -> Object -> IO ()+signRecoverInit mech (Object funcListPtr sessHandle objHandle) = do+ rv <- signRecoverInit' funcListPtr sessHandle mech objHandle+ when (rv /= 0) $ fail $ "failed to initialize signing with recovery operation: " ++ rvToStr rv++signRecover (Session sessHandle funcListPtr) signData maybeOutLen =+ unsafeUseAsCStringLen signData $ \(signDataPtr, signDataLen) -> do+ (rv, bs) <-+ varLenGet maybeOutLen $+ uncurry (signRecover' funcListPtr sessHandle (castPtr signDataPtr) (fromIntegral signDataLen))+ if rv /= 0+ then fail $ "failed to sign with recovery: " ++ rvToStr rv+ else return bs++verifyInit :: Mech -> Object -> IO ()+verifyInit mech (Object funcListPtr sessHandle objHandle) = do+ rv <- verifyInit' funcListPtr sessHandle mech objHandle+ when (rv /= 0) $ fail $ "failed to initialize verify operation: " ++ rvToStr rv++-- | Verifies signature using provided mechanism and key.+--+-- Example signature verification using RSA public key:+--+-- >>> verify (simpleMech RsaPkcs) sess pubKeyHandle signedData signature+-- True+verify ::+ Mech -- ^ Mechanism to be used for signature validation.+ -> Object -- ^ Verification key (usually public key).+ -> BS.ByteString -- ^ Signed data.+ -> BS.ByteString -- ^ Signature.+ -> IO Bool -- ^ True is signature is valid, False otherwise.+verify mech (Object funcListPtr sessHandle keyHandle) signData signatureData = do+ verifyInit mech (Object funcListPtr sessHandle keyHandle)+ unsafeUseAsCStringLen signData $ \(signDataPtr, signDataLen) ->+ unsafeUseAsCStringLen signatureData $ \(signatureDataPtr, signatureDataLen) -> do+ rv <-+ verify'+ funcListPtr+ sessHandle+ (castPtr signDataPtr)+ (fromIntegral signDataLen)+ (castPtr signatureDataPtr)+ (fromIntegral signatureDataLen)+ if rv == 0+ then return True+ else if rv == errSignatureInvalid+ then return False+ else fail $ "failed to verify: " ++ rvToStr rv++-- | Wrap a key using provided wrapping key and return opaque byte array representing wrapped key. This byte array+-- can be stored in user application and can be used later to recreate wrapped key using 'unwrapKey' function.+--+-- Example wrapping AES key using RSA public key:+--+-- > wrappedAesKey <- wrapKey (simpleMech RsaPkcs) sess pubRsaKeyHandle aesKeyHandle Nothing+wrapKey ::+ Mech -- ^ Mechanism used to wrap key (to encrypt)+ -> Object -- ^ Key which will be used to wrap (encrypt) another key+ -> Object -- ^ Key to be wrapped+ -> Maybe CULong -- ^ Maximum size in bytes of a resulting byte array+ -> IO BS.ByteString -- ^ Resulting opaque wrapped key+wrapKey mech (Object funcListPtr sessHandle wrappingKey) (Object _ _ key) maybeOutLen = do+ (rv, bs) <- varLenGet maybeOutLen $ uncurry (wrapKey' funcListPtr sessHandle mech wrappingKey key)+ if rv /= 0+ then fail $ "failed to wrap key: " ++ rvToStr rv+ else return bs++-- | Unwrap a key from opaque byte string and apply attributes to a resulting key object.+--+-- Example unwrapping AES key using RSA private key:+--+-- > unwrappedAesKey <- unwrapKey (simpleMech RsaPkcs) sess privRsaKeyHandle wrappedAesKey [Class SecretKey, KeyType AES]+unwrapKey ::+ Mech -- ^ Mechanism to use for unwrapping (decryption).+ -> Object -- ^ Handle to a key which will be used to unwrap (decrypt) key.+ -> BS.ByteString -- ^ Key to be unwrapped.+ -> [Attribute] -- ^ Attributes applied to unwrapped key object.+ -> IO Object -- ^ Unwrapped key handle.+unwrapKey mech (Object functionListPtr sessionHandle key) wrappedKey template =+ _withAttribs template $ \attribsPtr ->+ unsafeUseAsCStringLen wrappedKey $ \(wrappedKeyPtr, wrappedKeyLen) -> do+ (rv, unwrappedKey) <-+ unwrapKey'+ functionListPtr+ sessionHandle+ mech+ key+ (castPtr wrappedKeyPtr)+ (fromIntegral wrappedKeyLen)+ attribsPtr+ (fromIntegral $ length template)+ if rv /= 0+ then fail $ "failed to unwrap key: " ++ rvToStr rv+ else return $ Object functionListPtr sessionHandle unwrappedKey++-- | Mixes provided seed data with token's seed+seedRandom ::+ Session -- ^ Session to use+ -> BS.ByteString -- ^ Seed data to be added to RNG's seed+ -> IO ()+seedRandom (Session sessHandle funcListPtr) seedData =+ unsafeUseAsCStringLen seedData $ \(seedDataPtr, seedDataLen) -> do+ rv <- seedRandom' funcListPtr sessHandle (castPtr seedDataPtr) (fromIntegral seedDataLen)+ when (rv /= 0) $ fail $ "failed to seed random: " ++ rvToStr rv++-- | Generates random data using token's RNG.+generateRandom ::+ Session -- ^ Session to work on.+ -> CULong -- ^ Number of bytes to generate.+ -> IO BS.ByteString -- ^ Generated random bytes.+generateRandom (Session sessHandle funcListPtr) randLen =+ allocaBytes (fromIntegral randLen) $ \randPtr -> do+ rv <- generateRandom' funcListPtr sessHandle randPtr randLen+ if rv /= 0+ then fail $ "failed to generate random data: " ++ rvToStr rv+ else BS.packCStringLen (castPtr randPtr, fromIntegral randLen)++-- | Obtains a list of mechanism types supported by a token+getMechanismList :: Library -> SlotId -> Int -> IO [Int]+getMechanismList (Library _ functionListPtr) slotId maxMechanisms =+ allocaArray maxMechanisms $ \array -> do+ (rv, outArrayLen) <- getMechanismList' functionListPtr slotId array (fromIntegral maxMechanisms)+ if rv /= 0+ then fail $ "failed to get list of mechanisms: " ++ rvToStr rv+ else do+ mechsIds <- peekArray (fromIntegral outArrayLen) array+ return $ map fromIntegral mechsIds++-- | Obtains information about a particular mechanism possibly supported by a token+getMechanismInfo :: Library -> SlotId -> MechType -> IO MechInfo+getMechanismInfo (Library _ functionListPtr) slotId mechId = do+ (rv, types) <- _getMechanismInfo functionListPtr slotId (fromEnum mechId)+ if rv /= 0+ then fail $ "failed to get mechanism information: " ++ rvToStr rv+ else return types
src/System/Crypto/Pkcs11/Lazy.hs view
@@ -1,3 +1,4 @@+-- | This module contains lazy versions of functions. module System.Crypto.Pkcs11.Lazy ( encrypt ) where@@ -11,12 +12,12 @@ lazyEncryptList :: Session -> [BS.ByteString] -> IO [BS.ByteString] lazyEncryptList sess (c:rest) = do- encC <- encryptUpdate sess c defaultChunkSize+ encC <- encryptUpdate sess c (Just defaultChunkSize) encRest <- lazyEncryptList sess rest return (encC : encRest) lazyEncryptList sess [] = do- last <- encryptFinal sess defaultChunkSize+ last <- encryptFinal sess (Just defaultChunkSize) return [last]