PKCS#7 (en|de)cryption

darcs-hash:20070630030715-62b54-7a4a607132ecd1b3aa5fbd28f46152a418966ae1.gz

.boring

@@ -79,6 +79,7 @@ _stub\.(c|h)$
 ^OpenSSL/X509/Name\.hs$
 ^OpenSSL/X509/Request\.hs$
 ^OpenSSL/X509/Revocation\.hs$
+^OpenSSL/X509/Store\.hs$
 ^Setup$
 ^aclocal\.m4$
 ^configure$

HsOpenSSL.cabal

@@ -40,6 +40,7 @@ Exposed-Modules:
         OpenSSL.X509.Revocation
         OpenSSL.X509.Name
         OpenSSL.X509.Request
+        OpenSSL.X509.Store
 Extensions:
         ForeignFunctionInterface
 ghc-options:

OpenSSL/BIO.hsc

@@ -34,7 +34,9 @@ module OpenSSL.BIO
       BIO
     , BIO_
 
-    , withBioPtr -- private
+    , wrapBioPtr  -- private
+    , withBioPtr  -- private
+    , withBioPtr' -- private
 
       -- * BIO chaning
     , bioPush
@@ -112,14 +114,22 @@ foreign import ccall unsafe "HsOpenSSL_BIO_should_retry"
 
 new :: Ptr BIO_METHOD -> IO BIO
 new method
-    = do ptr <- _new method >>= failIfNull
-         newForeignPtr _free ptr >>= return . BIO
+    = _new method >>= failIfNull >>= wrapBioPtr
+
+
+wrapBioPtr :: Ptr BIO_ -> IO BIO
+wrapBioPtr bioPtr = newForeignPtr _free bioPtr >>= return . BIO
 
 
 withBioPtr :: BIO -> (Ptr BIO_ -> IO a) -> IO a
 withBioPtr (BIO bio) = withForeignPtr bio
 
 
+withBioPtr' :: Maybe BIO -> (Ptr BIO_ -> IO a) -> IO a
+withBioPtr' Nothing    f = f nullPtr
+withBioPtr' (Just bio) f = withBioPtr bio f
+
+
 -- a の後ろに b を付ける。a の參照だけ保持してそこに書き込む事も、b の
 -- 參照だけ保持してそこから讀み出す事も、兩方考へられるので、双方の
 -- ForeignPtr が双方を touch する。參照カウント方式ではないから循環參照

OpenSSL/PKCS7.hsc

@@ -9,9 +9,15 @@ module OpenSSL.PKCS7
     , wrapPkcs7Ptr -- private
     , withPkcs7Ptr -- private
 
+    , isDetachedSignature
+
     , pkcs7Sign
+    , pkcs7Verify
+    , pkcs7Encrypt
+    , pkcs7Decrypt
 
     , writeSmime
+    , readSmime
     )
     where
 
@@ -22,13 +28,16 @@ import qualified Data.ByteString.Char8      as B8
 import qualified Data.ByteString.Lazy.Char8 as L8
 import           Data.List
 import           Data.Traversable
+import           Data.Typeable
 import           Foreign
 import           Foreign.C
 import           OpenSSL.BIO
+import           OpenSSL.EVP.Cipher
 import           OpenSSL.EVP.PKey
 import           OpenSSL.Stack
 import           OpenSSL.Utils
 import           OpenSSL.X509
