diff --git a/Test.hs b/Test.hs --- a/Test.hs +++ b/Test.hs @@ -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 diff --git a/hspkcs11.cabal b/hspkcs11.cabal --- a/hspkcs11.cabal +++ b/hspkcs11.cabal @@ -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 diff --git a/src/Bindings/Pkcs11.chs b/src/Bindings/Pkcs11.chs new file mode 100644 --- /dev/null +++ b/src/Bindings/Pkcs11.chs @@ -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' +#} diff --git a/src/System/Crypto/Pkcs11.chs b/src/System/Crypto/Pkcs11.chs deleted file mode 100644 --- a/src/System/Crypto/Pkcs11.chs +++ /dev/null @@ -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 diff --git a/src/System/Crypto/Pkcs11.hs b/src/System/Crypto/Pkcs11.hs new file mode 100644 --- /dev/null +++ b/src/System/Crypto/Pkcs11.hs @@ -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 diff --git a/src/System/Crypto/Pkcs11/Lazy.hs b/src/System/Crypto/Pkcs11/Lazy.hs --- a/src/System/Crypto/Pkcs11/Lazy.hs +++ b/src/System/Crypto/Pkcs11/Lazy.hs @@ -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]