module System.Crypto.Pkcs11
(
Library
, loadLibrary
, releaseLibrary
, getInfo
, LibraryInfo
, infoCryptokiVersion
, infoManufacturerId
, infoFlags
, infoLibraryDescription
, infoLibraryVersion
, Version
, versionMajor
, versionMinor
, SlotId
, getSlotNum
, getSlotList
, getSlotInfo
, SlotInfo
, slotInfoDescription
, slotInfoManufacturerId
, slotInfoFlags
, slotInfoHardwareVersion
, slotInfoFirmwareVersion
, TokenInfo
, getTokenInfo
, tokenInfoLabel
, tokenInfoManufacturerId
, tokenInfoModel
, tokenInfoSerialNumber
, tokenInfoFlags
, initToken
, initPin
, setPin
, getMechanismList
, getMechanismInfo
, MechType(..)
, MechInfo
, mechInfoMinKeySize
, mechInfoMaxKeySize
, mechInfoFlags
, Mech
, simpleMech
, Session
, withSession
, login
, UserType(..)
, logout
, closeAllSessions
, getSessionInfo
, SessionInfo
, sessionInfoSlotId
, sessionInfoState
, sessionInfoFlags
, sessionInfoDeviceError
, SessionState(..)
, getOperationState
, Object
, Attribute(..)
, ClassType(..)
, KeyTypeValue(..)
, destroyObject
, createObject
, copyObject
, getObjectSize
, findObjects
, getTokenFlag
, getPrivateFlag
, getSensitiveFlag
, getEncryptFlag
, getDecryptFlag
, getWrapFlag
, getUnwrapFlag
, getSignFlag
, getModulus
, getPublicExponent
, getPrime
, getBase
, getEcdsaParams
, getEcPoint
, setAttributes
, generateKey
, generateKeyPair
, deriveKey
, wrapKey
, unwrapKey
, decrypt
, encrypt
, decryptInit
, encryptInit
, encryptUpdate
, encryptFinal
, digest
, digestInit
, sign
, verify
, signRecover
, signInit
, verifyInit
, signRecoverInit
, 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
data Library = Library
{ libraryHandle :: DL
, functionListPtr :: FunctionListPtr
}
data Object =
Object FunctionListPtr
SessionHandle
ObjectHandle
deriving (Show)
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)
getSlotNum ::
Library
-> Bool
-> IO CULong
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
getSlotList ::
Library
-> Bool
-> Int
-> 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)
destroyObject (Object funcListPtr sessHandle objectHandle) = do
rv <- destroyObject' funcListPtr sessHandle objectHandle
when (rv /= 0) $ fail $ "failed to destroy object: " ++ rvToStr rv
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
data Session =
Session SessionHandle
FunctionListPtr
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}
releaseLibrary lib = do
rv <- finalize $ functionListPtr lib
dlclose $ libraryHandle lib
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
withSession ::
Library
-> SlotId
-> Bool
-> (Session -> IO a)
-> IO a
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
findObjects :: Session -> [Attribute] -> IO [Object]
findObjects session attribs = do
_findObjectsInit session attribs
finally (_findObjectsEx session) (_findObjectsFinalEx session)
generateKeyPair ::
Mech
-> [Attribute]
-> [Attribute]
-> Session
-> IO (Object, Object)
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)
initToken ::
Library
-> SlotId
-> BU8.ByteString
-> String
-> IO ()
initToken (Library _ funcListPtr) slotId pin label = do
rv <- initToken' funcListPtr slotId pin label
when (rv /= 0) $ fail $ "failed to initialize token " ++ rvToStr rv
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
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
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
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
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
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
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
initPin :: Session -> BU8.ByteString -> IO ()
initPin (Session sessHandle funcListPtr) pin = do
rv <- initPin' funcListPtr sessHandle pin
when (rv /= 0) $ fail $ "initPin failed: " ++ rvToStr rv
setPin ::
Session
-> BU8.ByteString
-> BU8.ByteString
-> IO ()
setPin (Session sessHandle funcListPtr) oldPin newPin = do
rv <- setPin' funcListPtr sessHandle oldPin newPin
when (rv /= 0) $ fail $ "setPin failed: " ++ rvToStr rv
login ::
Session
-> UserType
-> BU8.ByteString
-> IO ()
login (Session sessionHandle functionListPtr) userType pin = do
rv <- _login functionListPtr sessionHandle userType pin
when (rv /= 0) $ fail $ "login failed: " ++ rvToStr rv
logout :: Session -> IO ()
logout (Session sessionHandle functionListPtr) = do
rv <- logout' functionListPtr sessionHandle
when (rv /= 0) $ fail $ "logout failed: " ++ rvToStr rv
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 ::
Mech
-> Object
-> BS.ByteString
-> Maybe CULong
-> IO BS.ByteString
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
encryptInit ::
Mech
-> Object
-> 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 ::
Mech
-> Object
-> BS.ByteString
-> Maybe CULong
-> IO BS.ByteString
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
digest ::
Mech
-> Session
-> BS.ByteString
-> Maybe CULong
-> IO BS.ByteString
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
sign ::
Mech
-> Object
-> BS.ByteString
-> Maybe CULong
-> IO BS.ByteString
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
verify ::
Mech
-> Object
-> BS.ByteString
-> BS.ByteString
-> IO Bool
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
wrapKey ::
Mech
-> Object
-> Object
-> Maybe CULong
-> IO BS.ByteString
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
unwrapKey ::
Mech
-> Object
-> BS.ByteString
-> [Attribute]
-> IO Object
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
seedRandom ::
Session
-> BS.ByteString
-> 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
generateRandom ::
Session
-> CULong
-> IO BS.ByteString
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)
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
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