+import           OpenSSL.X509.Store
 
 
 {- PKCS#7 -------------------------------------------------------------------- -}
@@ -48,6 +57,7 @@ data Pkcs7Flag = Pkcs7Text
                | Pkcs7NoSmimeCap
                | Pkcs7NoOldMimeType
                | Pkcs7CRLFEOL
+                 deriving (Show, Eq, Typeable)
 
 flagToInt :: Pkcs7Flag -> Int
 flagToInt Pkcs7Text          = #const PKCS7_TEXT
@@ -63,16 +73,34 @@ flagToInt Pkcs7NoSmimeCap    = #const PKCS7_NOSMIMECAP
 flagToInt Pkcs7NoOldMimeType = #const PKCS7_NOOLDMIMETYPE
 flagToInt Pkcs7CRLFEOL       = #const PKCS7_CRLFEOL
 
+
+data VerifyStatus = VerifySuccess (Maybe String)
+                  | VerifyFailure
+                    deriving (Show, Eq, Typeable)
+
+
 flagListToInt :: [Pkcs7Flag] -> Int
 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_ -> Int -> IO (Ptr PKCS7)
 
+foreign import ccall "PKCS7_verify"
+        _verify :: Ptr PKCS7 -> Ptr STACK -> Ptr X509_STORE -> Ptr BIO_ -> Ptr BIO_ -> Int -> IO Int
+
+foreign import ccall "PKCS7_encrypt"
+        _encrypt :: Ptr STACK -> Ptr BIO_ -> Ptr EVP_CIPHER -> Int -> IO (Ptr PKCS7)
+
+foreign import ccall "PKCS7_decrypt"
+        _decrypt :: Ptr PKCS7 -> Ptr EVP_PKEY -> Ptr X509_ -> Ptr BIO_ -> Int -> IO Int
+
 
 wrapPkcs7Ptr :: Ptr PKCS7 -> IO Pkcs7
 wrapPkcs7Ptr p7Ptr = newForeignPtr _free p7Ptr >>= return . Pkcs7
@@ -82,23 +110,22 @@ withPkcs7Ptr :: Pkcs7 -> (Ptr PKCS7 -> IO a) -> IO a
 withPkcs7Ptr (Pkcs7 pkcs7) = withForeignPtr pkcs7
 
 
+isDetachedSignature :: Pkcs7 -> IO Bool
+isDetachedSignature pkcs7
+    = withPkcs7Ptr pkcs7 $ \ pkcs7Ptr ->
+      _is_detached pkcs7Ptr
+           >>= return . (== 1)
+
+
 pkcs7Sign' :: X509 -> EvpPKey -> [X509] -> BIO -> [Pkcs7Flag] -> IO Pkcs7
 pkcs7Sign' signCert pkey certs input flagList
     = withX509Ptr signCert $ \ signCertPtr ->
       withPKeyPtr pkey     $ \ pkeyPtr     ->
-      -- [X509] から [Ptr X509_] を作る。後で touchX509 する事を
-      -- 忘れてはならない。
-      do let certPtrs = map unsafeX509ToPtr certs
-             flags    = flagListToInt flagList
-
-         pkcs7 <- withStack  certPtrs $ \ certStack ->
-                  withBioPtr input    $ \ inputPtr ->
-                      _sign signCertPtr pkeyPtr certStack inputPtr flags
-                      >>= failIfNull
-                      >>= wrapPkcs7Ptr
-
-         mapM_ touchX509 certs
-         return pkcs7
+      withX509Stack certs  $ \ certStack   ->
+      withBioPtr input     $ \ inputPtr    ->
+      _sign signCertPtr pkeyPtr certStack inputPtr (flagListToInt flagList)
+           >>= failIfNull
+           >>= wrapPkcs7Ptr
 
 
 pkcs7Sign :: X509 -> EvpPKey -> [X509] -> String -> [Pkcs7Flag] -> IO Pkcs7
@@ -107,11 +134,79 @@ pkcs7Sign signCert pkey certs input flagList
          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
+                           newMem >>= return . Just
+         withBioPtr' outData $ \ outDataPtr ->
+             _verify pkcs7Ptr certStack storePtr inDataPtr outDataPtr (flagListToInt flagList)
+                  >>= interpret outData
+    where
+      interpret :: Maybe BIO -> Int -> IO (Maybe BIO, Bool)
+      interpret bio 1 = return (bio    , True )
+      interpret _   _ = return (Nothing, False)
+
+
+pkcs7Verify :: Pkcs7 -> [X509] -> X509Store -> Maybe String -> [Pkcs7Flag] -> IO VerifyStatus
+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 $ VerifySuccess outData
+           else
+             return VerifyFailure
+
+
+pkcs7Encrypt' :: [X509] -> BIO -> EvpCipher -> [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 :: [X509] -> String -> EvpCipher -> [Pkcs7Flag] -> IO Pkcs7
+pkcs7Encrypt certs input cipher flagList
+    = do mem <- newConstMem input
+         pkcs7Encrypt' certs mem cipher flagList
+
+
+pkcs7Decrypt' :: Pkcs7 -> EvpPKey -> 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 :: Pkcs7 -> EvpPKey -> X509 -> [Pkcs7Flag] -> IO String
+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_ -> Int -> IO Int
 
+foreign import ccall unsafe "SMIME_read_PKCS7"
+        _SMIME_read_PKCS7 :: Ptr BIO_ -> Ptr (Ptr BIO_) -> IO (Ptr PKCS7)
+
 
 writeSmime :: Pkcs7 -> Maybe String -> [Pkcs7Flag] -> IO String
 writeSmime pkcs7 dataStr flagList
@@ -129,7 +224,29 @@ writeSmime' outBio pkcs7 dataBio flagList
       _SMIME_write_PKCS7 outBioPtr pkcs7Ptr dataBioPtr (flagListToInt flagList)
            >>= failIf (/= 1)
            >>  return ()
-    where
-      withBioPtr' :: Maybe BIO -> (Ptr BIO_ -> IO a) -> IO a
-      withBioPtr' Nothing    f = f nullPtr
-      withBioPtr' (Just bio) f = withBioPtr bio f
+
+
+readSmime :: String -> IO (Pkcs7, Maybe String)
+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
+                          wrapBioPtr outBioPtr >>= return . Just
+
+         return (pkcs7, outBio)

OpenSSL/Stack.hsc

@@ -4,6 +4,7 @@ module OpenSSL.Stack
     ( STACK
     , mapStack
     , withStack
+    , withForeignStack
     )
     where
 
@@ -19,7 +20,7 @@ data STACK = STACK
 foreign import ccall unsafe "sk_new_null"
         skNewNull :: IO (Ptr STACK)
 
-foreign import ccall unsafe "sk_new_null"
+foreign import ccall unsafe "sk_free"
         skFree :: Ptr STACK -> IO ()
 
 foreign import ccall unsafe "sk_push"
@@ -48,4 +49,15 @@ newStack values
 
 withStack :: [Ptr a] -> (Ptr STACK -> IO b) -> IO b
 withStack values f
-    = bracket (newStack values) skFree f
+    = bracket (newStack values) skFree f
+
+
+withForeignStack :: (fp -> Ptr obj)
+                 -> (fp -> IO ())
+                 -> [fp]
+                 -> (Ptr STACK -> IO ret)
+                 -> IO ret
+withForeignStack unsafeFpToPtr touchFp fps action
+    = do ret <- withStack (map unsafeFpToPtr fps) action
+         mapM_ touchFp fps
+         return ret

OpenSSL/X509.hsc

@@ -6,8 +6,11 @@ module OpenSSL.X509
     , newX509
     , wrapX509 -- private
     , withX509Ptr -- private
+    , withX509Stack -- private
     , unsafeX509ToPtr -- private
-    , touchX509
+    , touchX509 -- private
+
+    , compareX509
 
     , signX509
     , verifyX509
@@ -65,6 +68,9 @@ foreign import ccall unsafe "&X509_free"
 foreign import ccall unsafe "X509_print"
         _print :: Ptr BIO_ -> Ptr X509_ -> IO Int
 
+foreign import ccall unsafe "X509_cmp"
+        _cmp :: Ptr X509_ -> Ptr X509_ -> IO Int
+
 foreign import ccall unsafe "HsOpenSSL_X509_get_version"
         _get_version :: Ptr X509_ -> IO CLong
 
@@ -132,6 +138,10 @@ withX509Ptr :: X509 -> (Ptr X509_ -> IO a) -> IO a
 withX509Ptr (X509 x509) = withForeignPtr x509
 
 
+withX509Stack :: [X509] -> (Ptr STACK -> IO a) -> IO a
+withX509Stack = withForeignStack unsafeX509ToPtr touchX509
+
+
 unsafeX509ToPtr :: X509 -> Ptr X509_
 unsafeX509ToPtr (X509 x509) = unsafeForeignPtrToPtr x509
 
@@ -140,6 +150,19 @@ touchX509 :: X509 -> IO ()
 touchX509 (X509 x509) = touchForeignPtr x509
 
 
+compareX509 :: X509 -> X509 -> IO Ordering
+compareX509 cert1 cert2
+    = withX509Ptr cert1 $ \ cert1Ptr ->
+      withX509Ptr cert2 $ \ cert2Ptr ->
+      _cmp cert1Ptr cert2Ptr >>= return . interpret
+    where
+      interpret :: Int -> Ordering
+      interpret n
+          | n > 0     = GT
+          | n < 0     = LT
+          | otherwise = EQ
+
+
 signX509 :: X509 -> EvpPKey -> Maybe EvpMD -> IO ()
 signX509 x509 pkey mDigest
     = withX509Ptr x509 $ \ x509Ptr ->