{-# LINE 1 "OpenSSL/PKCS7.hsc" #-} {- -*- haskell -*- -} {-# LINE 2 "OpenSSL/PKCS7.hsc" #-} -- #prune -- |An interface to PKCS#7 structure and S\/MIME message. {-# LINE 8 "OpenSSL/PKCS7.hsc" #-} module OpenSSL.PKCS7 ( -- * Types Pkcs7 , PKCS7 -- private , Pkcs7Flag(..) , Pkcs7VerifyStatus(..) , wrapPkcs7Ptr -- private , withPkcs7Ptr -- private -- * Encryption and Signing , pkcs7Sign , pkcs7Verify , pkcs7Encrypt , pkcs7Decrypt -- * S\/MIME , writeSmime , readSmime ) where import Data.List import Data.Traversable import Data.Typeable import Foreign import Foreign.C import OpenSSL.BIO import OpenSSL.EVP.Cipher hiding (cipher) import OpenSSL.EVP.PKey import OpenSSL.EVP.Internal import OpenSSL.Stack import OpenSSL.Utils import OpenSSL.X509 import OpenSSL.X509.Store {- PKCS#7 -------------------------------------------------------------------- -} -- |@'Pkcs7'@ represents an abstract PKCS#7 structure. The concrete -- type of structure is hidden in the object: such polymorphism isn't -- very haskellish but please get it out of your mind since OpenSSL is -- written in C. newtype Pkcs7 = Pkcs7 (ForeignPtr PKCS7) data PKCS7 -- |@'Pkcs7Flag'@ is a set of flags that are used in many operations -- related to PKCS#7. data Pkcs7Flag = Pkcs7Text | Pkcs7NoCerts | Pkcs7NoSigs | Pkcs7NoChain | Pkcs7NoIntern | Pkcs7NoVerify | Pkcs7Detached | Pkcs7Binary | Pkcs7NoAttr | Pkcs7NoSmimeCap | Pkcs7NoOldMimeType | Pkcs7CRLFEOL deriving (Show, Eq, Typeable) flagToInt :: Pkcs7Flag -> CInt flagToInt Pkcs7Text = 1 {-# LINE 72 "OpenSSL/PKCS7.hsc" #-} flagToInt Pkcs7NoCerts = 2 {-# LINE 73 "OpenSSL/PKCS7.hsc" #-} flagToInt Pkcs7NoSigs = 4 {-# LINE 74 "OpenSSL/PKCS7.hsc" #-} flagToInt Pkcs7NoChain = 8 {-# LINE 75 "OpenSSL/PKCS7.hsc" #-} flagToInt Pkcs7NoIntern = 16 {-# LINE 76 "OpenSSL/PKCS7.hsc" #-} flagToInt Pkcs7NoVerify = 32 {-# LINE 77 "OpenSSL/PKCS7.hsc" #-} flagToInt Pkcs7Detached = 64 {-# LINE 78 "OpenSSL/PKCS7.hsc" #-} flagToInt Pkcs7Binary = 128 {-# LINE 79 "OpenSSL/PKCS7.hsc" #-} flagToInt Pkcs7NoAttr = 256 {-# LINE 80 "OpenSSL/PKCS7.hsc" #-} flagToInt Pkcs7NoSmimeCap = 512 {-# LINE 81 "OpenSSL/PKCS7.hsc" #-} flagToInt Pkcs7NoOldMimeType = 1024 {-# LINE 82 "OpenSSL/PKCS7.hsc" #-} flagToInt Pkcs7CRLFEOL = 2048 {-# LINE 83 "OpenSSL/PKCS7.hsc" #-} -- |@'Pkcs7VerifyStatus'@ represents a result of PKCS#7 -- verification. See 'pkcs7Verify'. data Pkcs7VerifyStatus = Pkcs7VerifySuccess (Maybe String) -- ^ Nothing if the PKCS#7 -- signature was a detached -- signature, and @Just content@ -- if it wasn't. | Pkcs7VerifyFailure deriving (Show, Eq, Typeable) flagListToInt :: [Pkcs7Flag] -> CInt flagListToInt = foldl' (.|.) 0 . map flagToInt foreign import ccall "&PKCS7_free" _free :: FunPtr (Ptr PKCS7 -> IO ()) foreign import ccall "HsOpenSSL_PKCS7_is_detached" _is_detached :: Ptr PKCS7 -> IO CLong foreign import ccall "PKCS7_sign" _sign :: Ptr X509_ -> Ptr EVP_PKEY -> Ptr STACK -> Ptr BIO_ -> CInt -> IO (Ptr PKCS7) foreign import ccall "PKCS7_verify" _verify :: Ptr PKCS7 -> Ptr STACK -> Ptr X509_STORE -> Ptr BIO_ -> Ptr BIO_ -> CInt -> IO CInt foreign import ccall "PKCS7_encrypt" _encrypt :: Ptr STACK -> Ptr BIO_ -> Ptr EVP_CIPHER -> CInt -> IO (Ptr PKCS7) foreign import ccall "PKCS7_decrypt" _decrypt :: Ptr PKCS7 -> Ptr EVP_PKEY -> Ptr X509_ -> Ptr BIO_ -> CInt -> IO CInt wrapPkcs7Ptr :: Ptr PKCS7 -> IO Pkcs7 wrapPkcs7Ptr = fmap Pkcs7 . newForeignPtr _free withPkcs7Ptr :: Pkcs7 -> (Ptr PKCS7 -> IO a) -> IO a withPkcs7Ptr (Pkcs7 pkcs7) = withForeignPtr pkcs7 isDetachedSignature :: Pkcs7 -> IO Bool isDetachedSignature pkcs7 = withPkcs7Ptr pkcs7 $ \ pkcs7Ptr -> fmap (== 1) (_is_detached pkcs7Ptr) pkcs7Sign' :: KeyPair key => X509 -> key -> [X509] -> BIO -> [Pkcs7Flag] -> IO Pkcs7 pkcs7Sign' signCert pkey certs input flagList = withX509Ptr signCert $ \ signCertPtr -> withPKeyPtr' pkey $ \ pkeyPtr -> withX509Stack certs $ \ certStack -> withBioPtr input $ \ inputPtr -> _sign signCertPtr pkeyPtr certStack inputPtr (flagListToInt flagList) >>= failIfNull >>= wrapPkcs7Ptr -- |@'pkcs7Sign'@ creates a PKCS#7 signedData structure. pkcs7Sign :: KeyPair key => X509 -- ^ certificate to sign with -> key -- ^ corresponding private key -> [X509] -- ^ optional additional set of certificates -- to include in the PKCS#7 structure (for -- example any intermediate CAs in the -- chain) -> String -- ^ data to be signed -> [Pkcs7Flag] -- ^ An optional set of flags: -- -- ['Pkcs7Text'] Many S\/MIME clients -- expect the signed content to include -- valid MIME headers. If the 'Pkcs7Text' -- flag is set MIME headers for type -- \"text\/plain\" are prepended to the -- data. -- -- ['Pkcs7NoCerts'] If 'Pkcs7NoCerts' is -- set the signer's certificate will not be -- included in the PKCS#7 structure, the -- signer's certificate must still be -- supplied in the parameter though. This -- can reduce the size of the signature if -- the signer's certificate can be obtained -- by other means: for example a previously -- signed message. -- -- ['Pkcs7Detached'] The data being signed -- is included in the PKCS#7 structure, -- unless 'Pkcs7Detached' is set in which -- case it is ommited. This is used for -- PKCS#7 detached signatures which are -- used in S\/MIME plaintext signed message -- for example. -- -- ['Pkcs7Binary'] Normally the supplied -- content is translated into MIME -- canonical format (as required by the -- S\/MIME specifications) but if -- 'Pkcs7Binary' is set no translation -- occurs. This option should be uesd if -- the supplied data is in binary format -- otherwise the translation will corrupt -- it. -- -- ['Pkcs7NoAttr'] -- -- ['Pkcs7NoSmimeCap'] The signedData -- structure includes several PKCS#7 -- authenticatedAttributes including the -- signing time, the PKCS#7 content type -- and the supported list of ciphers in an -- SMIMECapabilities attribute. If -- 'Pkcs7NoAttr' is set then no -- authenticatedAttributes will be used. If -- Pkcs7NoSmimeCap is set then just the -- SMIMECapabilities are omitted. -> IO Pkcs7 pkcs7Sign signCert pkey certs input flagList = do mem <- newConstMem input pkcs7Sign' signCert pkey certs mem flagList pkcs7Verify' :: Pkcs7 -> [X509] -> X509Store -> Maybe BIO -> [Pkcs7Flag] -> IO (Maybe BIO, Bool) pkcs7Verify' pkcs7 certs store inData flagList = withPkcs7Ptr pkcs7 $ \ pkcs7Ptr -> withX509Stack certs $ \ certStack -> withX509StorePtr store $ \ storePtr -> withBioPtr' inData $ \ inDataPtr -> do isDetached <- isDetachedSignature pkcs7 outData <- if isDetached then return Nothing else fmap Just newMem withBioPtr' outData $ \ outDataPtr -> _verify pkcs7Ptr certStack storePtr inDataPtr outDataPtr (flagListToInt flagList) >>= interpret outData where interpret :: Maybe BIO -> CInt -> IO (Maybe BIO, Bool) interpret bio 1 = return (bio , True ) interpret _ _ = return (Nothing, False) -- |@'pkcs7Verify'@ verifies a PKCS#7 signedData structure. pkcs7Verify :: Pkcs7 -- ^ A PKCS#7 structure to verify. -> [X509] -- ^ Set of certificates in which to -- search for the signer's -- certificate. -> X509Store -- ^ Trusted certificate store (used -- for chain verification). -> Maybe String -- ^ Signed data if the content is not -- present in the PKCS#7 structure -- (that is it is detached). -> [Pkcs7Flag] -- ^ An optional set of flags: -- -- ['Pkcs7NoIntern'] If -- 'Pkcs7NoIntern' is set the -- certificates in the message itself -- are not searched when locating the -- signer's certificate. This means -- that all the signers certificates -- must be in the second argument -- (['X509']). -- -- ['Pkcs7Text'] If the 'Pkcs7Text' -- flag is set MIME headers for type -- \"text\/plain\" are deleted from -- the content. If the content is not -- of type \"text\/plain\" then an -- error is returned. -- -- ['Pkcs7NoVerify'] If -- 'Pkcs7NoVerify' is set the -- signer's certificates are not -- chain verified. -- -- ['Pkcs7NoChain'] If 'Pkcs7NoChain' -- is set then the certificates -- contained in the message are not -- used as untrusted CAs. This means -- that the whole verify chain (apart -- from the signer's certificate) -- must be contained in the trusted -- store. -- -- ['Pkcs7NoSigs'] If 'Pkcs7NoSigs' -- is set then the signatures on the -- data are not checked. -> IO Pkcs7VerifyStatus pkcs7Verify pkcs7 certs store inData flagList = do inDataBio <- forM inData newConstMem (outDataBio, isSuccess) <- pkcs7Verify' pkcs7 certs store inDataBio flagList if isSuccess then do outData <- forM outDataBio bioRead return $ Pkcs7VerifySuccess outData else return Pkcs7VerifyFailure pkcs7Encrypt' :: [X509] -> BIO -> Cipher -> [Pkcs7Flag] -> IO Pkcs7 pkcs7Encrypt' certs input cipher flagList = withX509Stack certs $ \ certsPtr -> withBioPtr input $ \ inputPtr -> withCipherPtr cipher $ \ cipherPtr -> _encrypt certsPtr inputPtr cipherPtr (flagListToInt flagList) >>= failIfNull >>= wrapPkcs7Ptr -- |@'pkcs7Encrypt'@ creates a PKCS#7 envelopedData structure. pkcs7Encrypt :: [X509] -- ^ A list of recipient certificates. -> String -- ^ The content to be encrypted. -> Cipher -- ^ The symmetric cipher to use. -> [Pkcs7Flag] -- ^ An optional set of flags: -- -- ['Pkcs7Text'] If the 'Pkcs7Text' flag -- is set MIME headers for type -- \"text\/plain\" are prepended to the -- data. -- -- ['Pkcs7Binary'] Normally the supplied -- content is translated into MIME -- canonical format (as required by the -- S\/MIME specifications) if -- 'Pkcs7Binary' is set no translation -- occurs. This option should be used if -- the supplied data is in binary format -- otherwise the translation will -- corrupt it. If 'Pkcs7Binary' is set -- then 'Pkcs7Text' is ignored. -> IO Pkcs7 pkcs7Encrypt certs input cipher flagList = do mem <- newConstMem input pkcs7Encrypt' certs mem cipher flagList pkcs7Decrypt' :: KeyPair key => Pkcs7 -> key -> X509 -> BIO -> [Pkcs7Flag] -> IO () pkcs7Decrypt' pkcs7 pkey cert output flagList = withPkcs7Ptr pkcs7 $ \ pkcs7Ptr -> withPKeyPtr' pkey $ \ pkeyPtr -> withX509Ptr cert $ \ certPtr -> withBioPtr output $ \ outputPtr -> _decrypt pkcs7Ptr pkeyPtr certPtr outputPtr (flagListToInt flagList) >>= failIf (/= 1) >> return () -- |@'pkcs7Decrypt'@ decrypts content from PKCS#7 envelopedData -- structure. pkcs7Decrypt :: KeyPair key => Pkcs7 -- ^ The PKCS#7 structure to decrypt. -> key -- ^ The private key of the recipient. -> X509 -- ^ The recipient's certificate. -> [Pkcs7Flag] -- ^ An optional set of flags: -- -- ['Pkcs7Text'] If the 'Pkcs7Text' flag -- is set MIME headers for type -- \"text\/plain\" are deleted from the -- content. If the content is not of -- type \"text\/plain\" then an error is -- thrown. -> IO String -- ^ The decrypted content. pkcs7Decrypt pkcs7 pkey cert flagList = do mem <- newMem pkcs7Decrypt' pkcs7 pkey cert mem flagList bioRead mem {- S/MIME -------------------------------------------------------------------- -} foreign import ccall unsafe "SMIME_write_PKCS7" _SMIME_write_PKCS7 :: Ptr BIO_ -> Ptr PKCS7 -> Ptr BIO_ -> CInt -> IO CInt foreign import ccall unsafe "SMIME_read_PKCS7" _SMIME_read_PKCS7 :: Ptr BIO_ -> Ptr (Ptr BIO_) -> IO (Ptr PKCS7) -- |@'writeSmime'@ writes PKCS#7 structure to S\/MIME message. writeSmime :: Pkcs7 -- ^ A PKCS#7 structure to be written. -> Maybe String -- ^ If cleartext signing -- (multipart\/signed) is being used then -- the signed data must be supplied here. -> [Pkcs7Flag] -- ^ An optional set of flags: -- -- ['Pkcs7Detached'] If 'Pkcs7Detached' -- is set then cleartext signing will be -- used, this option only makes sense for -- signedData where 'Pkcs7Detached' is -- also set when 'pkcs7Sign' is also -- called. -- -- ['Pkcs7Text'] If the 'Pkcs7Text' flag -- is set MIME headers for type -- \"text\/plain\" are added to the -- content, this only makes sense if -- 'Pkcs7Detached' is also set. -> IO String -- ^ The result S\/MIME message. writeSmime pkcs7 dataStr flagList = do outBio <- newMem dataBio <- forM dataStr newConstMem writeSmime' outBio pkcs7 dataBio flagList bioRead outBio writeSmime' :: BIO -> Pkcs7 -> Maybe BIO -> [Pkcs7Flag] -> IO () writeSmime' outBio pkcs7 dataBio flagList = withBioPtr outBio $ \ outBioPtr -> withPkcs7Ptr pkcs7 $ \ pkcs7Ptr -> withBioPtr' dataBio $ \ dataBioPtr -> _SMIME_write_PKCS7 outBioPtr pkcs7Ptr dataBioPtr (flagListToInt flagList) >>= failIf (/= 1) >> return () -- |@'readSmime'@ parses S\/MIME message. readSmime :: String -- ^ The message to be read. -> IO (Pkcs7, Maybe String) -- ^ (The result PKCS#7 -- structure, @Just content@ -- if the PKCS#7 structure was -- a cleartext signature and -- @Nothing@ if it wasn't.) readSmime input = do inBio <- newConstMem input (pkcs7, outBio) <- readSmime' inBio output <- forM outBio bioRead return (pkcs7, output) readSmime' :: BIO -> IO (Pkcs7, Maybe BIO) readSmime' inBio = withBioPtr inBio $ \ inBioPtr -> alloca $ \ outBioPtrPtr -> do poke outBioPtrPtr nullPtr pkcs7 <- _SMIME_read_PKCS7 inBioPtr outBioPtrPtr >>= failIfNull >>= wrapPkcs7Ptr outBioPtr <- peek outBioPtrPtr outBio <- if outBioPtr == nullPtr then return Nothing else fmap Just (wrapBioPtr outBioPtr) return (pkcs7, outBio)