diff --git a/HsOpenSSL.cabal b/HsOpenSSL.cabal --- a/HsOpenSSL.cabal +++ b/HsOpenSSL.cabal @@ -5,7 +5,7 @@ generate RSA and DSA keys, read and write PEM files, generate message digests, sign and verify messages, encrypt and decrypt messages. -Version: 0.3 +Version: 0.3.1 License: PublicDomain License-File: COPYING Author: PHO @@ -13,57 +13,75 @@ Stability: experimental Homepage: http://ccm.sherry.jp/HsOpenSSL/ Category: Cryptography -Tested-With: GHC == 6.6.1 -Build-Depends: - base, time >= 1.1.1 -Exposed-Modules: - OpenSSL - OpenSSL.BN - OpenSSL.EVP.Base64 - OpenSSL.EVP.Cipher - OpenSSL.EVP.Digest - OpenSSL.EVP.Open - OpenSSL.EVP.PKey - OpenSSL.EVP.Seal - OpenSSL.EVP.Sign - OpenSSL.EVP.Verify - OpenSSL.Cipher - OpenSSL.PEM - OpenSSL.PKCS7 - OpenSSL.Random - OpenSSL.DSA - OpenSSL.RSA - OpenSSL.X509 - OpenSSL.X509.Revocation - OpenSSL.X509.Request - OpenSSL.X509.Store -Other-Modules: - OpenSSL.ASN1 - OpenSSL.BIO - OpenSSL.ERR - OpenSSL.Objects - OpenSSL.SSL - OpenSSL.Stack - OpenSSL.Utils - OpenSSL.X509.Name -Extensions: - ForeignFunctionInterface, EmptyDataDecls -ghc-options: - -O2 -fwarn-unused-imports -C-Sources: - cbits/HsOpenSSL.c -Include-Dirs: - cbits -Install-Includes: - HsOpenSSL.h +Tested-With: GHC == 6.8.1 +Cabal-Version: >= 1.2 + Extra-Source-Files: - AUTHORS - HsOpenSSL.buildinfo.in - NEWS - cbits/HsOpenSSL.h - configure - configure.ac - examples/Makefile - examples/GenRSAKey.hs - examples/HelloWorld.hs - examples/PKCS7.hs + AUTHORS + HsOpenSSL.buildinfo.in + NEWS + cbits/HsOpenSSL.h + configure + configure.ac + examples/Makefile + examples/GenRSAKey.hs + examples/HelloWorld.hs + examples/PKCS7.hs + tests/Base64.hs + tests/Cipher.hs + tests/DSA.hs + tests/Makefile + +flag splitBase + description: Choose the new smaller, split-up base package. + +Library + if flag(splitBase) + build-depends: base >= 3, bytestring, time >= 1.1.1, old-locale + else + build-depends: base < 3, time >= 1.1.1 + + --PkgConfig-Depends: openssl >= 0.9.7l + -- We really should use this instead of the configure script but + -- Cabal 1.2.2.0 can't handle the weird version scheme of OpenSSL. + + Exposed-Modules: + OpenSSL + OpenSSL.BN + OpenSSL.EVP.Base64 + OpenSSL.EVP.Cipher + OpenSSL.EVP.Digest + OpenSSL.EVP.Open + OpenSSL.EVP.PKey + OpenSSL.EVP.Seal + OpenSSL.EVP.Sign + OpenSSL.EVP.Verify + OpenSSL.Cipher + OpenSSL.PEM + OpenSSL.PKCS7 + OpenSSL.Random + OpenSSL.DSA + OpenSSL.RSA + OpenSSL.X509 + OpenSSL.X509.Revocation + OpenSSL.X509.Request + OpenSSL.X509.Store + Other-Modules: + OpenSSL.ASN1 + OpenSSL.BIO + OpenSSL.ERR + OpenSSL.Objects + OpenSSL.SSL + OpenSSL.Stack + OpenSSL.Utils + OpenSSL.X509.Name + Extensions: + ForeignFunctionInterface, EmptyDataDecls, MagicHash + ghc-options: + -Wall -fglasgow-exts + C-Sources: + cbits/HsOpenSSL.c + Include-Dirs: + cbits + Install-Includes: + HsOpenSSL.h diff --git a/NEWS b/NEWS --- a/NEWS +++ b/NEWS @@ -1,5 +1,13 @@ +Changes from 0.3 to 0.3.1 +------------------------- +* OpenSSL.EVP.Base64: Fix a bug in an internal function `decodeBlock': + decodeBase64* didn't drop the padding NUL. +* Applied patches by Adam Langley: + - Updates for 6.8.1 (also *requires* 6.8.1 now) + - tests/Base64.hs: Test for Base64 + Changes from 0.2 to 0.3 --------------------------------------- +----------------------- * Applied patches by Adam Langley: - tests/DSA.hs: Add a DSA test: this just adds a binary which tests a few simple DSA cases (and runs a timing test) and prints "PASS" diff --git a/OpenSSL.hs b/OpenSSL.hs new file mode 100644 --- /dev/null +++ b/OpenSSL.hs @@ -0,0 +1,79 @@ +{-# OPTIONS_GHC -optc-D__GLASGOW_HASKELL__=606 #-} +{-# INCLUDE "HsOpenSSL.h" #-} +{-# LINE 1 "OpenSSL.hsc" #-} +{- -*- haskell -*- -} +{-# LINE 2 "OpenSSL.hsc" #-} + +-- |HsOpenSSL is a (part of) OpenSSL binding for Haskell. It can +-- generate RSA and DSA keys, read and write PEM files, generate +-- message digests, sign and verify messages, encrypt and decrypt +-- messages. But since OpenSSL is a very large library, it is uneasy +-- to cover everything in it. +-- +-- Features that aren't (yet) supported: +-- +-- [/TLS\/SSL network connection/] ssl(3) functionalities are +-- totally uncovered. They should be covered someday. +-- +-- [/Complete coverage of Low-level API to symmetric ciphers/] Only +-- high-level APIs (EVP and BIO) are fully available. But I believe +-- no one will be lost without functions like @DES_set_odd_parity@. +-- +-- [/Low-level API to asymmetric ciphers/] Only a high-level API +-- (EVP) is available. But I believe no one will complain about the +-- absence of functions like @RSA_public_encrypt@. +-- +-- [/Key generation of Diffie-Hellman algorithm/] Only RSA and DSA +-- keys can currently be generated. +-- +-- [/X.509 v3 extension handling/] It should be supported in the +-- future. +-- +-- [/Low-level API to message digest functions/] Just use EVP +-- instead of something like @MD5_Update@. +-- +-- [/API to PKCS\#12 functionality/] It should be covered someday. +-- +-- [/BIO/] BIO isn't needed because we are Haskell hackers. Though +-- HsOpenSSL itself uses BIO internally. +-- +-- [/ENGINE cryptographic module/] The default implementations work +-- very well, don't they? +-- +-- So if you find out any features you want aren't supported, you must +-- write your own patch (or take over the HsOpenSSL project). Happy +-- hacking. + + +{-# LINE 44 "OpenSSL.hsc" #-} + +module OpenSSL + ( withOpenSSL + ) + where + +import OpenSSL.SSL + + +foreign import ccall "HsOpenSSL_setupMutex" + setupMutex :: IO () + + +-- |Computation of @'withOpenSSL' action@ initializes the OpenSSL +-- library and computes @action@. Every applications that use +-- HsOpenSSL must wrap any operations related to OpenSSL with +-- 'withOpenSSL', or they might crash. +-- +-- > module Main where +-- > import OpenSSL +-- > +-- > main :: IO () +-- > main = withOpenSSL $ +-- > do ... +-- +withOpenSSL :: IO a -> IO a +withOpenSSL act + = do loadErrorStrings + addAllAlgorithms + setupMutex + act diff --git a/OpenSSL/ASN1.hs b/OpenSSL/ASN1.hs new file mode 100644 --- /dev/null +++ b/OpenSSL/ASN1.hs @@ -0,0 +1,168 @@ +{-# OPTIONS_GHC -optc-D__GLASGOW_HASKELL__=606 #-} +{-# INCLUDE "HsOpenSSL.h" #-} +{-# LINE 1 "OpenSSL/ASN1.hsc" #-} + +{-# LINE 2 "OpenSSL/ASN1.hsc" #-} + +module OpenSSL.ASN1 + ( ASN1_OBJECT + , obj2nid + , nid2sn + , nid2ln + + , ASN1_STRING + , peekASN1String + + , ASN1_INTEGER + , peekASN1Integer + , withASN1Integer + + , ASN1_TIME + , peekASN1Time + , withASN1Time + ) + where + + +import Control.Exception +import Control.Monad +import Data.Time.Clock +import Data.Time.Clock.POSIX +import Data.Time.Format +import Foreign +import Foreign.C +import OpenSSL.BIO +import OpenSSL.BN +import OpenSSL.Utils +import System.Locale + +{- ASN1_OBJECT --------------------------------------------------------------- -} + +data ASN1_OBJECT + +foreign import ccall unsafe "OBJ_obj2nid" + obj2nid :: Ptr ASN1_OBJECT -> IO Int + +foreign import ccall unsafe "OBJ_nid2sn" + _nid2sn :: Int -> IO CString + +foreign import ccall unsafe "OBJ_nid2ln" + _nid2ln :: Int -> IO CString + + +nid2sn :: Int -> IO String +nid2sn nid = _nid2sn nid >>= peekCString + + +nid2ln :: Int -> IO String +nid2ln nid = _nid2ln nid >>= peekCString + + +{- ASN1_STRING --------------------------------------------------------------- -} + +data ASN1_STRING + +peekASN1String :: Ptr ASN1_STRING -> IO String +peekASN1String strPtr + = do buf <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) strPtr +{-# LINE 64 "OpenSSL/ASN1.hsc" #-} + len <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) strPtr +{-# LINE 65 "OpenSSL/ASN1.hsc" #-} + peekCStringLen (buf, len) + + +{- ASN1_INTEGER -------------------------------------------------------------- -} + +data ASN1_INTEGER + +foreign import ccall unsafe "HsOpenSSL_M_ASN1_INTEGER_new" + _ASN1_INTEGER_new :: IO (Ptr ASN1_INTEGER) + +foreign import ccall unsafe "HsOpenSSL_M_ASN1_INTEGER_free" + _ASN1_INTEGER_free :: Ptr ASN1_INTEGER -> IO () + +foreign import ccall unsafe "ASN1_INTEGER_to_BN" + _ASN1_INTEGER_to_BN :: Ptr ASN1_INTEGER -> Ptr BIGNUM -> IO (Ptr BIGNUM) + +foreign import ccall unsafe "BN_to_ASN1_INTEGER" + _BN_to_ASN1_INTEGER :: Ptr BIGNUM -> Ptr ASN1_INTEGER -> IO (Ptr ASN1_INTEGER) + + +peekASN1Integer :: Ptr ASN1_INTEGER -> IO Integer +peekASN1Integer intPtr + = allocaBN $ \ bn -> + do _ASN1_INTEGER_to_BN intPtr (unwrapBN bn) + >>= failIfNull + peekBN bn + + +allocaASN1Integer :: (Ptr ASN1_INTEGER -> IO a) -> IO a +allocaASN1Integer m + = bracket _ASN1_INTEGER_new _ASN1_INTEGER_free m + + +withASN1Integer :: Integer -> (Ptr ASN1_INTEGER -> IO a) -> IO a +withASN1Integer int m + = withBN int $ \ bn -> + allocaASN1Integer $ \ intPtr -> + do _BN_to_ASN1_INTEGER (unwrapBN bn) intPtr + >>= failIfNull + m intPtr + + +{- ASN1_TIME ---------------------------------------------------------------- -} + +data ASN1_TIME + +foreign import ccall unsafe "HsOpenSSL_M_ASN1_TIME_new" + _ASN1_TIME_new :: IO (Ptr ASN1_TIME) + +foreign import ccall unsafe "HsOpenSSL_M_ASN1_TIME_free" + _ASN1_TIME_free :: Ptr ASN1_TIME -> IO () + +foreign import ccall unsafe "ASN1_TIME_set" + _ASN1_TIME_set :: Ptr ASN1_TIME -> CTime -> IO (Ptr ASN1_TIME) + +foreign import ccall unsafe "ASN1_TIME_print" + _ASN1_TIME_print :: Ptr BIO_ -> Ptr ASN1_TIME -> IO Int + + +peekASN1Time :: Ptr ASN1_TIME -> IO UTCTime -- asn1/t_x509.c +peekASN1Time time + = do bio <- newMem + withBioPtr bio $ \ bioPtr -> + _ASN1_TIME_print bioPtr time + >>= failIf (/= 1) + timeStr <- bioRead bio + case parseTime locale "%b %e %H:%M:%S %Y %Z" timeStr of + Just utc -> return utc + Nothing -> fail ("peekASN1Time: failed to parse time string: " ++ timeStr) + where + locale :: TimeLocale + locale = TimeLocale { + wDays = undefined + , months = [ (undefined, x) + | x <- [ "Jan", "Feb", "Mar", "Apr", "May", "Jun" + , "Jul", "Aug", "Sep", "Oct", "Nov", "Dec" + ] + ] + , intervals = undefined + , amPm = undefined + , dateTimeFmt = undefined + , dateFmt = undefined + , timeFmt = undefined + , time12Fmt = undefined + } + + +allocaASN1Time :: (Ptr ASN1_TIME -> IO a) -> IO a +allocaASN1Time m + = bracket _ASN1_TIME_new _ASN1_TIME_free m + + +withASN1Time :: UTCTime -> (Ptr ASN1_TIME -> IO a) -> IO a +withASN1Time utc m + = allocaASN1Time $ \ time -> + do _ASN1_TIME_set time (fromIntegral $ round $ utcTimeToPOSIXSeconds utc) + >>= failIfNull + m time diff --git a/OpenSSL/ASN1.hsc b/OpenSSL/ASN1.hsc --- a/OpenSSL/ASN1.hsc +++ b/OpenSSL/ASN1.hsc @@ -157,6 +157,6 @@ withASN1Time :: UTCTime -> (Ptr ASN1_TIME -> IO a) -> IO a withASN1Time utc m = allocaASN1Time $ \ time -> - do _ASN1_TIME_set time (fromIntegral $ round $ utcTimeToPOSIXSeconds utc) + do _ASN1_TIME_set time (fromIntegral $ (round $ utcTimeToPOSIXSeconds utc :: Integer)) >>= failIfNull m time diff --git a/OpenSSL/BIO.hs b/OpenSSL/BIO.hs new file mode 100644 --- /dev/null +++ b/OpenSSL/BIO.hs @@ -0,0 +1,476 @@ +{-# OPTIONS_GHC -optc-D__GLASGOW_HASKELL__=606 #-} +{-# LINE 1 "OpenSSL/BIO.hsc" #-} +{- --------------------------------------------------------------------------- -} +{-# LINE 2 "OpenSSL/BIO.hsc" #-} +{- -} +{- FOR INTERNAL USE ONLY -} +{- -} +{- When I firstly saw the manpage of bio(3), it looked like a great API. I ac- -} +{- tually wrote a wrapper and even wrote a document. What a pain! -} +{- -} +{- Now I realized that BIOs aren't necessary to we Haskell hackers. Their fun- -} +{- ctionalities overlaps with Haskell's own I/O system. The only thing which -} +{- wasn't available without bio(3) -- at least I thought so -- was the -} +{- BIO_f_base64(3), but I found an undocumented API for the Base64 codec. -} +{- I FOUND AN UNDOCUMENTED API FOR THE VERY BASE64 CODEC. -} +{- So I decided to bury all the OpenSSL.BIO module. The game is over. -} +{- -} +{- --------------------------------------------------------------------------- -} + + +-- |A BIO is an I\/O abstraction, it hides many of the underlying I\/O +-- details from an application, if you are writing a pure C +-- application... +-- +-- I know, we are hacking on Haskell so BIO components like BIO_s_file +-- are hardly needed. But for filter BIOs, such as BIO_f_base64 and +-- BIO_f_cipher, they should be useful too to us. + +module OpenSSL.BIO + ( -- * Type + BIO + , BIO_ + + , wrapBioPtr -- private + , withBioPtr -- private + , withBioPtr' -- private + + -- * BIO chaning + , bioPush + , (==>) + , (<==) + , bioJoin + + -- * BIO control operations + , bioFlush + , bioReset + , bioEOF + + -- * BIO I\/O functions + , bioRead + , bioReadBS + , bioReadLBS + , bioGets + , bioGetsBS + , bioGetsLBS + , bioWrite + , bioWriteBS + , bioWriteLBS + + -- * Base64 BIO filter + , newBase64 + + -- * Buffering BIO filter + , newBuffer + + -- * Memory BIO sink\/source + , newMem + , newConstMem + , newConstMemBS + , newConstMemLBS + + -- * Null data BIO sink\/source + , newNullBIO + ) + where + +import Control.Monad +import Data.ByteString.Base +import qualified Data.ByteString.Char8 as B8 +import qualified Data.ByteString.Lazy.Char8 as L8 +import Foreign hiding (new) +import Foreign.C +import qualified GHC.ForeignPtr as GF +import OpenSSL.Utils +import System.IO.Unsafe + +{- bio ---------------------------------------------------------------------- -} + +data BIO_METHOD + +-- |@BIO@ is a @ForeignPtr@ to an opaque BIO object. They are created by newXXX actions. +newtype BIO = BIO (ForeignPtr BIO_) +data BIO_ + +foreign import ccall unsafe "BIO_new" + _new :: Ptr BIO_METHOD -> IO (Ptr BIO_) + +foreign import ccall unsafe "&BIO_free" + _free :: FunPtr (Ptr BIO_ -> IO ()) + +foreign import ccall unsafe "BIO_push" + _push :: Ptr BIO_ -> Ptr BIO_ -> IO (Ptr BIO_) + +foreign import ccall unsafe "HsOpenSSL_BIO_set_flags" + _set_flags :: Ptr BIO_ -> Int -> IO () + +foreign import ccall unsafe "HsOpenSSL_BIO_should_retry" + _should_retry :: Ptr BIO_ -> IO Int + + +new :: Ptr BIO_METHOD -> IO BIO +new method + = _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 する。參照カウント方式ではないから循環參照 +-- しても問題無い。 + +-- |Computation of @'bioPush' a b@ connects @b@ behind @a@. +-- +-- Example: +-- +-- > do b64 <- newBase64 True +-- > mem <- newMem +-- > bioPush b64 mem +-- > +-- > -- Encode some text in Base64 and write the result to the +-- > -- memory buffer. +-- > bioWrite b64 "Hello, world!" +-- > bioFlush b64 +-- > +-- > -- Then dump the memory buffer. +-- > bioRead mem >>= putStrLn +-- +bioPush :: BIO -> BIO -> IO () +bioPush (BIO a) (BIO b) + = withForeignPtr a $ \ aPtr -> + withForeignPtr b $ \ bPtr -> + do _push aPtr bPtr + GF.addForeignPtrConcFinalizer a $ touchForeignPtr b + GF.addForeignPtrConcFinalizer b $ touchForeignPtr a + return () + +-- |@a '==>' b@ is an alias to @'bioPush' a b@. +(==>) :: BIO -> BIO -> IO () +(==>) = bioPush + +-- |@a '<==' b@ is an alias to @'bioPush' b a@. +(<==) :: BIO -> BIO -> IO () +(<==) = flip bioPush + + +-- |@'bioJoin' [bio1, bio2, ..]@ connects many BIOs at once. +bioJoin :: [BIO] -> IO () +bioJoin [] = return () +bioJoin (_:[]) = return () +bioJoin (a:b:xs) = bioPush a b >> bioJoin (b:xs) + + +setFlags :: BIO -> Int -> IO () +setFlags bio flags + = withBioPtr bio $ \ bioPtr -> + _set_flags bioPtr flags + +bioShouldRetry :: BIO -> IO Bool +bioShouldRetry bio + = withBioPtr bio $ \ bioPtr -> + _should_retry bioPtr >>= return . (/= 0) + + +{- ctrl --------------------------------------------------------------------- -} + +foreign import ccall unsafe "HsOpenSSL_BIO_flush" + _flush :: Ptr BIO_ -> IO Int + +foreign import ccall unsafe "HsOpenSSL_BIO_reset" + _reset :: Ptr BIO_ -> IO Int + +foreign import ccall unsafe "HsOpenSSL_BIO_eof" + _eof :: Ptr BIO_ -> IO Int + +-- |@'bioFlush' bio@ normally writes out any internally buffered data, +-- in some cases it is used to signal EOF and that no more data will +-- be written. +bioFlush :: BIO -> IO () +bioFlush bio + = withBioPtr bio $ \ bioPtr -> + _flush bioPtr >>= failIf (/= 1) >> return () + +-- |@'bioReset' bio@ typically resets a BIO to some initial state. +bioReset :: BIO -> IO () +bioReset bio + = withBioPtr bio $ \ bioPtr -> + _reset bioPtr >> return () -- BIO_reset の戻り値は全 BIO で共通で + -- ないのでエラーチェックが出來ない。 + +-- |@'bioEOF' bio@ returns 1 if @bio@ has read EOF, the precise +-- meaning of EOF varies according to the BIO type. +bioEOF :: BIO -> IO Bool +bioEOF bio + = withBioPtr bio $ \ bioPtr -> + _eof bioPtr >>= return . (== 1) + + +{- I/O ---------------------------------------------------------------------- -} + +foreign import ccall unsafe "BIO_read" + _read :: Ptr BIO_ -> Ptr CChar -> Int -> IO Int + +foreign import ccall unsafe "BIO_gets" + _gets :: Ptr BIO_ -> Ptr CChar -> Int -> IO Int + +foreign import ccall unsafe "BIO_write" + _write :: Ptr BIO_ -> Ptr CChar -> Int -> IO Int + +-- |@'bioRead' bio@ lazily reads all data in @bio@. +bioRead :: BIO -> IO String +bioRead bio + = liftM L8.unpack $ bioReadLBS bio + +-- |@'bioReadBS' bio len@ attempts to read @len@ bytes from @bio@, +-- then return a ByteString. The actual length of result may be less +-- than @len@. +bioReadBS :: BIO -> Int -> IO ByteString +bioReadBS bio maxLen + = withBioPtr bio $ \ bioPtr -> + createAndTrim maxLen $ \ bufPtr -> + _read bioPtr (castPtr bufPtr) maxLen >>= interpret + where + interpret :: Int -> IO Int + interpret n + | n == 0 = return 0 + | n == -1 = return 0 + | n < -1 = raiseOpenSSLError + | otherwise = return n + +-- |@'bioReadLBS' bio@ lazily reads all data in @bio@, then return a +-- LazyByteString. +bioReadLBS :: BIO -> IO LazyByteString +bioReadLBS bio = lazyRead >>= return . LPS + where + chunkSize = 32 * 1024 + + lazyRead = unsafeInterleaveIO loop + + loop = do bs <- bioReadBS bio chunkSize + if B8.null bs then + do isEOF <- bioEOF bio + if isEOF then + return [] + else + do shouldRetry <- bioShouldRetry bio + if shouldRetry then + loop + else + fail "bioReadLBS: got null but isEOF=False, shouldRetry=False" + else + do bss <- lazyRead + return (bs:bss) + +-- |@'bioGets' bio len@ normally attempts to read one line of data +-- from @bio@ of maximum length @len@. There are exceptions to this +-- however, for example 'bioGets' on a digest BIO will calculate and +-- return the digest and other BIOs may not support 'bioGets' at all. +bioGets :: BIO -> Int -> IO String +bioGets bio maxLen + = liftM B8.unpack (bioGetsBS bio maxLen) + +-- |'bioGetsBS' does the same as 'bioGets' but returns ByteString. +bioGetsBS :: BIO -> Int -> IO ByteString +bioGetsBS bio maxLen + = withBioPtr bio $ \ bioPtr -> + createAndTrim maxLen $ \ bufPtr -> + _gets bioPtr (castPtr bufPtr) maxLen >>= interpret + where + interpret :: Int -> IO Int + interpret n + | n == 0 = return 0 + | n == -1 = return 0 + | n < -1 = raiseOpenSSLError + | otherwise = return n + +-- |'bioGetsLBS' does the same as 'bioGets' but returns +-- LazyByteString. +bioGetsLBS :: BIO -> Int -> IO LazyByteString +bioGetsLBS bio maxLen + = bioGetsBS bio maxLen >>= \ bs -> (return . LPS) [bs] + +-- |@'bioWrite' bio str@ lazily writes entire @str@ to @bio@. The +-- string doesn't necessarily have to be finite. +bioWrite :: BIO -> String -> IO () +bioWrite bio str + = (return . L8.pack) str >>= bioWriteLBS bio + +-- |@'bioWriteBS' bio bs@ writes @bs@ to @bio@. +bioWriteBS :: BIO -> ByteString -> IO () +bioWriteBS bio bs + = withBioPtr bio $ \ bioPtr -> + unsafeUseAsCStringLen bs $ \ (buf, len) -> + _write bioPtr buf len >>= interpret + where + interpret :: Int -> IO () + interpret n + | n == B8.length bs = return () + | n == -1 = bioWriteBS bio bs -- full retry + | n < -1 = raiseOpenSSLError + | otherwise = bioWriteBS bio (B8.drop n bs) -- partial retry + +-- |@'bioWriteLBS' bio lbs@ lazily writes entire @lbs@ to @bio@. The +-- string doesn't necessarily have to be finite. +bioWriteLBS :: BIO -> LazyByteString -> IO () +bioWriteLBS bio (LPS chunks) + = mapM_ (bioWriteBS bio) chunks + + +{- base64 ------------------------------------------------------------------- -} + +foreign import ccall unsafe "BIO_f_base64" + f_base64 :: IO (Ptr BIO_METHOD) + +foreign import ccall unsafe "HsOpenSSL_BIO_FLAGS_BASE64_NO_NL" + _FLAGS_BASE64_NO_NL :: Int + +-- |@'newBase64' noNL@ creates a Base64 BIO filter. This is a filter +-- bio that base64 encodes any data written through it and decodes any +-- data read through it. +-- +-- If @noNL@ flag is True, the filter encodes the data all on one line +-- or expects the data to be all on one line. +-- +-- Base64 BIOs do not support 'bioGets'. +-- +-- 'bioFlush' on a Base64 BIO that is being written through is used to +-- signal that no more data is to be encoded: this is used to flush +-- the final block through the BIO. +newBase64 :: Bool -> IO BIO +newBase64 noNL + = do bio <- new =<< f_base64 + when noNL $ setFlags bio _FLAGS_BASE64_NO_NL + return bio + + +{- buffer ------------------------------------------------------------------- -} + +foreign import ccall unsafe "BIO_f_buffer" + f_buffer :: IO (Ptr BIO_METHOD) + +foreign import ccall unsafe "HsOpenSSL_BIO_set_buffer_size" + _set_buffer_size :: Ptr BIO_ -> Int -> IO Int + + +-- |@'newBuffer' mBufSize@ creates a buffering BIO filter. Data +-- written to a buffering BIO is buffered and periodically written to +-- the next BIO in the chain. Data read from a buffering BIO comes +-- from the next BIO in the chain. +-- +-- Buffering BIOs support 'bioGets'. +-- +-- Calling 'bioReset' on a buffering BIO clears any buffered data. +-- +-- Question: When I created a BIO chain like this and attempted to +-- read from the buf, the buffering BIO weirdly behaved: BIO_read() +-- returned nothing, but both BIO_eof() and BIO_should_retry() +-- returned zero. I tried to examine the source code of +-- crypto\/bio\/bf_buff.c but it was too complicated to +-- understand. Does anyone know why this happens? The version of +-- OpenSSL was 0.9.7l. +-- +-- > main = withOpenSSL $ +-- > do mem <- newConstMem "Hello, world!" +-- > buf <- newBuffer Nothing +-- > mem ==> buf +-- > +-- > bioRead buf >>= putStrLn -- This fails, but why? +-- +-- I am being depressed for this unaccountable failure. +-- +newBuffer :: Maybe Int -- ^ Explicit buffer size (@Just n@) or the + -- default size (@Nothing@). + -> IO BIO +newBuffer bufSize + = do bio <- new =<< f_buffer + case bufSize of + Just n -> withBioPtr bio $ \ bioPtr -> + _set_buffer_size bioPtr n + >>= failIf (/= 1) >> return () + Nothing -> return () + return bio + + +{- mem ---------------------------------------------------------------------- -} + +foreign import ccall unsafe "BIO_s_mem" + s_mem :: IO (Ptr BIO_METHOD) + +foreign import ccall unsafe "BIO_new_mem_buf" + _new_mem_buf :: Ptr CChar -> Int -> IO (Ptr BIO_) + + +-- |@'newMem'@ creates a memory BIO sink\/source. Any data written to +-- a memory BIO can be recalled by reading from it. Unless the memory +-- BIO is read only any data read from it is deleted from the BIO. +-- +-- Memory BIOs support 'bioGets'. +-- +-- Calling 'bioReset' on a erad write memory BIO clears any data in +-- it. On a read only BIO it restores the BIO to its original state +-- and the read only data can be read again. +-- +-- 'bioEOF' is true if no data is in the BIO. +-- +-- Every read from a read write memory BIO will remove the data just +-- read with an internal copy operation, if a BIO contains a lots of +-- data and it is read in small chunks the operation can be very +-- slow. The use of a read only memory BIO avoids this problem. If the +-- BIO must be read write then adding a buffering BIO ('newBuffer') to +-- the chain will speed up the process. +newMem :: IO BIO +newMem = s_mem >>= new + +-- |@'newConstMem' str@ creates a read-only memory BIO source. +newConstMem :: String -> IO BIO +newConstMem str + = (return . B8.pack) str >>= newConstMemBS + +-- |@'newConstMemBS' bs@ is like 'newConstMem' but takes a ByteString. +newConstMemBS :: ByteString -> IO BIO +newConstMemBS bs + = let (foreignBuf, off, len) = toForeignPtr bs + in + -- ByteString への參照を BIO の finalizer に持たせる。 + withForeignPtr foreignBuf $ \ buf -> + do bioPtr <- _new_mem_buf (castPtr $ buf `plusPtr` off) len + >>= failIfNull + + bio <- newForeignPtr _free bioPtr + GF.addForeignPtrConcFinalizer bio $ touchForeignPtr foreignBuf + + return $ BIO bio + +-- |@'newConstMemLBS' lbs@ is like 'newConstMem' but takes a +-- LazyByteString. +newConstMemLBS :: LazyByteString -> IO BIO +newConstMemLBS (LPS bss) + = (return . B8.concat) bss >>= newConstMemBS + +{- null --------------------------------------------------------------------- -} + +foreign import ccall unsafe "BIO_s_null" + s_null :: IO (Ptr BIO_METHOD) + +-- |@'newNullBIO'@ creates a null BIO sink\/source. Data written to +-- the null sink is discarded, reads return EOF. +-- +-- A null sink is useful if, for example, an application wishes to +-- digest some data by writing through a digest bio but not send the +-- digested data anywhere. Since a BIO chain must normally include a +-- source\/sink BIO this can be achieved by adding a null sink BIO to +-- the end of the chain. +newNullBIO :: IO BIO +newNullBIO = s_null >>= new diff --git a/OpenSSL/BIO.hsc b/OpenSSL/BIO.hsc --- a/OpenSSL/BIO.hsc +++ b/OpenSSL/BIO.hsc @@ -72,7 +72,8 @@ where import Control.Monad -import Data.ByteString.Base +import Data.ByteString.Internal (createAndTrim, toForeignPtr) +import Data.ByteString.Unsafe (unsafeUseAsCStringLen) import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Lazy.Char8 as L8 import Foreign hiding (new) @@ -233,7 +234,7 @@ -- |@'bioReadBS' bio len@ attempts to read @len@ bytes from @bio@, -- then return a ByteString. The actual length of result may be less -- than @len@. -bioReadBS :: BIO -> Int -> IO ByteString +bioReadBS :: BIO -> Int -> IO B8.ByteString bioReadBS bio maxLen = withBioPtr bio $ \ bioPtr -> createAndTrim maxLen $ \ bufPtr -> @@ -248,8 +249,8 @@ -- |@'bioReadLBS' bio@ lazily reads all data in @bio@, then return a -- LazyByteString. -bioReadLBS :: BIO -> IO LazyByteString -bioReadLBS bio = lazyRead >>= return . LPS +bioReadLBS :: BIO -> IO L8.ByteString +bioReadLBS bio = lazyRead >>= return . L8.fromChunks where chunkSize = 32 * 1024 @@ -279,7 +280,7 @@ = liftM B8.unpack (bioGetsBS bio maxLen) -- |'bioGetsBS' does the same as 'bioGets' but returns ByteString. -bioGetsBS :: BIO -> Int -> IO ByteString +bioGetsBS :: BIO -> Int -> IO B8.ByteString bioGetsBS bio maxLen = withBioPtr bio $ \ bioPtr -> createAndTrim maxLen $ \ bufPtr -> @@ -294,9 +295,9 @@ -- |'bioGetsLBS' does the same as 'bioGets' but returns -- LazyByteString. -bioGetsLBS :: BIO -> Int -> IO LazyByteString +bioGetsLBS :: BIO -> Int -> IO L8.ByteString bioGetsLBS bio maxLen - = bioGetsBS bio maxLen >>= \ bs -> (return . LPS) [bs] + = bioGetsBS bio maxLen >>= \ bs -> (return . L8.fromChunks) [bs] -- |@'bioWrite' bio str@ lazily writes entire @str@ to @bio@. The -- string doesn't necessarily have to be finite. @@ -305,7 +306,7 @@ = (return . L8.pack) str >>= bioWriteLBS bio -- |@'bioWriteBS' bio bs@ writes @bs@ to @bio@. -bioWriteBS :: BIO -> ByteString -> IO () +bioWriteBS :: BIO -> B8.ByteString -> IO () bioWriteBS bio bs = withBioPtr bio $ \ bioPtr -> unsafeUseAsCStringLen bs $ \ (buf, len) -> @@ -320,9 +321,9 @@ -- |@'bioWriteLBS' bio lbs@ lazily writes entire @lbs@ to @bio@. The -- string doesn't necessarily have to be finite. -bioWriteLBS :: BIO -> LazyByteString -> IO () -bioWriteLBS bio (LPS chunks) - = mapM_ (bioWriteBS bio) chunks +bioWriteLBS :: BIO -> L8.ByteString -> IO () +bioWriteLBS bio lbs + = mapM_ (bioWriteBS bio) $ L8.toChunks lbs {- base64 ------------------------------------------------------------------- -} @@ -436,7 +437,7 @@ = (return . B8.pack) str >>= newConstMemBS -- |@'newConstMemBS' bs@ is like 'newConstMem' but takes a ByteString. -newConstMemBS :: ByteString -> IO BIO +newConstMemBS :: B8.ByteString -> IO BIO newConstMemBS bs = let (foreignBuf, off, len) = toForeignPtr bs in @@ -452,9 +453,9 @@ -- |@'newConstMemLBS' lbs@ is like 'newConstMem' but takes a -- LazyByteString. -newConstMemLBS :: LazyByteString -> IO BIO -newConstMemLBS (LPS bss) - = (return . B8.concat) bss >>= newConstMemBS +newConstMemLBS :: L8.ByteString -> IO BIO +newConstMemLBS lbs + = (return . B8.concat . L8.toChunks) lbs >>= newConstMemBS {- null --------------------------------------------------------------------- -} diff --git a/OpenSSL/BN.hs b/OpenSSL/BN.hs new file mode 100644 --- /dev/null +++ b/OpenSSL/BN.hs @@ -0,0 +1,354 @@ +{-# OPTIONS_GHC -optc-D__GLASGOW_HASKELL__=606 #-} +{-# INCLUDE "HsOpenSSL.h" #-} +{-# LINE 1 "OpenSSL/BN.hsc" #-} + +{-# LINE 2 "OpenSSL/BN.hsc" #-} + +-- #prune + +-- |BN - multiprecision integer arithmetics + +module OpenSSL.BN + ( -- * Type + BigNum + , BIGNUM + + -- * Allocation + , allocaBN + , withBN + + , newBN + , wrapBN -- private + , unwrapBN -- private + + -- * Conversion from\/to Integer + , peekBN + +{-# LINE 23 "OpenSSL/BN.hsc" #-} + , integerToBN + , bnToInteger + +{-# LINE 26 "OpenSSL/BN.hsc" #-} + , integerToMPI + , mpiToInteger + + -- * Computation + , modexp + + -- * Random number generation + , randIntegerUptoNMinusOneSuchThat + , prandIntegerUptoNMinusOneSuchThat + , randIntegerZeroToNMinusOne + , prandIntegerZeroToNMinusOne + , randIntegerOneToNMinusOne + , prandIntegerOneToNMinusOne + ) + where + +import Control.Exception +import Foreign +import qualified Data.ByteString as BS +import OpenSSL.Utils + + +{-# LINE 51 "OpenSSL/BN.hsc" #-} +import Foreign.C.Types +import Data.Word (Word32) +import GHC.Base +import GHC.Num +import GHC.Prim +import GHC.IOBase (IO(..)) + +{-# LINE 58 "OpenSSL/BN.hsc" #-} + +-- |'BigNum' is an opaque object representing a big number. +newtype BigNum = BigNum (Ptr BIGNUM) +data BIGNUM + + +foreign import ccall unsafe "BN_new" + _new :: IO (Ptr BIGNUM) + +foreign import ccall unsafe "BN_free" + _free :: Ptr BIGNUM -> IO () + +-- |@'allocaBN' f@ allocates a 'BigNum' and computes @f@. Then it +-- frees the 'BigNum'. +allocaBN :: (BigNum -> IO a) -> IO a +allocaBN m + = bracket _new _free (m . wrapBN) + + +unwrapBN :: BigNum -> Ptr BIGNUM +unwrapBN (BigNum p) = p + + +wrapBN :: Ptr BIGNUM -> BigNum +wrapBN = BigNum + + + +{-# LINE 130 "OpenSSL/BN.hsc" #-} + +{- fast, dangerous functions ------------------------------------------------ -} + +-- Both BN (the OpenSSL library) and GMP (used by GHC) use the same internal +-- representation for numbers: an array of words, least-significant first. Thus +-- we can move from Integer's to BIGNUMs very quickly: by copying in the worst +-- case and by just alloca'ing and pointing into the Integer in the fast case. +-- Note that, in the fast case, it's very important that any foreign function +-- calls be "unsafe", that is, they don't call back into Haskell. Otherwise the +-- GC could do nasty things to the data which we thought that we had a pointer +-- to + +foreign import ccall unsafe "memcpy" + _copy_in :: ByteArray# -> Ptr () -> CSize -> IO () + +foreign import ccall unsafe "memcpy" + _copy_out :: Ptr () -> ByteArray# -> CSize -> IO () + +-- These are taken from Data.Binary's disabled fast Integer support +data ByteArray = BA {-# UNPACK #-} !ByteArray# +data MBA = MBA {-# UNPACK #-} !(MutableByteArray# RealWorld) + +newByteArray :: Int# -> IO MBA +newByteArray sz = IO $ \s -> + case newByteArray# sz s of { (# s', arr #) -> + (# s', MBA arr #) } + +freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray +freezeByteArray arr = IO $ \s -> + case unsafeFreezeByteArray# arr s of { (# s', arr' #) -> + (# s', BA arr' #) } + +-- | Convert a BIGNUM to an Integer +bnToInteger :: BigNum -> IO Integer +bnToInteger bn = do + nlimbs <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) (unwrapBN bn) :: IO CSize +{-# LINE 166 "OpenSSL/BN.hsc" #-} + case nlimbs of + 0 -> return 0 + 1 -> do (I# i) <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) (unwrapBN bn) >>= peek +{-# LINE 169 "OpenSSL/BN.hsc" #-} + negative <- ((\hsc_ptr -> peekByteOff hsc_ptr 12)) (unwrapBN bn) :: IO Word32 +{-# LINE 170 "OpenSSL/BN.hsc" #-} + if negative == 0 + then return $ S# i + else return $ 0 - (S# i) + otherwise -> do + let (I# nlimbsi) = fromIntegral nlimbs + (I# limbsize) = ((4)) +{-# LINE 176 "OpenSSL/BN.hsc" #-} + (MBA arr) <- newByteArray (nlimbsi *# limbsize) + (BA ba) <- freezeByteArray arr + limbs <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) (unwrapBN bn) +{-# LINE 179 "OpenSSL/BN.hsc" #-} + _copy_in ba limbs $ fromIntegral $ nlimbs * ((4)) +{-# LINE 180 "OpenSSL/BN.hsc" #-} + negative <- ((\hsc_ptr -> peekByteOff hsc_ptr 12)) (unwrapBN bn) :: IO Word32 +{-# LINE 181 "OpenSSL/BN.hsc" #-} + if negative == 0 + then return $ J# nlimbsi ba + else return $ 0 - (J# nlimbsi ba) + +-- | This is a GHC specific, fast conversion between Integers and OpenSSL +-- bignums. It returns a malloced BigNum. +integerToBN :: Integer -> IO BigNum +integerToBN 0 = do + bnptr <- mallocBytes ((20)) +{-# LINE 190 "OpenSSL/BN.hsc" #-} + ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) bnptr nullPtr +{-# LINE 191 "OpenSSL/BN.hsc" #-} + -- This is needed to give GHC enough type information + let one :: Word32 + one = 1 + zero :: Word32 + zero = 0 + ((\hsc_ptr -> pokeByteOff hsc_ptr 16)) bnptr one +{-# LINE 197 "OpenSSL/BN.hsc" #-} + ((\hsc_ptr -> pokeByteOff hsc_ptr 4)) bnptr zero +{-# LINE 198 "OpenSSL/BN.hsc" #-} + ((\hsc_ptr -> pokeByteOff hsc_ptr 8)) bnptr zero +{-# LINE 199 "OpenSSL/BN.hsc" #-} + ((\hsc_ptr -> pokeByteOff hsc_ptr 12)) bnptr zero +{-# LINE 200 "OpenSSL/BN.hsc" #-} + return (wrapBN bnptr) + +integerToBN (S# v) = do + bnptr <- mallocBytes ((20)) +{-# LINE 204 "OpenSSL/BN.hsc" #-} + limbs <- malloc :: IO (Ptr Word32) + poke limbs $ fromIntegral $ abs $ I# v + ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) bnptr limbs +{-# LINE 207 "OpenSSL/BN.hsc" #-} + -- This is needed to give GHC enough type information since #poke just + -- uses an offset + let one :: Word32 + one = 1 + ((\hsc_ptr -> pokeByteOff hsc_ptr 16)) bnptr one +{-# LINE 212 "OpenSSL/BN.hsc" #-} + ((\hsc_ptr -> pokeByteOff hsc_ptr 4)) bnptr one +{-# LINE 213 "OpenSSL/BN.hsc" #-} + ((\hsc_ptr -> pokeByteOff hsc_ptr 8)) bnptr one +{-# LINE 214 "OpenSSL/BN.hsc" #-} + ((\hsc_ptr -> pokeByteOff hsc_ptr 12)) bnptr (if (I# v) < 0 then one else 0) +{-# LINE 215 "OpenSSL/BN.hsc" #-} + return (wrapBN bnptr) + +integerToBN v@(J# nlimbs_ bytearray) + | v >= 0 = do + let nlimbs = (I# nlimbs_) + bnptr <- mallocBytes ((20)) +{-# LINE 221 "OpenSSL/BN.hsc" #-} + limbs <- mallocBytes (((4)) * nlimbs) +{-# LINE 222 "OpenSSL/BN.hsc" #-} + ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) bnptr limbs +{-# LINE 223 "OpenSSL/BN.hsc" #-} + ((\hsc_ptr -> pokeByteOff hsc_ptr 16)) bnptr (1 :: Word32) +{-# LINE 224 "OpenSSL/BN.hsc" #-} + _copy_out limbs bytearray (fromIntegral $ ((4)) * nlimbs) +{-# LINE 225 "OpenSSL/BN.hsc" #-} + ((\hsc_ptr -> pokeByteOff hsc_ptr 4)) bnptr ((fromIntegral nlimbs) :: Word32) +{-# LINE 226 "OpenSSL/BN.hsc" #-} + ((\hsc_ptr -> pokeByteOff hsc_ptr 8)) bnptr ((fromIntegral nlimbs) :: Word32) +{-# LINE 227 "OpenSSL/BN.hsc" #-} + ((\hsc_ptr -> pokeByteOff hsc_ptr 12)) bnptr (0 :: Word32) +{-# LINE 228 "OpenSSL/BN.hsc" #-} + return (wrapBN bnptr) + | otherwise = do bnptr <- integerToBN (0-v) + ((\hsc_ptr -> pokeByteOff hsc_ptr 12)) (unwrapBN bnptr) (1 :: Word32) +{-# LINE 231 "OpenSSL/BN.hsc" #-} + return bnptr + +-- TODO: we could make a function which doesn't even allocate BN data if we +-- wanted to be very fast and dangerout. The BIGNUM could point right into the +-- Integer's data. However, I'm not sure about the semantics of the GC; which +-- might move the Integer data around. + +-- |@'withBN' n f@ converts n to a 'BigNum' and computes @f@. Then it +-- frees the 'BigNum'. +withBN :: Integer -> (BigNum -> IO a) -> IO a +withBN dec m = bracket (integerToBN dec) (_free . unwrapBN) m + +-- |This is an alias to 'bnToInteger'. +peekBN :: BigNum -> IO Integer +peekBN = bnToInteger + +-- |This is an alias to 'integerToBN'. +newBN :: Integer -> IO BigNum +newBN = integerToBN + +foreign import ccall unsafe "BN_bn2mpi" + _bn2mpi :: Ptr BIGNUM -> Ptr CChar -> IO CInt + +foreign import ccall unsafe "BN_mpi2bn" + _mpi2bn :: Ptr CChar -> CInt -> Ptr BIGNUM -> IO (Ptr BIGNUM) + + +{-# LINE 258 "OpenSSL/BN.hsc" #-} + +-- | Convert a BigNum to an MPI: a serialisation of large ints which has a +-- 4-byte, big endian length followed by the bytes of the number in +-- most-significant-first order. +bnToMPI :: BigNum -> IO BS.ByteString +bnToMPI bn = do + bytes <- _bn2mpi (unwrapBN bn) nullPtr + allocaBytes (fromIntegral bytes) (\buffer -> do + _bn2mpi (unwrapBN bn) buffer + BS.copyCStringLen (buffer, fromIntegral bytes)) + +-- | Convert an MPI into a BigNum. See bnToMPI for details of the format +mpiToBN :: BS.ByteString -> IO BigNum +mpiToBN mpi = do + BS.useAsCStringLen mpi (\(ptr, len) -> do + _mpi2bn ptr (fromIntegral len) nullPtr) >>= return . wrapBN + +-- | Convert an Integer to an MPI. SEe bnToMPI for the format +integerToMPI :: Integer -> IO BS.ByteString +integerToMPI v = bracket (integerToBN v) (_free . unwrapBN) bnToMPI + +-- | Convert an MPI to an Integer. SEe bnToMPI for the format +mpiToInteger :: BS.ByteString -> IO Integer +mpiToInteger mpi = do + bn <- mpiToBN mpi + v <- bnToInteger bn + _free (unwrapBN bn) + return v + +foreign import ccall unsafe "BN_mod_exp" + _mod_exp :: Ptr BIGNUM -> Ptr BIGNUM -> Ptr BIGNUM -> Ptr BIGNUM -> BNCtx -> IO (Ptr BIGNUM) + +type BNCtx = Ptr BNCTX +data BNCTX = BNCTX + +foreign import ccall unsafe "BN_CTX_new" + _BN_ctx_new :: IO BNCtx + +foreign import ccall unsafe "BN_CTX_free" + _BN_ctx_free :: BNCtx -> IO () + +withBNCtx :: (BNCtx -> IO a) -> IO a +withBNCtx f = bracket _BN_ctx_new _BN_ctx_free f + +-- |@'modexp' a p m@ computes @a@ to the @p@-th power modulo @m@. +modexp :: Integer -> Integer -> Integer -> Integer +modexp a p m = unsafePerformIO (do + withBN a (\bnA -> (do + withBN p (\bnP -> (do + withBN m (\bnM -> (do + withBNCtx (\ctx -> (do + r <- newBN 0 + _mod_exp (unwrapBN r) (unwrapBN bnA) (unwrapBN bnP) (unwrapBN bnM) ctx + bnToInteger r >>= return))))))))) + +{- Random Integer generation ------------------------------------------------ -} + +foreign import ccall unsafe "BN_rand_range" + _BN_rand_range :: Ptr BIGNUM -> Ptr BIGNUM -> IO CInt + +foreign import ccall unsafe "BN_pseudo_rand_range" + _BN_pseudo_rand_range :: Ptr BIGNUM -> Ptr BIGNUM -> IO CInt + +-- | Return a strongly random number in the range 0 <= x < n where the given +-- filter function returns true. +randIntegerUptoNMinusOneSuchThat :: (Integer -> Bool) -- ^ a filter function + -> Integer -- ^ one plus the upper limit + -> IO Integer +randIntegerUptoNMinusOneSuchThat f range = withBN range (\bnRange -> (do + r <- newBN 0 + let try = do + _BN_rand_range (unwrapBN r) (unwrapBN bnRange) >>= failIf (/= 1) + i <- bnToInteger r + if f i + then return i + else try + try)) + +-- | Return a random number in the range 0 <= x < n where the given +-- filter function returns true. +prandIntegerUptoNMinusOneSuchThat :: (Integer -> Bool) -- ^ a filter function + -> Integer -- ^ one plus the upper limit + -> IO Integer +prandIntegerUptoNMinusOneSuchThat f range = withBN range (\bnRange -> (do + r <- newBN 0 + let try = do + _BN_rand_range (unwrapBN r) (unwrapBN bnRange) >>= failIf (/= 1) + i <- bnToInteger r + if f i + then return i + else try + try)) + +-- | Return a strongly random number in the range 0 <= x < n +randIntegerZeroToNMinusOne :: Integer -> IO Integer +randIntegerZeroToNMinusOne = randIntegerUptoNMinusOneSuchThat (const True) +-- | Return a strongly random number in the range 0 < x < n +randIntegerOneToNMinusOne :: Integer -> IO Integer +randIntegerOneToNMinusOne = randIntegerUptoNMinusOneSuchThat (/= 0) + +-- | Return a random number in the range 0 <= x < n +prandIntegerZeroToNMinusOne :: Integer -> IO Integer +prandIntegerZeroToNMinusOne = prandIntegerUptoNMinusOneSuchThat (const True) +-- | Return a random number in the range 0 < x < n +prandIntegerOneToNMinusOne :: Integer -> IO Integer +prandIntegerOneToNMinusOne = prandIntegerUptoNMinusOneSuchThat (/= 0) diff --git a/OpenSSL/BN.hsc b/OpenSSL/BN.hsc --- a/OpenSSL/BN.hsc +++ b/OpenSSL/BN.hsc @@ -1,3 +1,5 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + #include "HsOpenSSL.h" -- #prune @@ -39,7 +41,7 @@ ) where -import Control.Exception +import Control.Exception hiding (try) import Foreign import qualified Data.ByteString as BS import OpenSSL.Utils @@ -170,7 +172,7 @@ if negative == 0 then return $ S## i else return $ 0 - (S## i) - otherwise -> do + _ -> do let (I## nlimbsi) = fromIntegral nlimbs (I## limbsize) = (#size unsigned long) (MBA arr) <- newByteArray (nlimbsi *## limbsize) @@ -264,7 +266,7 @@ bytes <- _bn2mpi (unwrapBN bn) nullPtr allocaBytes (fromIntegral bytes) (\buffer -> do _bn2mpi (unwrapBN bn) buffer - BS.copyCStringLen (buffer, fromIntegral bytes)) + BS.packCStringLen (buffer, fromIntegral bytes)) -- | Convert an MPI into a BigNum. See bnToMPI for details of the format mpiToBN :: BS.ByteString -> IO BigNum @@ -288,7 +290,7 @@ _mod_exp :: Ptr BIGNUM -> Ptr BIGNUM -> Ptr BIGNUM -> Ptr BIGNUM -> BNCtx -> IO (Ptr BIGNUM) type BNCtx = Ptr BNCTX -data BNCTX = BNCTX +data BNCTX foreign import ccall unsafe "BN_CTX_new" _BN_ctx_new :: IO BNCtx diff --git a/OpenSSL/Cipher.hs b/OpenSSL/Cipher.hs new file mode 100644 --- /dev/null +++ b/OpenSSL/Cipher.hs @@ -0,0 +1,123 @@ +{-# OPTIONS_GHC -optc-D__GLASGOW_HASKELL__=606 #-} +{-# INCLUDE "HsOpenSSL.h" #-} +{-# INCLUDE "openssl/aes.h" #-} +{-# LINE 1 "OpenSSL/Cipher.hsc" #-} + +{-# LINE 2 "OpenSSL/Cipher.hsc" #-} + +{-# LINE 3 "OpenSSL/Cipher.hsc" #-} + +-- | This module interfaces to some of the OpenSSL ciphers without using +-- EVP (see OpenSSL.EVP.Cipher). The EVP ciphers are easier to use, +-- however, in some cases you cannot do without using the OpenSSL +-- fuctions directly. +-- +-- One of these cases (and the motivating example +-- for this module) is that the EVP CBC functions try to encode the +-- length of the input string in the output (thus hiding the fact that the +-- cipher is, in fact, block based and needs padding). This means that the +-- EVP CBC functions cannot, in some cases, interface with other users +-- which don't use that system (like SSH). +module OpenSSL.Cipher + ( Mode(..) + , newAESCtx + , aesCBC + , aesCTR) + where + +import Control.Monad (when) +import Data.IORef +import Foreign +import Foreign.C.Types +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base as BSB +import OpenSSL.Utils + +data Mode = Encrypt | Decrypt deriving (Eq, Show) + +modeToInt Encrypt = 1 +modeToInt Decrypt = 0 + +data AES_KEY +data AESCtx = AESCtx + (ForeignPtr AES_KEY) -- the key schedule + (ForeignPtr CUChar) -- the IV / counter + (ForeignPtr CUChar) -- the encrypted counter (CTR mode) + (IORef CUInt) -- the number of bytes of the encrypted counter used + Mode + +foreign import ccall unsafe "memcpy" + _memcpy :: Ptr CUChar -> Ptr CChar -> CSize -> IO () + +foreign import ccall unsafe "memset" + _memset :: Ptr CUChar -> CChar -> CSize -> IO () + +foreign import ccall unsafe "AES_set_encrypt_key" + _AES_set_encrypt_key :: Ptr CChar -> CInt -> Ptr AES_KEY -> IO CInt +foreign import ccall unsafe "AES_set_decrypt_key" + _AES_set_decrypt_key :: Ptr CChar -> CInt -> Ptr AES_KEY -> IO CInt + +foreign import ccall unsafe "AES_cbc_encrypt" + _AES_cbc_encrypt :: Ptr CChar -> Ptr Word8 -> CULong -> Ptr AES_KEY -> Ptr CUChar -> CInt -> IO () + +foreign import ccall unsafe "AES_ctr128_encrypt" + _AES_ctr_encrypt :: Ptr CChar -> Ptr Word8 -> CULong -> Ptr AES_KEY -> Ptr CUChar -> Ptr CUChar -> Ptr CUInt -> IO () + +foreign import ccall unsafe "&free" + _free :: FunPtr (Ptr a -> IO ()) + +-- | Construct a new context which holds the key schedule and IV. +newAESCtx :: Mode -- ^ For CTR mode, this must always be Encrypt + -> BS.ByteString -- ^ Key: 128, 192 or 256 bits long + -> BS.ByteString -- ^ IV: 16 bytes long + -> IO AESCtx +newAESCtx mode key iv = do + let keyLen = BS.length key * 8 + when (not $ any ((==) keyLen) [128, 192, 256]) $ fail "Bad AES key length" + when (BS.length iv /= 16) $ fail "Bad AES128 iv length" + ctx <- mallocForeignPtrBytes ((244)) +{-# LINE 73 "OpenSSL/Cipher.hsc" #-} + withForeignPtr ctx $ \ctxPtr -> + BS.useAsCStringLen key (\(ptr, len) -> + case mode of + Encrypt -> _AES_set_encrypt_key ptr (fromIntegral keyLen) ctxPtr >>= failIf (/= 0) + Decrypt -> _AES_set_decrypt_key ptr (fromIntegral keyLen) ctxPtr >>= failIf (/= 0)) + ivbytes <- mallocForeignPtrBytes 16 + ecounter <- mallocForeignPtrBytes 16 + nref <- newIORef 0 + withForeignPtr ecounter (\ecptr -> _memset ecptr 0 16) + withForeignPtr ivbytes $ \ivPtr -> + BS.useAsCStringLen iv $ \(ptr, len) -> + do _memcpy ivPtr ptr 16 + return $ AESCtx ctx ivbytes ecounter nref mode + +-- | Encrypt some number of blocks using CBC. This is an IO function because +-- the context is destructivly updated. +aesCBC :: AESCtx -- ^ context + -> BS.ByteString -- ^ input, must be multiple of block size (16 bytes) + -> IO BS.ByteString +aesCBC (AESCtx ctx iv _ _ mode) input = do + when (BS.length input `mod` 16 /= 0) $ fail "Bad input length to aesCBC" + withForeignPtr ctx $ \ctxPtr -> + withForeignPtr iv $ \ivPtr -> + BS.useAsCStringLen input $ \(ptr, len) -> + BSB.create (BS.length input) $ \out -> + _AES_cbc_encrypt ptr out (fromIntegral len) ctxPtr ivPtr $ modeToInt mode + +-- | Encrypt some number of bytes using CTR mode. This is an IO function +-- because the context is destructivly updated. +aesCTR :: AESCtx -- ^ context + -> BS.ByteString -- ^ input, any number of bytes + -> IO BS.ByteString +aesCTR (AESCtx ctx iv ecounter nref Encrypt) input = do + withForeignPtr ctx $ \ctxPtr -> + withForeignPtr iv $ \ivPtr -> + withForeignPtr ecounter $ \ecptr -> + BS.useAsCStringLen input $ \(ptr, len) -> + BSB.create (BS.length input) $ \out -> + alloca $ \nptr -> do + n <- readIORef nref + poke nptr n + _AES_ctr_encrypt ptr out (fromIntegral len) ctxPtr ivPtr ecptr nptr + n' <- peek nptr + writeIORef nref n' diff --git a/OpenSSL/Cipher.hsc b/OpenSSL/Cipher.hsc --- a/OpenSSL/Cipher.hsc +++ b/OpenSSL/Cipher.hsc @@ -24,11 +24,12 @@ import Foreign import Foreign.C.Types import qualified Data.ByteString as BS -import qualified Data.ByteString.Base as BSB +import qualified Data.ByteString.Internal as BSI import OpenSSL.Utils data Mode = Encrypt | Decrypt deriving (Eq, Show) +modeToInt :: Num a => Mode -> a modeToInt Encrypt = 1 modeToInt Decrypt = 0 @@ -71,7 +72,7 @@ when (BS.length iv /= 16) $ fail "Bad AES128 iv length" ctx <- mallocForeignPtrBytes (#size AES_KEY) withForeignPtr ctx $ \ctxPtr -> - BS.useAsCStringLen key (\(ptr, len) -> + BS.useAsCStringLen key (\(ptr, _) -> case mode of Encrypt -> _AES_set_encrypt_key ptr (fromIntegral keyLen) ctxPtr >>= failIf (/= 0) Decrypt -> _AES_set_decrypt_key ptr (fromIntegral keyLen) ctxPtr >>= failIf (/= 0)) @@ -80,7 +81,7 @@ nref <- newIORef 0 withForeignPtr ecounter (\ecptr -> _memset ecptr 0 16) withForeignPtr ivbytes $ \ivPtr -> - BS.useAsCStringLen iv $ \(ptr, len) -> + BS.useAsCStringLen iv $ \(ptr, _) -> do _memcpy ivPtr ptr 16 return $ AESCtx ctx ivbytes ecounter nref mode @@ -94,7 +95,7 @@ withForeignPtr ctx $ \ctxPtr -> withForeignPtr iv $ \ivPtr -> BS.useAsCStringLen input $ \(ptr, len) -> - BSB.create (BS.length input) $ \out -> + BSI.create (BS.length input) $ \out -> _AES_cbc_encrypt ptr out (fromIntegral len) ctxPtr ivPtr $ modeToInt mode -- | Encrypt some number of bytes using CTR mode. This is an IO function @@ -102,12 +103,13 @@ aesCTR :: AESCtx -- ^ context -> BS.ByteString -- ^ input, any number of bytes -> IO BS.ByteString +aesCTR (AESCtx _ _ _ _ Decrypt) _ = fail "the context mode must be Encrypt" aesCTR (AESCtx ctx iv ecounter nref Encrypt) input = do withForeignPtr ctx $ \ctxPtr -> withForeignPtr iv $ \ivPtr -> withForeignPtr ecounter $ \ecptr -> BS.useAsCStringLen input $ \(ptr, len) -> - BSB.create (BS.length input) $ \out -> + BSI.create (BS.length input) $ \out -> alloca $ \nptr -> do n <- readIORef nref poke nptr n diff --git a/OpenSSL/DSA.hs b/OpenSSL/DSA.hs new file mode 100644 --- /dev/null +++ b/OpenSSL/DSA.hs @@ -0,0 +1,249 @@ +{-# OPTIONS_GHC -optc-D__GLASGOW_HASKELL__=606 #-} +{-# INCLUDE "HsOpenSSL.h" #-} +{-# LINE 1 "OpenSSL/DSA.hsc" #-} +{- -*- haskell -*- -} +{-# LINE 2 "OpenSSL/DSA.hsc" #-} + +-- #prune + +-- | The Digital Signature Algorithm (FIPS 186-2). +-- See + + +{-# LINE 9 "OpenSSL/DSA.hsc" #-} + +module OpenSSL.DSA + ( -- * Type + DSA + , DSA_ -- private + , withDSAPtr -- private + + -- * Key and parameter generation + , generateParameters + , generateKey + , generateParametersAndKey + + -- * Signing and verification + , signDigestedData + , verifyDigestedData + + -- * Extracting fields of DSA objects + , dsaP + , dsaQ + , dsaG + , dsaPrivate + , dsaPublic + , dsaToTuple + , tupleToDSA + ) where + +import Control.Monad +import Foreign +import Foreign.C (CString) +import Foreign.C.Types +import OpenSSL.BN +import OpenSSL.Utils +import qualified Data.ByteString as BS + +-- | The type of a DSA key, includes parameters p, q, g. +newtype DSA = DSA (ForeignPtr DSA_) + +data DSA_ + +foreign import ccall unsafe "&DSA_free" + _free :: FunPtr (Ptr DSA_ -> IO ()) + +foreign import ccall unsafe "DSA_free" + dsa_free :: Ptr DSA_ -> IO () + +foreign import ccall unsafe "BN_free" + _bn_free :: Ptr BIGNUM -> IO () + +foreign import ccall unsafe "DSA_new" + _dsa_new :: IO (Ptr DSA_) + +foreign import ccall unsafe "DSA_generate_key" + _dsa_generate_key :: Ptr DSA_ -> IO () + +foreign import ccall unsafe "HsOpenSSL_dsa_sign" + _dsa_sign :: Ptr DSA_ -> CString -> Int -> Ptr (Ptr BIGNUM) -> Ptr (Ptr BIGNUM) -> IO Int + +foreign import ccall unsafe "HsOpenSSL_dsa_verify" + _dsa_verify :: Ptr DSA_ -> CString -> Int -> Ptr BIGNUM -> Ptr BIGNUM -> IO Int + +withDSAPtr :: DSA -> (Ptr DSA_ -> IO a) -> IO a +withDSAPtr (DSA ptr) = withForeignPtr ptr + +foreign import ccall safe "DSA_generate_parameters" + _generate_params :: Int -> Ptr CChar -> Int -> Ptr CInt -> Ptr CInt -> Ptr () -> Ptr () -> IO (Ptr DSA_) + +peekDSA :: (Ptr DSA_ -> IO (Ptr BIGNUM)) -> DSA -> IO (Maybe Integer) +peekDSA peeker (DSA dsa) = do + withForeignPtr dsa (\ptr -> do + bn <- peeker ptr + if bn == nullPtr + then return Nothing + else peekBN (wrapBN bn) >>= return . Just) + +-- | Generate DSA parameters (*not* a key, but required for a key). This is a +-- compute intensive operation. See FIPS 186-2, app 2. This agrees with the +-- test vectors given in FIP 186-2, app 5 +generateParameters :: Int -- ^ The number of bits in the generated prime: 512 <= x <= 1024 + -> Maybe BS.ByteString -- ^ optional seed, its length must be 20 bytes + -> IO (Int, Int, Integer, Integer, Integer) -- ^ (iteration count, generator count, p, q, g) +generateParameters nbits mseed = do + when (nbits < 512 || nbits > 1024) $ fail "Invalid DSA bit size" + alloca (\i1 -> do + alloca (\i2 -> do + (\x -> case mseed of + Nothing -> x (nullPtr, 0) + Just seed -> BS.useAsCStringLen seed x) (\(seedptr, seedlen) -> do + ptr <- _generate_params nbits seedptr seedlen i1 i2 nullPtr nullPtr + failIfNull ptr + itcount <- peek i1 + gencount <- peek i2 + p <- ((\hsc_ptr -> peekByteOff hsc_ptr 12)) ptr >>= peekBN . wrapBN +{-# LINE 101 "OpenSSL/DSA.hsc" #-} + q <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) ptr >>= peekBN . wrapBN +{-# LINE 102 "OpenSSL/DSA.hsc" #-} + g <- ((\hsc_ptr -> peekByteOff hsc_ptr 20)) ptr >>= peekBN . wrapBN +{-# LINE 103 "OpenSSL/DSA.hsc" #-} + dsa_free ptr + return (fromIntegral itcount, fromIntegral gencount, p, q, g)))) + +{- +-- | This function just runs the example DSA generation, as given in FIP 186-2, +-- app 5. The return values should be: +-- (105, +-- "8df2a494492276aa3d25759bb06869cbeac0d83afb8d0cf7cbb8324f0d7882e5d0762fc5b7210 +-- eafc2e9adac32ab7aac49693dfbf83724c2ec0736ee31c80291", +-- "c773218c737ec8ee993b4f2ded30f48edace915f", +-- "626d027839ea0a13413163a55b4cb500299d5522956cefcb3bff10f399ce2c2e71cb9de5fa24 +-- babf58e5b79521925c9cc42e9f6f464b088cc572af53e6d78802"), as given at the bottom of +-- page 21 +test_generateParameters = do + let seed = BS.pack [0xd5, 0x01, 0x4e, 0x4b, + 0x60, 0xef, 0x2b, 0xa8, + 0xb6, 0x21, 0x1b, 0x40, + 0x62, 0xba, 0x32, 0x24, + 0xe0, 0x42, 0x7d, 0xd3] + (a, b, p, q, g) <- generateParameters 512 $ Just seed + return (a, toHex p, toHex q, g) +-} + +-- | Generate a new DSA key, given valid parameters +generateKey :: Integer -- ^ p + -> Integer -- ^ q + -> Integer -- ^ g + -> IO DSA +generateKey p q g = do + ptr <- _dsa_new + newBN p >>= return . unwrapBN >>= ((\hsc_ptr -> pokeByteOff hsc_ptr 12)) ptr +{-# LINE 134 "OpenSSL/DSA.hsc" #-} + newBN q >>= return . unwrapBN >>= ((\hsc_ptr -> pokeByteOff hsc_ptr 16)) ptr +{-# LINE 135 "OpenSSL/DSA.hsc" #-} + newBN g >>= return . unwrapBN >>= ((\hsc_ptr -> pokeByteOff hsc_ptr 20)) ptr +{-# LINE 136 "OpenSSL/DSA.hsc" #-} + _dsa_generate_key ptr + newForeignPtr _free ptr >>= return . DSA + +-- |Return the public prime number of the key. +dsaP :: DSA -> IO (Maybe Integer) +dsaP = peekDSA ((\hsc_ptr -> peekByteOff hsc_ptr 12)) +{-# LINE 142 "OpenSSL/DSA.hsc" #-} + +-- |Return the public 160-bit subprime, @q | p-1@ of the key. +dsaQ :: DSA -> IO (Maybe Integer) +dsaQ = peekDSA ((\hsc_ptr -> peekByteOff hsc_ptr 16)) +{-# LINE 146 "OpenSSL/DSA.hsc" #-} + +-- |Return the public generator of subgroup of the key. +dsaG :: DSA -> IO (Maybe Integer) +dsaG = peekDSA ((\hsc_ptr -> peekByteOff hsc_ptr 20)) +{-# LINE 150 "OpenSSL/DSA.hsc" #-} + +-- |Return the public key @y = g^x@. +dsaPublic :: DSA -> IO (Maybe Integer) +dsaPublic = peekDSA ((\hsc_ptr -> peekByteOff hsc_ptr 24)) +{-# LINE 154 "OpenSSL/DSA.hsc" #-} + +-- |Return the private key @x@. +dsaPrivate :: DSA -> IO (Maybe Integer) +dsaPrivate = peekDSA ((\hsc_ptr -> peekByteOff hsc_ptr 28)) +{-# LINE 158 "OpenSSL/DSA.hsc" #-} + +-- | Convert a DSA object to a tuple of its members in the order p, q, g, +-- public, private. If this is a public key, private will be Nothing +dsaToTuple :: DSA -> IO (Integer, Integer, Integer, Integer, Maybe Integer) +dsaToTuple dsa = do + Just p <- peekDSA ((\hsc_ptr -> peekByteOff hsc_ptr 12)) dsa +{-# LINE 164 "OpenSSL/DSA.hsc" #-} + Just q <- peekDSA ((\hsc_ptr -> peekByteOff hsc_ptr 16)) dsa +{-# LINE 165 "OpenSSL/DSA.hsc" #-} + Just g <- peekDSA ((\hsc_ptr -> peekByteOff hsc_ptr 20)) dsa +{-# LINE 166 "OpenSSL/DSA.hsc" #-} + Just pub <- peekDSA ((\hsc_ptr -> peekByteOff hsc_ptr 24)) dsa +{-# LINE 167 "OpenSSL/DSA.hsc" #-} + private <- peekDSA ((\hsc_ptr -> peekByteOff hsc_ptr 28)) dsa +{-# LINE 168 "OpenSSL/DSA.hsc" #-} + + return (p, q, g, pub, private) + +-- | Convert a tuple of members (in the same format as from dsaToTuple) into a +-- DSA object +tupleToDSA :: (Integer, Integer, Integer, Integer, Maybe Integer) -> IO DSA +tupleToDSA (p, q, g, pub, mpriv) = do + ptr <- _dsa_new + newBN p >>= return . unwrapBN >>= ((\hsc_ptr -> pokeByteOff hsc_ptr 12)) ptr +{-# LINE 177 "OpenSSL/DSA.hsc" #-} + newBN q >>= return . unwrapBN >>= ((\hsc_ptr -> pokeByteOff hsc_ptr 16)) ptr +{-# LINE 178 "OpenSSL/DSA.hsc" #-} + newBN g >>= return . unwrapBN >>= ((\hsc_ptr -> pokeByteOff hsc_ptr 20)) ptr +{-# LINE 179 "OpenSSL/DSA.hsc" #-} + newBN pub >>= return . unwrapBN >>= ((\hsc_ptr -> pokeByteOff hsc_ptr 24)) ptr +{-# LINE 180 "OpenSSL/DSA.hsc" #-} + case mpriv of + Just priv -> newBN priv >>= return . unwrapBN >>= ((\hsc_ptr -> pokeByteOff hsc_ptr 28)) ptr +{-# LINE 182 "OpenSSL/DSA.hsc" #-} + Nothing -> ((\hsc_ptr -> pokeByteOff hsc_ptr 28)) ptr nullPtr +{-# LINE 183 "OpenSSL/DSA.hsc" #-} + newForeignPtr _free ptr >>= return . DSA + +-- | A utility function to generate both the parameters and the key pair at the +-- same time. Saves serialising and deserialising the parameters too +generateParametersAndKey :: Int -- ^ The number of bits in the generated prime: 512 <= x <= 1024 + -> Maybe BS.ByteString -- ^ optional seed, its length must be 20 bytes + -> IO DSA +generateParametersAndKey nbits mseed = do + (\x -> case mseed of + Nothing -> x (nullPtr, 0) + Just seed -> BS.useAsCStringLen seed x) (\(seedptr, seedlen) -> do + ptr <- _generate_params nbits seedptr seedlen nullPtr nullPtr nullPtr nullPtr + failIfNull ptr + _dsa_generate_key ptr + newForeignPtr _free ptr >>= return . DSA) + +-- | Sign pre-digested data. The DSA specs call for SHA1 to be used so, if you +-- use anything else, YMMV. Returns a pair of Integers which, together, are +-- the signature +signDigestedData :: DSA -> BS.ByteString -> IO (Integer, Integer) +signDigestedData dsa bytes = do + BS.useAsCStringLen bytes (\(ptr, len) -> do + alloca (\rptr -> do + alloca (\sptr -> do + withDSAPtr dsa (\dsaptr -> do + _dsa_sign dsaptr ptr len rptr sptr >>= failIf (== 0) + r <- peek rptr >>= peekBN . wrapBN + peek rptr >>= _bn_free + s <- peek sptr >>= peekBN . wrapBN + peek sptr >>= _bn_free + return (r, s))))) + +-- | Verify pre-digested data given a signature. +verifyDigestedData :: DSA -> BS.ByteString -> (Integer, Integer) -> IO Bool +verifyDigestedData dsa bytes (r, s) = do + BS.useAsCStringLen bytes (\(ptr, len) -> do + withBN r (\bnR -> do + withBN s (\bnS -> do + withDSAPtr dsa (\dsaptr -> do + _dsa_verify dsaptr ptr len (unwrapBN bnR) (unwrapBN bnS) >>= return . (== 1))))) diff --git a/OpenSSL/ERR.hs b/OpenSSL/ERR.hs new file mode 100644 --- /dev/null +++ b/OpenSSL/ERR.hs @@ -0,0 +1,36 @@ +{-# OPTIONS_GHC -optc-D__GLASGOW_HASKELL__=606 #-} +{-# LINE 1 "OpenSSL/ERR.hsc" #-} +module OpenSSL.ERR +{-# LINE 2 "OpenSSL/ERR.hsc" #-} + ( getError + , peekError + + , errorString + ) + where + +import Foreign +import Foreign.C + + +foreign import ccall unsafe "ERR_get_error" + _get_error :: IO CULong + +foreign import ccall unsafe "ERR_peek_error" + _peek_error :: IO CULong + +foreign import ccall unsafe "ERR_error_string" + _error_string :: CULong -> CString -> IO CString + + +getError :: IO Integer +getError = _get_error >>= return . fromIntegral + + +peekError :: IO Integer +peekError = _peek_error >>= return . fromIntegral + + +errorString :: Integer -> IO String +errorString code + = _error_string (fromIntegral code) nullPtr >>= peekCString diff --git a/OpenSSL/EVP/Base64.hs b/OpenSSL/EVP/Base64.hs new file mode 100644 --- /dev/null +++ b/OpenSSL/EVP/Base64.hs @@ -0,0 +1,140 @@ +{-# OPTIONS_GHC -optc-D__GLASGOW_HASKELL__=606 #-} +{-# LINE 1 "OpenSSL/EVP/Base64.hsc" #-} +{- -*- haskell -*- -} +{-# LINE 2 "OpenSSL/EVP/Base64.hsc" #-} + +-- |An interface to Base64 codec. + +module OpenSSL.EVP.Base64 + ( -- * Encoding + encodeBase64 + , encodeBase64BS + , encodeBase64LBS + + -- * Decoding + , decodeBase64 + , decodeBase64BS + , decodeBase64LBS + ) + where + +import Control.Exception +import Data.ByteString.Base +import qualified Data.ByteString.Char8 as B8 +import qualified Data.ByteString.Lazy.Char8 as L8 +import Data.List +import Foreign +import Foreign.C + + +-- エンコード時: 最低 3 バイト以上になるまで次のブロックを取り出し續け +-- る。返された[ByteString] は B8.concat してから、その文字列長より小さ +-- な最大の 3 の倍數の位置で分割し、殘りは次のブロックの一部と見做す。 +-- +-- デコード時: 分割のアルゴリズムは同じだが最低バイト数が 4。 +nextBlock :: Int -> ([ByteString], LazyByteString) -> ([ByteString], LazyByteString) +nextBlock _ (xs, LPS [] ) = (xs, LPS []) +nextBlock minLen (xs, LPS src) = if foldl' (+) 0 (map B8.length xs) >= minLen then + (xs, LPS src) + else + case src of + (y:ys) -> nextBlock minLen (xs ++ [y], LPS ys) + + +{- encode -------------------------------------------------------------------- -} + +foreign import ccall unsafe "EVP_EncodeBlock" + _EncodeBlock :: Ptr CChar -> Ptr CChar -> Int -> IO Int + + +encodeBlock :: ByteString -> ByteString +encodeBlock inBS + = unsafePerformIO $ + unsafeUseAsCStringLen inBS $ \ (inBuf, inLen) -> + createAndTrim maxOutLen $ \ outBuf -> + _EncodeBlock (castPtr outBuf) inBuf inLen + where + maxOutLen = (inputLen `div` 3 + 1) * 4 + 1 -- +1: '\0' + inputLen = B8.length inBS + + +-- |@'encodeBase64' str@ lazilly encodes a stream of data to +-- Base64. The string doesn't have to be finite. Note that the string +-- must not contain any letters which aren't in the range of U+0000 - +-- U+00FF. +encodeBase64 :: String -> String +encodeBase64 = L8.unpack . encodeBase64LBS . L8.pack + +-- |@'encodeBase64BS' bs@ strictly encodes a chunk of data to Base64. +encodeBase64BS :: ByteString -> ByteString +encodeBase64BS = encodeBlock + +-- |@'encodeBase64LBS' lbs@ lazilly encodes a stream of data to +-- Base64. The string doesn't have to be finite. +encodeBase64LBS :: LazyByteString -> LazyByteString +encodeBase64LBS inLBS + | L8.null inLBS = L8.empty + | otherwise + = let (blockParts', remain' ) = nextBlock 3 ([], inLBS) + block' = B8.concat blockParts' + blockLen' = B8.length block' + (block , leftover) = if blockLen' < 3 then + -- 最後の半端 + (block', B8.empty) + else + B8.splitAt (blockLen' - blockLen' `mod` 3) block' + remain = if B8.null leftover then + remain' + else + case remain' of + LPS xs -> LPS (leftover:xs) + encodedBlock = encodeBlock block + LPS encodedRemain = encodeBase64LBS remain + in + LPS ([encodedBlock] ++ encodedRemain) + + +{- decode -------------------------------------------------------------------- -} + +foreign import ccall unsafe "EVP_DecodeBlock" + _DecodeBlock :: Ptr CChar -> Ptr CChar -> Int -> IO Int + + +decodeBlock :: ByteString -> ByteString +decodeBlock inBS + = assert (B8.length inBS `mod` 4 == 0) $ + unsafePerformIO $ + unsafeUseAsCStringLen inBS $ \ (inBuf, inLen) -> + createAndTrim (B8.length inBS) $ \ outBuf -> + _DecodeBlock (castPtr outBuf) inBuf inLen + +-- |@'decodeBase64' str@ lazilly decodes a stream of data from +-- Base64. The string doesn't have to be finite. +decodeBase64 :: String -> String +decodeBase64 = L8.unpack . decodeBase64LBS . L8.pack + +-- |@'decodeBase64BS' bs@ strictly decodes a chunk of data from +-- Base64. +decodeBase64BS :: ByteString -> ByteString +decodeBase64BS = decodeBlock + +-- |@'decodeBase64LBS' lbs@ lazilly decodes a stream of data from +-- Base64. The string doesn't have to be finite. +decodeBase64LBS :: LazyByteString -> LazyByteString +decodeBase64LBS inLBS + | L8.null inLBS = L8.empty + | otherwise + = let (blockParts', remain' ) = nextBlock 4 ([], inLBS) + block' = B8.concat blockParts' + blockLen' = B8.length block' + (block , leftover) = assert (blockLen' >= 4) $ + B8.splitAt (blockLen' - blockLen' `mod` 4) block' + remain = if B8.null leftover then + remain' + else + case remain' of + LPS xs -> LPS (leftover:xs) + decodedBlock = decodeBlock block + LPS decodedRemain = decodeBase64LBS remain + in + LPS ([decodedBlock] ++ decodedRemain) diff --git a/OpenSSL/EVP/Base64.hsc b/OpenSSL/EVP/Base64.hsc --- a/OpenSSL/EVP/Base64.hsc +++ b/OpenSSL/EVP/Base64.hsc @@ -15,8 +15,10 @@ ) where -import Control.Exception -import Data.ByteString.Base +import Control.Exception hiding (block) +import Data.ByteString.Internal (createAndTrim) +import Data.ByteString.Unsafe (unsafeUseAsCStringLen) +import qualified Data.ByteString.Lazy.Internal as L8Internal import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Lazy.Char8 as L8 import Data.List @@ -29,13 +31,14 @@ -- な最大の 3 の倍數の位置で分割し、殘りは次のブロックの一部と見做す。 -- -- デコード時: 分割のアルゴリズムは同じだが最低バイト数が 4。 -nextBlock :: Int -> ([ByteString], LazyByteString) -> ([ByteString], LazyByteString) -nextBlock _ (xs, LPS [] ) = (xs, LPS []) -nextBlock minLen (xs, LPS src) = if foldl' (+) 0 (map B8.length xs) >= minLen then - (xs, LPS src) - else - case src of - (y:ys) -> nextBlock minLen (xs ++ [y], LPS ys) +nextBlock :: Int -> ([B8.ByteString], L8.ByteString) -> ([B8.ByteString], L8.ByteString) +nextBlock minLen (xs, src) + = if foldl' (+) 0 (map B8.length xs) >= minLen then + (xs, src) + else + case src of + L8Internal.Empty -> (xs, src) + L8Internal.Chunk y ys -> nextBlock minLen (xs ++ [y], ys) {- encode -------------------------------------------------------------------- -} @@ -44,7 +47,7 @@ _EncodeBlock :: Ptr CChar -> Ptr CChar -> Int -> IO Int -encodeBlock :: ByteString -> ByteString +encodeBlock :: B8.ByteString -> B8.ByteString encodeBlock inBS = unsafePerformIO $ unsafeUseAsCStringLen inBS $ \ (inBuf, inLen) -> @@ -63,12 +66,12 @@ encodeBase64 = L8.unpack . encodeBase64LBS . L8.pack -- |@'encodeBase64BS' bs@ strictly encodes a chunk of data to Base64. -encodeBase64BS :: ByteString -> ByteString +encodeBase64BS :: B8.ByteString -> B8.ByteString encodeBase64BS = encodeBlock -- |@'encodeBase64LBS' lbs@ lazilly encodes a stream of data to -- Base64. The string doesn't have to be finite. -encodeBase64LBS :: LazyByteString -> LazyByteString +encodeBase64LBS :: L8.ByteString -> L8.ByteString encodeBase64LBS inLBS | L8.null inLBS = L8.empty | otherwise @@ -83,12 +86,11 @@ remain = if B8.null leftover then remain' else - case remain' of - LPS xs -> LPS (leftover:xs) + L8.fromChunks [leftover] `L8.append` remain' encodedBlock = encodeBlock block - LPS encodedRemain = encodeBase64LBS remain + encodedRemain = encodeBase64LBS remain in - LPS ([encodedBlock] ++ encodedRemain) + L8.fromChunks [encodedBlock] `L8.append` encodedRemain {- decode -------------------------------------------------------------------- -} @@ -97,13 +99,17 @@ _DecodeBlock :: Ptr CChar -> Ptr CChar -> Int -> IO Int -decodeBlock :: ByteString -> ByteString +decodeBlock :: B8.ByteString -> B8.ByteString decodeBlock inBS = assert (B8.length inBS `mod` 4 == 0) $ unsafePerformIO $ unsafeUseAsCStringLen inBS $ \ (inBuf, inLen) -> createAndTrim (B8.length inBS) $ \ outBuf -> _DecodeBlock (castPtr outBuf) inBuf inLen + >>= \ outLen -> return (outLen - paddingLen) + where + paddingLen :: Int + paddingLen = B8.count '=' inBS -- |@'decodeBase64' str@ lazilly decodes a stream of data from -- Base64. The string doesn't have to be finite. @@ -112,12 +118,12 @@ -- |@'decodeBase64BS' bs@ strictly decodes a chunk of data from -- Base64. -decodeBase64BS :: ByteString -> ByteString +decodeBase64BS :: B8.ByteString -> B8.ByteString decodeBase64BS = decodeBlock -- |@'decodeBase64LBS' lbs@ lazilly decodes a stream of data from -- Base64. The string doesn't have to be finite. -decodeBase64LBS :: LazyByteString -> LazyByteString +decodeBase64LBS :: L8.ByteString -> L8.ByteString decodeBase64LBS inLBS | L8.null inLBS = L8.empty | otherwise @@ -129,9 +135,8 @@ remain = if B8.null leftover then remain' else - case remain' of - LPS xs -> LPS (leftover:xs) + L8.fromChunks [leftover] `L8.append` remain' decodedBlock = decodeBlock block - LPS decodedRemain = decodeBase64LBS remain + decodedRemain = decodeBase64LBS remain in - LPS ([decodedBlock] ++ decodedRemain) + L8.fromChunks [decodedBlock] `L8.append` decodedRemain diff --git a/OpenSSL/EVP/Cipher.hs b/OpenSSL/EVP/Cipher.hs new file mode 100644 --- /dev/null +++ b/OpenSSL/EVP/Cipher.hs @@ -0,0 +1,227 @@ +{-# OPTIONS_GHC -optc-D__GLASGOW_HASKELL__=606 #-} +{-# INCLUDE "HsOpenSSL.h" #-} +{-# LINE 1 "OpenSSL/EVP/Cipher.hsc" #-} +{- -*- haskell -*- -} +{-# LINE 2 "OpenSSL/EVP/Cipher.hsc" #-} + +-- #prune + +-- |An interface to symmetric cipher algorithms. + + +{-# LINE 8 "OpenSSL/EVP/Cipher.hsc" #-} + +module OpenSSL.EVP.Cipher + ( Cipher + , EVP_CIPHER -- private + , withCipherPtr -- private + + , getCipherByName + , getCipherNames + + , cipherIvLength -- private + + , CipherCtx -- private + , EVP_CIPHER_CTX -- private + , newCtx -- private + , withCipherCtxPtr -- private + + , CryptoMode(..) + + , cipherStrictly -- private + , cipherLazily -- private + + , cipher + , cipherBS + , cipherLBS + ) + where + +import Control.Monad +import Data.ByteString.Base +import qualified Data.ByteString.Char8 as B8 +import qualified Data.ByteString.Lazy.Char8 as L8 +import Foreign +import Foreign.C +import OpenSSL.Objects +import OpenSSL.Utils +import System.IO.Unsafe + + +{- EVP_CIPHER ---------------------------------------------------------------- -} + +-- |@Cipher@ is an opaque object that represents an algorithm of +-- symmetric cipher. +newtype Cipher = Cipher (Ptr EVP_CIPHER) +data EVP_CIPHER + + +foreign import ccall unsafe "EVP_get_cipherbyname" + _get_cipherbyname :: CString -> IO (Ptr EVP_CIPHER) + + +foreign import ccall unsafe "HsOpenSSL_EVP_CIPHER_iv_length" + _iv_length :: Ptr EVP_CIPHER -> Int + + +withCipherPtr :: Cipher -> (Ptr EVP_CIPHER -> IO a) -> IO a +withCipherPtr (Cipher cipher) f = f cipher + +-- |@'getCipherByName' name@ returns a symmetric cipher algorithm +-- whose name is @name@. If no algorithms are found, the result is +-- @Nothing@. +getCipherByName :: String -> IO (Maybe Cipher) +getCipherByName name + = withCString name $ \ namePtr -> + do ptr <- _get_cipherbyname namePtr + if ptr == nullPtr then + return Nothing + else + return $ Just $ Cipher ptr + +-- |@'getCipherNames'@ returns a list of name of symmetric cipher +-- algorithms. +getCipherNames :: IO [String] +getCipherNames = getObjNames CipherMethodType True + + +cipherIvLength :: Cipher -> Int +cipherIvLength (Cipher cipher) = _iv_length cipher + + +{- EVP_CIPHER_CTX ------------------------------------------------------------ -} + +newtype CipherCtx = CipherCtx (ForeignPtr EVP_CIPHER_CTX) +data EVP_CIPHER_CTX + + +foreign import ccall unsafe "EVP_CIPHER_CTX_init" + _ctx_init :: Ptr EVP_CIPHER_CTX -> IO () + +foreign import ccall unsafe "&EVP_CIPHER_CTX_cleanup" + _ctx_cleanup :: FunPtr (Ptr EVP_CIPHER_CTX -> IO ()) + +foreign import ccall unsafe "HsOpenSSL_EVP_CIPHER_CTX_block_size" + _ctx_block_size :: Ptr EVP_CIPHER_CTX -> Int + + +newCtx :: IO CipherCtx +newCtx = do ctx <- mallocForeignPtrBytes ((140)) +{-# LINE 105 "OpenSSL/EVP/Cipher.hsc" #-} + withForeignPtr ctx $ \ ctxPtr -> + _ctx_init ctxPtr + addForeignPtrFinalizer _ctx_cleanup ctx + return $ CipherCtx ctx + + +withCipherCtxPtr :: CipherCtx -> (Ptr EVP_CIPHER_CTX -> IO a) -> IO a +withCipherCtxPtr (CipherCtx ctx) = withForeignPtr ctx + + +{- encrypt/decrypt ----------------------------------------------------------- -} + +-- |@CryptoMode@ represents instruction to 'cipher' and such like. +data CryptoMode = Encrypt | Decrypt + + +foreign import ccall unsafe "EVP_CipherInit" + _CipherInit :: Ptr EVP_CIPHER_CTX -> Ptr EVP_CIPHER -> CString -> CString -> Int -> IO Int + +foreign import ccall unsafe "EVP_CipherUpdate" + _CipherUpdate :: Ptr EVP_CIPHER_CTX -> Ptr CChar -> Ptr Int -> Ptr CChar -> Int -> IO Int + +foreign import ccall unsafe "EVP_CipherFinal" + _CipherFinal :: Ptr EVP_CIPHER_CTX -> Ptr CChar -> Ptr Int -> IO Int + + +cryptoModeToInt :: CryptoMode -> Int +cryptoModeToInt Encrypt = 1 +cryptoModeToInt Decrypt = 0 + + +cipherInit :: Cipher -> String -> String -> CryptoMode -> IO CipherCtx +cipherInit (Cipher c) key iv mode + = do ctx <- newCtx + withCipherCtxPtr ctx $ \ ctxPtr -> + withCString key $ \ keyPtr -> + withCString iv $ \ ivPtr -> + _CipherInit ctxPtr c keyPtr ivPtr (cryptoModeToInt mode) + >>= failIf (/= 1) + return ctx + + +cipherUpdateBS :: CipherCtx -> ByteString -> IO ByteString +cipherUpdateBS ctx inBS + = withCipherCtxPtr ctx $ \ ctxPtr -> + unsafeUseAsCStringLen inBS $ \ (inBuf, inLen) -> + createAndTrim (inLen + _ctx_block_size ctxPtr - 1) $ \ outBuf -> + alloca $ \ outLenPtr -> + _CipherUpdate ctxPtr (castPtr outBuf) outLenPtr inBuf inLen + >>= failIf (/= 1) + >> peek outLenPtr + + +cipherFinalBS :: CipherCtx -> IO ByteString +cipherFinalBS ctx + = withCipherCtxPtr ctx $ \ ctxPtr -> + createAndTrim (_ctx_block_size ctxPtr) $ \ outBuf -> + alloca $ \ outLenPtr -> + _CipherFinal ctxPtr (castPtr outBuf) outLenPtr + >>= failIf (/= 1) + >> peek outLenPtr + +-- |@'cipher'@ lazilly encrypts or decrypts a stream of data. The +-- input string doesn't necessarily have to be finite. +cipher :: Cipher -- ^ algorithm to use + -> String -- ^ symmetric key + -> String -- ^ IV + -> CryptoMode -- ^ operation + -> String -- ^ An input string to encrypt\/decrypt. Note + -- that the string must not contain any letters + -- which aren't in the range of U+0000 - + -- U+00FF. + -> IO String -- ^ the result string +cipher c key iv mode input + = liftM L8.unpack $ cipherLBS c key iv mode $ L8.pack input + +-- |@'cipherBS'@ strictly encrypts or decrypts a chunk of data. +cipherBS :: Cipher -- ^ algorithm to use + -> String -- ^ symmetric key + -> String -- ^ IV + -> CryptoMode -- ^ operation + -> ByteString -- ^ input string to encrypt\/decrypt + -> IO ByteString -- ^ the result string +cipherBS c key iv mode input + = do ctx <- cipherInit c key iv mode + cipherStrictly ctx input + +-- |@'cipherLBS'@ lazilly encrypts or decrypts a stream of data. The +-- input string doesn't necessarily have to be finite. +cipherLBS :: Cipher -- ^ algorithm to use + -> String -- ^ symmetric key + -> String -- ^ IV + -> CryptoMode -- ^ operation + -> LazyByteString -- ^ input string to encrypt\/decrypt + -> IO LazyByteString -- ^ the result string +cipherLBS c key iv mode input + = do ctx <- cipherInit c key iv mode + cipherLazily ctx input + + +cipherStrictly :: CipherCtx -> ByteString -> IO ByteString +cipherStrictly ctx input + = do output' <- cipherUpdateBS ctx input + output'' <- cipherFinalBS ctx + return $ B8.append output' output'' + + +cipherLazily :: CipherCtx -> LazyByteString -> IO LazyByteString + +cipherLazily ctx (LPS []) + = cipherFinalBS ctx >>= \ bs -> (return . LPS) [bs] + +cipherLazily ctx (LPS (x:xs)) + = do y <- cipherUpdateBS ctx x + LPS ys <- unsafeInterleaveIO $ + cipherLazily ctx (LPS xs) + return $ LPS (y:ys) diff --git a/OpenSSL/EVP/Cipher.hsc b/OpenSSL/EVP/Cipher.hsc --- a/OpenSSL/EVP/Cipher.hsc +++ b/OpenSSL/EVP/Cipher.hsc @@ -33,9 +33,11 @@ where import Control.Monad -import Data.ByteString.Base +import Data.ByteString.Internal (createAndTrim) +import Data.ByteString.Unsafe (unsafeUseAsCStringLen) import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Lazy.Char8 as L8 +import qualified Data.ByteString.Lazy.Internal as L8Internal import Foreign import Foreign.C import OpenSSL.Objects @@ -60,7 +62,7 @@ withCipherPtr :: Cipher -> (Ptr EVP_CIPHER -> IO a) -> IO a -withCipherPtr (Cipher cipher) f = f cipher +withCipherPtr (Cipher cipherPtr) f = f cipherPtr -- |@'getCipherByName' name@ returns a symmetric cipher algorithm -- whose name is @name@. If no algorithms are found, the result is @@ -81,7 +83,7 @@ cipherIvLength :: Cipher -> Int -cipherIvLength (Cipher cipher) = _iv_length cipher +cipherIvLength (Cipher cipherPtr) = _iv_length cipherPtr {- EVP_CIPHER_CTX ------------------------------------------------------------ -} @@ -144,7 +146,7 @@ return ctx -cipherUpdateBS :: CipherCtx -> ByteString -> IO ByteString +cipherUpdateBS :: CipherCtx -> B8.ByteString -> IO B8.ByteString cipherUpdateBS ctx inBS = withCipherCtxPtr ctx $ \ ctxPtr -> unsafeUseAsCStringLen inBS $ \ (inBuf, inLen) -> @@ -155,7 +157,7 @@ >> peek outLenPtr -cipherFinalBS :: CipherCtx -> IO ByteString +cipherFinalBS :: CipherCtx -> IO B8.ByteString cipherFinalBS ctx = withCipherCtxPtr ctx $ \ ctxPtr -> createAndTrim (_ctx_block_size ctxPtr) $ \ outBuf -> @@ -183,8 +185,8 @@ -> String -- ^ symmetric key -> String -- ^ IV -> CryptoMode -- ^ operation - -> ByteString -- ^ input string to encrypt\/decrypt - -> IO ByteString -- ^ the result string + -> B8.ByteString -- ^ input string to encrypt\/decrypt + -> IO B8.ByteString -- ^ the result string cipherBS c key iv mode input = do ctx <- cipherInit c key iv mode cipherStrictly ctx input @@ -195,27 +197,27 @@ -> String -- ^ symmetric key -> String -- ^ IV -> CryptoMode -- ^ operation - -> LazyByteString -- ^ input string to encrypt\/decrypt - -> IO LazyByteString -- ^ the result string + -> L8.ByteString -- ^ input string to encrypt\/decrypt + -> IO L8.ByteString -- ^ the result string cipherLBS c key iv mode input = do ctx <- cipherInit c key iv mode cipherLazily ctx input -cipherStrictly :: CipherCtx -> ByteString -> IO ByteString +cipherStrictly :: CipherCtx -> B8.ByteString -> IO B8.ByteString cipherStrictly ctx input = do output' <- cipherUpdateBS ctx input output'' <- cipherFinalBS ctx return $ B8.append output' output'' -cipherLazily :: CipherCtx -> LazyByteString -> IO LazyByteString +cipherLazily :: CipherCtx -> L8.ByteString -> IO L8.ByteString -cipherLazily ctx (LPS []) - = cipherFinalBS ctx >>= \ bs -> (return . LPS) [bs] +cipherLazily ctx (L8Internal.Empty) = + cipherFinalBS ctx >>= \ bs -> (return . L8.fromChunks) [bs] -cipherLazily ctx (LPS (x:xs)) - = do y <- cipherUpdateBS ctx x - LPS ys <- unsafeInterleaveIO $ - cipherLazily ctx (LPS xs) - return $ LPS (y:ys) +cipherLazily ctx (L8Internal.Chunk x xs) = do + y <- cipherUpdateBS ctx x + ys <- unsafeInterleaveIO $ + cipherLazily ctx xs + return $ L8Internal.Chunk y ys diff --git a/OpenSSL/EVP/Digest.hs b/OpenSSL/EVP/Digest.hs new file mode 100644 --- /dev/null +++ b/OpenSSL/EVP/Digest.hs @@ -0,0 +1,207 @@ +{-# OPTIONS_GHC -optc-D__GLASGOW_HASKELL__=606 #-} +{-# INCLUDE "HsOpenSSL.h" #-} +{-# LINE 1 "OpenSSL/EVP/Digest.hsc" #-} +{- -*- haskell -*- -} +{-# LINE 2 "OpenSSL/EVP/Digest.hsc" #-} + +-- #prune + +-- |An interface to message digest algorithms. + + +{-# LINE 8 "OpenSSL/EVP/Digest.hsc" #-} + +module OpenSSL.EVP.Digest + ( Digest + , EVP_MD -- private + , withMDPtr -- private + + , getDigestByName + , getDigestNames + + , DigestCtx -- private + , EVP_MD_CTX -- private + , withDigestCtxPtr -- private + + , digestStrictly -- private + , digestLazily -- private + + , digest + , digestBS + , digestLBS + + , hmacBS + ) + where + +import Control.Monad +import Data.ByteString.Base +import Data.ByteString (copyCStringLen) +import qualified Data.ByteString.Char8 as B8 +import qualified Data.ByteString.Lazy.Char8 as L8 +import Foreign +import Foreign.C +import OpenSSL.Objects +import OpenSSL.Utils + + +{- EVP_MD -------------------------------------------------------------------- -} + +-- |@Digest@ is an opaque object that represents an algorithm of +-- message digest. +newtype Digest = Digest (Ptr EVP_MD) +data EVP_MD + + +foreign import ccall unsafe "EVP_get_digestbyname" + _get_digestbyname :: CString -> IO (Ptr EVP_MD) + +foreign import ccall unsafe "HsOpenSSL_EVP_MD_size" + mdSize :: Ptr EVP_MD -> Int + + +withMDPtr :: Digest -> (Ptr EVP_MD -> IO a) -> IO a +withMDPtr (Digest mdPtr) f = f mdPtr + +-- |@'getDigestByName' name@ returns a message digest algorithm whose +-- name is @name@. If no algorithms are found, the result is +-- @Nothing@. +getDigestByName :: String -> IO (Maybe Digest) +getDigestByName name + = withCString name $ \ namePtr -> + do ptr <- _get_digestbyname namePtr + if ptr == nullPtr then + return Nothing + else + return $ Just $ Digest ptr + +-- |@'getDigestNames'@ returns a list of name of message digest +-- algorithms. +getDigestNames :: IO [String] +getDigestNames = getObjNames MDMethodType True + + +{- EVP_MD_CTX ---------------------------------------------------------------- -} + +newtype DigestCtx = DigestCtx (ForeignPtr EVP_MD_CTX) +data EVP_MD_CTX + + +foreign import ccall unsafe "EVP_MD_CTX_init" + _ctx_init :: Ptr EVP_MD_CTX -> IO () + +foreign import ccall unsafe "&EVP_MD_CTX_cleanup" + _ctx_cleanup :: FunPtr (Ptr EVP_MD_CTX -> IO ()) + + +newCtx :: IO DigestCtx +newCtx = do ctx <- mallocForeignPtrBytes ((16)) +{-# LINE 94 "OpenSSL/EVP/Digest.hsc" #-} + withForeignPtr ctx $ \ ctxPtr -> + _ctx_init ctxPtr + addForeignPtrFinalizer _ctx_cleanup ctx + return $ DigestCtx ctx + + +withDigestCtxPtr :: DigestCtx -> (Ptr EVP_MD_CTX -> IO a) -> IO a +withDigestCtxPtr (DigestCtx ctx) = withForeignPtr ctx + + +{- digest -------------------------------------------------------------------- -} + +foreign import ccall unsafe "EVP_DigestInit" + _DigestInit :: Ptr EVP_MD_CTX -> Ptr EVP_MD -> IO Int + +foreign import ccall unsafe "EVP_DigestUpdate" + _DigestUpdate :: Ptr EVP_MD_CTX -> Ptr CChar -> CSize -> IO Int + +foreign import ccall unsafe "EVP_DigestFinal" + _DigestFinal :: Ptr EVP_MD_CTX -> Ptr CChar -> Ptr CUInt -> IO Int + + +digestInit :: Digest -> IO DigestCtx +digestInit (Digest md) + = do ctx <- newCtx + withDigestCtxPtr ctx $ \ ctxPtr -> + _DigestInit ctxPtr md >>= failIf (/= 1) + return ctx + + +digestUpdateBS :: DigestCtx -> ByteString -> IO () +digestUpdateBS ctx bs + = withDigestCtxPtr ctx $ \ ctxPtr -> + unsafeUseAsCStringLen bs $ \ (buf, len) -> + _DigestUpdate ctxPtr buf (fromIntegral len) >>= failIf (/= 1) >> return () + + +digestUpdateLBS :: DigestCtx -> LazyByteString -> IO () +digestUpdateLBS ctx (LPS chunks) + = mapM_ (digestUpdateBS ctx) chunks + + +digestFinal :: DigestCtx -> IO String +digestFinal ctx + = withDigestCtxPtr ctx $ \ ctxPtr -> + allocaArray (36) $ \ bufPtr -> +{-# LINE 140 "OpenSSL/EVP/Digest.hsc" #-} + alloca $ \ bufLenPtr -> + do _DigestFinal ctxPtr bufPtr bufLenPtr >>= failIf (/= 1) + bufLen <- liftM fromIntegral $ peek bufLenPtr + peekCStringLen (bufPtr, bufLen) + + +digestStrictly :: Digest -> ByteString -> IO DigestCtx +digestStrictly md input + = do ctx <- digestInit md + digestUpdateBS ctx input + return ctx + + +digestLazily :: Digest -> LazyByteString -> IO DigestCtx +digestLazily md (LPS input) + = do ctx <- digestInit md + mapM_ (digestUpdateBS ctx) input + return ctx + +-- |@'digest'@ digests a stream of data. The string must +-- not contain any letters which aren't in the range of U+0000 - +-- U+00FF. +digest :: Digest -> String -> String +digest md input + = digestLBS md $ L8.pack input + +-- |@'digestBS'@ digests a chunk of data. +digestBS :: Digest -> ByteString -> String +digestBS md input + = unsafePerformIO $ + do ctx <- digestStrictly md input + digestFinal ctx + +-- |@'digestLBS'@ digests a stream of data. +digestLBS :: Digest -> LazyByteString -> String +digestLBS md input + = unsafePerformIO $ + do ctx <- digestLazily md input + digestFinal ctx + +{- HMAC ---------------------------------------------------------------------- -} + +foreign import ccall unsafe "HMAC" + _HMAC :: Ptr EVP_MD -> Ptr CChar -> CInt -> Ptr CChar -> CInt + -> Ptr CChar -> Ptr CUInt -> IO () + +-- | Perform a private key signing using the HMAC template with a given hash +hmacBS :: Digest -- ^ the hash function to use in the HMAC calculation + -> ByteString -- ^ the HMAC key + -> ByteString -- ^ the data to be signed + -> ByteString -- ^ resulting HMAC +hmacBS (Digest md) key input = + unsafePerformIO $ + allocaArray (36) $ \bufPtr -> +{-# LINE 194 "OpenSSL/EVP/Digest.hsc" #-} + alloca $ \bufLenPtr -> + unsafeUseAsCStringLen key $ \(keydata, keylen) -> + unsafeUseAsCStringLen input $ \(inputdata, inputlen) -> + do _HMAC md keydata (fromIntegral keylen) inputdata (fromIntegral inputlen) bufPtr bufLenPtr + bufLen <- liftM fromIntegral $ peek bufLenPtr + copyCStringLen (bufPtr, bufLen) diff --git a/OpenSSL/EVP/Digest.hsc b/OpenSSL/EVP/Digest.hsc --- a/OpenSSL/EVP/Digest.hsc +++ b/OpenSSL/EVP/Digest.hsc @@ -30,8 +30,7 @@ where import Control.Monad -import Data.ByteString.Base -import Data.ByteString (copyCStringLen) +import Data.ByteString.Unsafe (unsafeUseAsCStringLen) import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Lazy.Char8 as L8 import Foreign @@ -51,10 +50,7 @@ foreign import ccall unsafe "EVP_get_digestbyname" _get_digestbyname :: CString -> IO (Ptr EVP_MD) -foreign import ccall unsafe "HsOpenSSL_EVP_MD_size" - mdSize :: Ptr EVP_MD -> Int - withMDPtr :: Digest -> (Ptr EVP_MD -> IO a) -> IO a withMDPtr (Digest mdPtr) f = f mdPtr @@ -121,18 +117,13 @@ return ctx -digestUpdateBS :: DigestCtx -> ByteString -> IO () +digestUpdateBS :: DigestCtx -> B8.ByteString -> IO () digestUpdateBS ctx bs = withDigestCtxPtr ctx $ \ ctxPtr -> unsafeUseAsCStringLen bs $ \ (buf, len) -> _DigestUpdate ctxPtr buf (fromIntegral len) >>= failIf (/= 1) >> return () -digestUpdateLBS :: DigestCtx -> LazyByteString -> IO () -digestUpdateLBS ctx (LPS chunks) - = mapM_ (digestUpdateBS ctx) chunks - - digestFinal :: DigestCtx -> IO String digestFinal ctx = withDigestCtxPtr ctx $ \ ctxPtr -> @@ -143,17 +134,17 @@ peekCStringLen (bufPtr, bufLen) -digestStrictly :: Digest -> ByteString -> IO DigestCtx +digestStrictly :: Digest -> B8.ByteString -> IO DigestCtx digestStrictly md input = do ctx <- digestInit md digestUpdateBS ctx input return ctx -digestLazily :: Digest -> LazyByteString -> IO DigestCtx -digestLazily md (LPS input) +digestLazily :: Digest -> L8.ByteString -> IO DigestCtx +digestLazily md lbs = do ctx <- digestInit md - mapM_ (digestUpdateBS ctx) input + mapM_ (digestUpdateBS ctx) $ L8.toChunks lbs return ctx -- |@'digest'@ digests a stream of data. The string must @@ -164,14 +155,14 @@ = digestLBS md $ L8.pack input -- |@'digestBS'@ digests a chunk of data. -digestBS :: Digest -> ByteString -> String +digestBS :: Digest -> B8.ByteString -> String digestBS md input = unsafePerformIO $ do ctx <- digestStrictly md input digestFinal ctx -- |@'digestLBS'@ digests a stream of data. -digestLBS :: Digest -> LazyByteString -> String +digestLBS :: Digest -> L8.ByteString -> String digestLBS md input = unsafePerformIO $ do ctx <- digestLazily md input @@ -185,9 +176,9 @@ -- | Perform a private key signing using the HMAC template with a given hash hmacBS :: Digest -- ^ the hash function to use in the HMAC calculation - -> ByteString -- ^ the HMAC key - -> ByteString -- ^ the data to be signed - -> ByteString -- ^ resulting HMAC + -> B8.ByteString -- ^ the HMAC key + -> B8.ByteString -- ^ the data to be signed + -> B8.ByteString -- ^ resulting HMAC hmacBS (Digest md) key input = unsafePerformIO $ allocaArray (#const EVP_MAX_MD_SIZE) $ \bufPtr -> @@ -196,4 +187,4 @@ unsafeUseAsCStringLen input $ \(inputdata, inputlen) -> do _HMAC md keydata (fromIntegral keylen) inputdata (fromIntegral inputlen) bufPtr bufLenPtr bufLen <- liftM fromIntegral $ peek bufLenPtr - copyCStringLen (bufPtr, bufLen) + B8.packCStringLen (bufPtr, bufLen) diff --git a/OpenSSL/EVP/Open.hs b/OpenSSL/EVP/Open.hs new file mode 100644 --- /dev/null +++ b/OpenSSL/EVP/Open.hs @@ -0,0 +1,82 @@ +{-# OPTIONS_GHC -optc-D__GLASGOW_HASKELL__=606 #-} +{-# LINE 1 "OpenSSL/EVP/Open.hsc" #-} +{- -*- haskell -*- -} +{-# LINE 2 "OpenSSL/EVP/Open.hsc" #-} + +-- |Asymmetric cipher decryption using encrypted symmetric key. This +-- is an opposite of "OpenSSL.EVP.Seal". + +module OpenSSL.EVP.Open + ( open + , openBS + , openLBS + ) + where + +import Control.Monad +import Data.ByteString.Base +import qualified Data.ByteString.Char8 as B8 +import qualified Data.ByteString.Lazy.Char8 as L8 +import Foreign +import Foreign.C +import OpenSSL.EVP.Cipher +import OpenSSL.EVP.PKey +import OpenSSL.Utils + + +foreign import ccall unsafe "EVP_OpenInit" + _OpenInit :: Ptr EVP_CIPHER_CTX + -> Cipher + -> Ptr CChar + -> Int + -> CString + -> Ptr EVP_PKEY + -> IO Int + + +openInit :: Cipher -> String -> String -> PKey -> IO CipherCtx +openInit cipher encKey iv pkey + = do ctx <- newCtx + withCipherCtxPtr ctx $ \ ctxPtr -> + withCStringLen encKey $ \ (encKeyPtr, encKeyLen) -> + withCString iv $ \ ivPtr -> + withPKeyPtr pkey $ \ pkeyPtr -> + _OpenInit ctxPtr cipher encKeyPtr encKeyLen ivPtr pkeyPtr + >>= failIf (== 0) + return ctx + +-- |@'open'@ lazilly decrypts a stream of data. The input string +-- doesn't necessarily have to be finite. +open :: Cipher -- ^ symmetric cipher algorithm to use + -> String -- ^ encrypted symmetric key to decrypt the input string + -> String -- ^ IV + -> PKey -- ^ private key to decrypt the symmetric key + -> String -- ^ input string to decrypt + -> String -- ^ decrypted string +open cipher encKey iv pkey input + = L8.unpack $ openLBS cipher encKey iv pkey $ L8.pack input + +-- |@'openBS'@ decrypts a chunk of data. +openBS :: Cipher -- ^ symmetric cipher algorithm to use + -> String -- ^ encrypted symmetric key to decrypt the input string + -> String -- ^ IV + -> PKey -- ^ private key to decrypt the symmetric key + -> ByteString -- ^ input string to decrypt + -> ByteString -- ^ decrypted string +openBS cipher encKey iv pkey input + = unsafePerformIO $ + do ctx <- openInit cipher encKey iv pkey + cipherStrictly ctx input + +-- |@'openLBS'@ lazilly decrypts a stream of data. The input string +-- doesn't necessarily have to be finite. +openLBS :: Cipher -- ^ symmetric cipher algorithm to use + -> String -- ^ encrypted symmetric key to decrypt the input string + -> String -- ^ IV + -> PKey -- ^ private key to decrypt the symmetric key + -> LazyByteString -- ^ input string to decrypt + -> LazyByteString -- ^ decrypted string +openLBS cipher encKey iv pkey input + = unsafePerformIO $ + do ctx <- openInit cipher encKey iv pkey + cipherLazily ctx input diff --git a/OpenSSL/EVP/Open.hsc b/OpenSSL/EVP/Open.hsc --- a/OpenSSL/EVP/Open.hsc +++ b/OpenSSL/EVP/Open.hsc @@ -11,12 +11,11 @@ where import Control.Monad -import Data.ByteString.Base import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Lazy.Char8 as L8 import Foreign import Foreign.C -import OpenSSL.EVP.Cipher +import OpenSSL.EVP.Cipher hiding (cipher) import OpenSSL.EVP.PKey import OpenSSL.Utils @@ -58,8 +57,8 @@ -> String -- ^ encrypted symmetric key to decrypt the input string -> String -- ^ IV -> PKey -- ^ private key to decrypt the symmetric key - -> ByteString -- ^ input string to decrypt - -> ByteString -- ^ decrypted string + -> B8.ByteString -- ^ input string to decrypt + -> B8.ByteString -- ^ decrypted string openBS cipher encKey iv pkey input = unsafePerformIO $ do ctx <- openInit cipher encKey iv pkey @@ -71,8 +70,8 @@ -> String -- ^ encrypted symmetric key to decrypt the input string -> String -- ^ IV -> PKey -- ^ private key to decrypt the symmetric key - -> LazyByteString -- ^ input string to decrypt - -> LazyByteString -- ^ decrypted string + -> L8.ByteString -- ^ input string to decrypt + -> L8.ByteString -- ^ decrypted string openLBS cipher encKey iv pkey input = unsafePerformIO $ do ctx <- openInit cipher encKey iv pkey diff --git a/OpenSSL/EVP/PKey.hs b/OpenSSL/EVP/PKey.hs new file mode 100644 --- /dev/null +++ b/OpenSSL/EVP/PKey.hs @@ -0,0 +1,139 @@ +{-# OPTIONS_GHC -optc-D__GLASGOW_HASKELL__=606 #-} +{-# INCLUDE "HsOpenSSL.h" #-} +{-# LINE 1 "OpenSSL/EVP/PKey.hsc" #-} +{- -*- haskell -*- -} +{-# LINE 2 "OpenSSL/EVP/PKey.hsc" #-} + +-- #prune + +-- |An interface to asymmetric cipher keypair. + + +{-# LINE 8 "OpenSSL/EVP/PKey.hsc" #-} + +module OpenSSL.EVP.PKey + ( PKey + , EVP_PKEY -- private + + , wrapPKeyPtr -- private + , withPKeyPtr -- private + , unsafePKeyToPtr -- private + , touchPKey -- private + , pkeySize -- private + , pkeyDefaultMD -- private + + -- FIXME: newPKeyDSA, newPKeyDH and newPKeyECKey may be needed + +{-# LINE 22 "OpenSSL/EVP/PKey.hsc" #-} + , newPKeyRSA + +{-# LINE 24 "OpenSSL/EVP/PKey.hsc" #-} + +{-# LINE 25 "OpenSSL/EVP/PKey.hsc" #-} + , newPKeyDSA + +{-# LINE 27 "OpenSSL/EVP/PKey.hsc" #-} + ) + where + +import Foreign +import OpenSSL.DSA +import OpenSSL.EVP.Digest +import OpenSSL.RSA +import OpenSSL.Utils + +-- |@PKey@ is an opaque object that represents either public key or +-- public\/private keypair. The concrete algorithm of asymmetric +-- cipher is hidden in the object. +newtype PKey = PKey (ForeignPtr EVP_PKEY) +data EVP_PKEY + + +foreign import ccall unsafe "EVP_PKEY_new" + _pkey_new :: IO (Ptr EVP_PKEY) + +foreign import ccall unsafe "&EVP_PKEY_free" + _pkey_free :: FunPtr (Ptr EVP_PKEY -> IO ()) + +foreign import ccall unsafe "EVP_PKEY_size" + _pkey_size :: Ptr EVP_PKEY -> IO Int + + +wrapPKeyPtr :: Ptr EVP_PKEY -> IO PKey +wrapPKeyPtr pkeyPtr + = newForeignPtr _pkey_free pkeyPtr >>= return . PKey + + +withPKeyPtr :: PKey -> (Ptr EVP_PKEY -> IO a) -> IO a +withPKeyPtr (PKey pkey) = withForeignPtr pkey + + +unsafePKeyToPtr :: PKey -> Ptr EVP_PKEY +unsafePKeyToPtr (PKey pkey) = unsafeForeignPtrToPtr pkey + + +touchPKey :: PKey -> IO () +touchPKey (PKey pkey) = touchForeignPtr pkey + + +pkeySize :: PKey -> IO Int +pkeySize pkey + = withPKeyPtr pkey $ \ pkeyPtr -> + _pkey_size pkeyPtr + + +pkeyDefaultMD :: PKey -> IO Digest +pkeyDefaultMD pkey + = withPKeyPtr pkey $ \ pkeyPtr -> + do pkeyType <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) pkeyPtr :: IO Int +{-# LINE 80 "OpenSSL/EVP/PKey.hsc" #-} + digestName <- case pkeyType of + +{-# LINE 82 "OpenSSL/EVP/PKey.hsc" #-} + (6) -> return "sha1" +{-# LINE 83 "OpenSSL/EVP/PKey.hsc" #-} + +{-# LINE 84 "OpenSSL/EVP/PKey.hsc" #-} + +{-# LINE 85 "OpenSSL/EVP/PKey.hsc" #-} + (116) -> return "dss1" +{-# LINE 86 "OpenSSL/EVP/PKey.hsc" #-} + +{-# LINE 87 "OpenSSL/EVP/PKey.hsc" #-} + _ -> fail ("pkeyDefaultMD: unsupported pkey type: " ++ show pkeyType) + mDigest <- getDigestByName digestName + case mDigest of + Just digest -> return digest + Nothing -> fail ("pkeyDefaultMD: digest method not found: " ++ digestName) + + + +{-# LINE 95 "OpenSSL/EVP/PKey.hsc" #-} +foreign import ccall unsafe "EVP_PKEY_set1_RSA" + _set1_RSA :: Ptr EVP_PKEY -> Ptr RSA_ -> IO Int + +-- |@'newPKeyRSA' rsa@ encapsulates an RSA key into 'PKey'. +newPKeyRSA :: RSA -> PKey +newPKeyRSA rsa + = unsafePerformIO $ + withRSAPtr rsa $ \ rsaPtr -> + do pkeyPtr <- _pkey_new >>= failIfNull + _set1_RSA pkeyPtr rsaPtr >>= failIf (/= 1) + wrapPKeyPtr pkeyPtr + +{-# LINE 107 "OpenSSL/EVP/PKey.hsc" #-} + + + +{-# LINE 110 "OpenSSL/EVP/PKey.hsc" #-} +foreign import ccall unsafe "EVP_PKEY_set1_DSA" + _set1_DSA :: Ptr EVP_PKEY -> Ptr DSA_ -> IO Int + +-- |@'newPKeyDSA' dsa@ encapsulates an 'DSA' key into 'PKey'. +newPKeyDSA :: DSA -> PKey +newPKeyDSA dsa + = unsafePerformIO $ + withDSAPtr dsa $ \ dsaPtr -> + do pkeyPtr <- _pkey_new >>= failIfNull + _set1_DSA pkeyPtr dsaPtr >>= failIf (/= 1) + wrapPKeyPtr pkeyPtr diff --git a/OpenSSL/EVP/PKey.hsc b/OpenSSL/EVP/PKey.hsc --- a/OpenSSL/EVP/PKey.hsc +++ b/OpenSSL/EVP/PKey.hsc @@ -29,7 +29,7 @@ import Foreign import OpenSSL.DSA -import OpenSSL.EVP.Digest +import OpenSSL.EVP.Digest hiding (digest) import OpenSSL.RSA import OpenSSL.Utils diff --git a/OpenSSL/EVP/Seal.hs b/OpenSSL/EVP/Seal.hs new file mode 100644 --- /dev/null +++ b/OpenSSL/EVP/Seal.hs @@ -0,0 +1,137 @@ +{-# OPTIONS_GHC -optc-D__GLASGOW_HASKELL__=606 #-} +{-# LINE 1 "OpenSSL/EVP/Seal.hsc" #-} +{- -*- haskell -*- -} +{-# LINE 2 "OpenSSL/EVP/Seal.hsc" #-} + +-- |Asymmetric cipher decryption using encrypted symmetric key. This +-- is an opposite of "OpenSSL.EVP.Open". + +module OpenSSL.EVP.Seal + ( seal + , sealBS + , sealLBS + ) + where + +import Control.Monad +import Data.ByteString.Base +import qualified Data.ByteString.Char8 as B8 +import qualified Data.ByteString.Lazy.Char8 as L8 +import Foreign +import Foreign.C +import OpenSSL.EVP.Cipher +import OpenSSL.EVP.PKey +import OpenSSL.Utils + + +foreign import ccall unsafe "EVP_SealInit" + _SealInit :: Ptr EVP_CIPHER_CTX + -> Cipher + -> Ptr (Ptr CChar) + -> Ptr Int + -> CString + -> Ptr (Ptr EVP_PKEY) + -> Int + -> IO Int + + +sealInit :: Cipher -> [PKey] -> IO (CipherCtx, [String], String) + +sealInit _ [] + = fail "sealInit: at least one public key is required" + +sealInit cipher pubKeys + = do ctx <- newCtx + + -- 暗号化された共通鍵の配列が書き込まれる場所を作る。各共通鍵 + -- は最大で pkeySize の長さになる。 + encKeyBufs <- mapM mallocEncKeyBuf pubKeys + + -- encKeys は [Ptr a] なので、これを Ptr (Ptr CChar) にしなけ + -- ればならない。 + encKeyBufsPtr <- newArray encKeyBufs + + -- 暗号化された共通鍵の各々の長さが書き込まれる場所を作る。 + encKeyBufsLenPtr <- mallocArray nKeys + + -- IV の書き込まれる場所を作る。 + ivPtr <- mallocArray (cipherIvLength cipher) + + -- [PKey] から Ptr (Ptr EVP_PKEY) を作る。後でそれぞれの + -- PKey を touchForeignPtr する事を忘れてはならない。 + pubKeysPtr <- newArray $ map unsafePKeyToPtr pubKeys + + -- 確保した領域を解放する IO アクションを作って置く + let cleanup = do mapM_ free encKeyBufs + free encKeyBufsPtr + free encKeyBufsLenPtr + free ivPtr + free pubKeysPtr + mapM_ touchPKey pubKeys + + -- いよいよ EVP_SealInit を呼ぶ。 + ret <- withCipherCtxPtr ctx $ \ ctxPtr -> + _SealInit ctxPtr cipher encKeyBufsPtr encKeyBufsLenPtr ivPtr pubKeysPtr nKeys + + if ret == 0 then + cleanup >> raiseOpenSSLError + else + do encKeysLen <- peekArray nKeys encKeyBufsLenPtr + encKeys <- mapM peekCStringLen $ zip encKeyBufs encKeysLen + iv <- peekCString ivPtr + cleanup + return (ctx, encKeys, iv) + where + nKeys :: Int + nKeys = length pubKeys + + mallocEncKeyBuf :: Storable a => PKey -> IO (Ptr a) + mallocEncKeyBuf pubKey + = pkeySize pubKey >>= mallocArray + +-- |@'seal'@ lazilly encrypts a stream of data. The input string +-- doesn't necessarily have to be finite. +seal :: Cipher -- ^ symmetric cipher algorithm to use + -> [PKey] -- ^ A list of public keys to encrypt a + -- symmetric key. At least one public key must + -- be supplied. If two or more keys are given, + -- the symmetric key are encrypted by each + -- public keys so that any of the + -- corresponding private keys can decrypt the + -- message. + -> String -- ^ input string to encrypt + -> IO (String, [String], String) -- ^ (encrypted string, list of + -- encrypted asymmetric keys, + -- IV) +seal cipher pubKeys input + = do (output, encKeys, iv) <- sealLBS cipher pubKeys $ L8.pack input + return (L8.unpack output, encKeys, iv) + +-- |@'sealBS'@ strictly encrypts a chunk of data. +sealBS :: Cipher -- ^ symmetric cipher algorithm to use + -> [PKey] -- ^ list of public keys to encrypt a symmetric + -- key + -> ByteString -- ^ input string to encrypt + -> IO (ByteString, [String], String) -- ^ (encrypted string, + -- list of encrypted + -- asymmetric keys, IV) +sealBS cipher pubKeys input + = do (ctx, encKeys, iv) <- sealInit cipher pubKeys + output <- cipherStrictly ctx input + return (output, encKeys, iv) + +-- |@'sealLBS'@ lazilly encrypts a stream of data. The input string +-- doesn't necessarily have to be finite. +sealLBS :: Cipher -- ^ symmetric cipher algorithm to use + -> [PKey] -- ^ list of public keys to encrypt a + -- symmetric key + -> LazyByteString -- ^ input string to encrypt + -> IO (LazyByteString, [String], String) -- ^ (encrypted + -- string, list of + -- encrypted + -- asymmetric keys, + -- IV) +sealLBS cipher pubKeys input + = do (ctx, encKeys, iv) <- sealInit cipher pubKeys + output <- cipherLazily ctx input + return (output, encKeys, iv) diff --git a/OpenSSL/EVP/Seal.hsc b/OpenSSL/EVP/Seal.hsc --- a/OpenSSL/EVP/Seal.hsc +++ b/OpenSSL/EVP/Seal.hsc @@ -11,12 +11,11 @@ where import Control.Monad -import Data.ByteString.Base import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Lazy.Char8 as L8 import Foreign import Foreign.C -import OpenSSL.EVP.Cipher +import OpenSSL.EVP.Cipher hiding (cipher) import OpenSSL.EVP.PKey import OpenSSL.Utils @@ -108,8 +107,8 @@ sealBS :: Cipher -- ^ symmetric cipher algorithm to use -> [PKey] -- ^ list of public keys to encrypt a symmetric -- key - -> ByteString -- ^ input string to encrypt - -> IO (ByteString, [String], String) -- ^ (encrypted string, + -> B8.ByteString -- ^ input string to encrypt + -> IO (B8.ByteString, [String], String) -- ^ (encrypted string, -- list of encrypted -- asymmetric keys, IV) sealBS cipher pubKeys input @@ -122,8 +121,8 @@ sealLBS :: Cipher -- ^ symmetric cipher algorithm to use -> [PKey] -- ^ list of public keys to encrypt a -- symmetric key - -> LazyByteString -- ^ input string to encrypt - -> IO (LazyByteString, [String], String) -- ^ (encrypted + -> L8.ByteString -- ^ input string to encrypt + -> IO (L8.ByteString, [String], String) -- ^ (encrypted -- string, list of -- encrypted -- asymmetric keys, diff --git a/OpenSSL/EVP/Sign.hs b/OpenSSL/EVP/Sign.hs new file mode 100644 --- /dev/null +++ b/OpenSSL/EVP/Sign.hs @@ -0,0 +1,70 @@ +{-# OPTIONS_GHC -optc-D__GLASGOW_HASKELL__=606 #-} +{-# LINE 1 "OpenSSL/EVP/Sign.hsc" #-} +{- -*- haskell -*- -} +{-# LINE 2 "OpenSSL/EVP/Sign.hsc" #-} + +-- |Message signing using asymmetric cipher and message digest +-- algorithm. This is an opposite of "OpenSSL.EVP.Verify". + +module OpenSSL.EVP.Sign + ( sign + , signBS + , signLBS + ) + where + +import Control.Monad +import Data.ByteString.Base +import qualified Data.ByteString.Char8 as B8 +import qualified Data.ByteString.Lazy.Char8 as L8 +import Foreign +import Foreign.C +import OpenSSL.EVP.Digest +import OpenSSL.EVP.PKey +import OpenSSL.Utils + + +foreign import ccall unsafe "EVP_SignFinal" + _SignFinal :: Ptr EVP_MD_CTX -> Ptr CChar -> Ptr CUInt -> Ptr EVP_PKEY -> IO Int + + +signFinal :: DigestCtx -> PKey -> IO String +signFinal ctx pkey + = do maxLen <- pkeySize pkey + withDigestCtxPtr ctx $ \ ctxPtr -> + withPKeyPtr pkey $ \ pkeyPtr -> + allocaArray maxLen $ \ bufPtr -> + alloca $ \ bufLenPtr -> + do _SignFinal ctxPtr bufPtr bufLenPtr pkeyPtr + >>= failIf (/= 1) + bufLen <- liftM fromIntegral $ peek bufLenPtr + peekCStringLen (bufPtr, bufLen) + + +-- |@'sign'@ generates a signature from a stream of data. The string +-- must not contain any letters which aren't in the range of U+0000 - +-- U+00FF. +sign :: Digest -- ^ message digest algorithm to use + -> PKey -- ^ private key to sign the message digest + -> String -- ^ input string + -> IO String -- ^ the result signature +sign md pkey input + = signLBS md pkey $ L8.pack input + +-- |@'signBS'@ generates a signature from a chunk of data. +signBS :: Digest -- ^ message digest algorithm to use + -> PKey -- ^ private key to sign the message digest + -> ByteString -- ^ input string + -> IO String -- ^ the result signature +signBS md pkey input + = do ctx <- digestStrictly md input + signFinal ctx pkey + +-- |@'signLBS'@ generates a signature from a stream of data. +signLBS :: Digest -- ^ message digest algorithm to use + -> PKey -- ^ private key to sign the message digest + -> LazyByteString -- ^ input string + -> IO String -- ^ the result signature +signLBS md pkey input + = do ctx <- digestLazily md input + signFinal ctx pkey diff --git a/OpenSSL/EVP/Sign.hsc b/OpenSSL/EVP/Sign.hsc --- a/OpenSSL/EVP/Sign.hsc +++ b/OpenSSL/EVP/Sign.hsc @@ -11,7 +11,6 @@ where import Control.Monad -import Data.ByteString.Base import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Lazy.Char8 as L8 import Foreign @@ -51,7 +50,7 @@ -- |@'signBS'@ generates a signature from a chunk of data. signBS :: Digest -- ^ message digest algorithm to use -> PKey -- ^ private key to sign the message digest - -> ByteString -- ^ input string + -> B8.ByteString -- ^ input string -> IO String -- ^ the result signature signBS md pkey input = do ctx <- digestStrictly md input @@ -60,7 +59,7 @@ -- |@'signLBS'@ generates a signature from a stream of data. signLBS :: Digest -- ^ message digest algorithm to use -> PKey -- ^ private key to sign the message digest - -> LazyByteString -- ^ input string + -> L8.ByteString -- ^ input string -> IO String -- ^ the result signature signLBS md pkey input = do ctx <- digestLazily md input diff --git a/OpenSSL/EVP/Verify.hs b/OpenSSL/EVP/Verify.hs new file mode 100644 --- /dev/null +++ b/OpenSSL/EVP/Verify.hs @@ -0,0 +1,79 @@ +{-# OPTIONS_GHC -optc-D__GLASGOW_HASKELL__=606 #-} +{-# LINE 1 "OpenSSL/EVP/Verify.hsc" #-} +{- -*- haskell -*- -} +{-# LINE 2 "OpenSSL/EVP/Verify.hsc" #-} + +-- |Message verification using asymmetric cipher and message digest +-- algorithm. This is an opposite of "OpenSSL.EVP.Sign". + +module OpenSSL.EVP.Verify + ( VerifyStatus(..) + , verify + , verifyBS + , verifyLBS + ) + where + +import Control.Monad +import Data.ByteString.Base +import qualified Data.ByteString.Char8 as B8 +import qualified Data.ByteString.Lazy.Char8 as L8 +import Data.Typeable +import Foreign +import Foreign.C +import OpenSSL.EVP.Digest +import OpenSSL.EVP.PKey +import OpenSSL.Utils + +-- |@'VerifyStatus'@ represents a result of verification. +data VerifyStatus = VerifySuccess + | VerifyFailure + deriving (Show, Eq, Typeable) + + +foreign import ccall unsafe "EVP_VerifyFinal" + _VerifyFinal :: Ptr EVP_MD_CTX -> Ptr CChar -> CUInt -> Ptr EVP_PKEY -> IO Int + + +verifyFinalBS :: DigestCtx -> String -> PKey -> IO VerifyStatus +verifyFinalBS ctx sig pkey + = withDigestCtxPtr ctx $ \ ctxPtr -> + withCStringLen sig $ \ (buf, len) -> + withPKeyPtr pkey $ \ pkeyPtr -> + _VerifyFinal ctxPtr buf (fromIntegral len) pkeyPtr >>= interpret + where + interpret :: Int -> IO VerifyStatus + interpret 1 = return VerifySuccess + interpret 0 = return VerifyFailure + interpret _ = raiseOpenSSLError + +-- |@'verify'@ verifies a signature and a stream of data. The string +-- must not contain any letters which aren't in the range of U+0000 - +-- U+00FF. +verify :: Digest -- ^ message digest algorithm to use + -> String -- ^ message signature + -> PKey -- ^ public key to verify the signature + -> String -- ^ input string to verify + -> IO VerifyStatus -- ^ the result of verification +verify md sig pkey input + = verifyLBS md sig pkey (L8.pack input) + +-- |@'verifyBS'@ verifies a signature and a chunk of data. +verifyBS :: Digest -- ^ message digest algorithm to use + -> String -- ^ message signature + -> PKey -- ^ public key to verify the signature + -> ByteString -- ^ input string to verify + -> IO VerifyStatus -- ^ the result of verification +verifyBS md sig pkey input + = do ctx <- digestStrictly md input + verifyFinalBS ctx sig pkey + +-- |@'verifyLBS'@ verifies a signature of a stream of data. +verifyLBS :: Digest -- ^ message digest algorithm to use + -> String -- ^ message signature + -> PKey -- ^ public key to verify the signature + -> LazyByteString -- ^ input string to verify + -> IO VerifyStatus -- ^ the result of verification +verifyLBS md sig pkey input + = do ctx <- digestLazily md input + verifyFinalBS ctx sig pkey diff --git a/OpenSSL/EVP/Verify.hsc b/OpenSSL/EVP/Verify.hsc --- a/OpenSSL/EVP/Verify.hsc +++ b/OpenSSL/EVP/Verify.hsc @@ -12,7 +12,6 @@ where import Control.Monad -import Data.ByteString.Base import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Lazy.Char8 as L8 import Data.Typeable @@ -59,7 +58,7 @@ verifyBS :: Digest -- ^ message digest algorithm to use -> String -- ^ message signature -> PKey -- ^ public key to verify the signature - -> ByteString -- ^ input string to verify + -> B8.ByteString -- ^ input string to verify -> IO VerifyStatus -- ^ the result of verification verifyBS md sig pkey input = do ctx <- digestStrictly md input @@ -69,7 +68,7 @@ verifyLBS :: Digest -- ^ message digest algorithm to use -> String -- ^ message signature -> PKey -- ^ public key to verify the signature - -> LazyByteString -- ^ input string to verify + -> L8.ByteString -- ^ input string to verify -> IO VerifyStatus -- ^ the result of verification verifyLBS md sig pkey input = do ctx <- digestLazily md input diff --git a/OpenSSL/Objects.hs b/OpenSSL/Objects.hs new file mode 100644 --- /dev/null +++ b/OpenSSL/Objects.hs @@ -0,0 +1,74 @@ +{-# OPTIONS_GHC -optc-D__GLASGOW_HASKELL__=606 #-} +{-# INCLUDE "HsOpenSSL.h" #-} +{-# LINE 1 "OpenSSL/Objects.hsc" #-} + +{-# LINE 2 "OpenSSL/Objects.hsc" #-} + +module OpenSSL.Objects + ( ObjNameType(..) + , getObjNames + ) + where + +import Data.IORef +import Foreign +import Foreign.C + + +type ObjName = Ptr OBJ_NAME +data OBJ_NAME + +type DoAllCallback = ObjName -> Ptr () -> IO () + + +foreign import ccall safe "OBJ_NAME_do_all" + _NAME_do_all :: Int -> FunPtr DoAllCallback -> Ptr () -> IO () + +foreign import ccall safe "OBJ_NAME_do_all_sorted" + _NAME_do_all_sorted :: Int -> FunPtr DoAllCallback -> Ptr () -> IO () + +foreign import ccall "wrapper" + mkDoAllCallback :: DoAllCallback -> IO (FunPtr DoAllCallback) + + +data ObjNameType = MDMethodType + | CipherMethodType + | PKeyMethodType + | CompMethodType + +objNameTypeToInt :: ObjNameType -> Int +objNameTypeToInt MDMethodType = 1 +{-# LINE 37 "OpenSSL/Objects.hsc" #-} +objNameTypeToInt CipherMethodType = 2 +{-# LINE 38 "OpenSSL/Objects.hsc" #-} +objNameTypeToInt PKeyMethodType = 3 +{-# LINE 39 "OpenSSL/Objects.hsc" #-} +objNameTypeToInt CompMethodType = 4 +{-# LINE 40 "OpenSSL/Objects.hsc" #-} + + +iterateObjNames :: ObjNameType -> Bool -> (ObjName -> IO ()) -> IO () +iterateObjNames nameType wantSorted cb + = do cbPtr <- mkDoAllCallback $ \ name _ -> cb name + let action = if wantSorted then + _NAME_do_all_sorted + else + _NAME_do_all + action (objNameTypeToInt nameType) cbPtr nullPtr + freeHaskellFunPtr cbPtr + + +objNameStr :: ObjName -> IO String +objNameStr name + = do strPtr <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) name +{-# LINE 56 "OpenSSL/Objects.hsc" #-} + peekCString strPtr + + +getObjNames :: ObjNameType -> Bool -> IO [String] +getObjNames nameType wantSorted + = do listRef <- newIORef [] + iterateObjNames nameType wantSorted $ \ name -> + do nameStr <- objNameStr name + modifyIORef listRef (++ [nameStr]) + readIORef listRef diff --git a/OpenSSL/PEM.hs b/OpenSSL/PEM.hs new file mode 100644 --- /dev/null +++ b/OpenSSL/PEM.hs @@ -0,0 +1,462 @@ +{-# OPTIONS_GHC -optc-D__GLASGOW_HASKELL__=606 #-} +{-# LINE 1 "OpenSSL/PEM.hsc" #-} +{- -*- haskell -*- -} +{-# LINE 2 "OpenSSL/PEM.hsc" #-} + +-- |An interface to PEM routines. + +module OpenSSL.PEM + ( -- * Password supply + PemPasswordCallback + , PemPasswordRWState(..) + , PemPasswordSupply(..) + + -- * Private key + , writePKCS8PrivateKey + , readPrivateKey + + -- * Public key + , writePublicKey + , readPublicKey + + -- * X.509 certificate + , writeX509 + , readX509 + + -- * PKCS#10 certificate request + , PemX509ReqFormat(..) + , writeX509Req + , readX509Req + + -- * Certificate Revocation List + , writeCRL + , readCRL + + -- * PKCS#7 structure + , writePkcs7 + , readPkcs7 + ) + where + +import Control.Exception +import Control.Monad +import Foreign +import Foreign.C +import OpenSSL.BIO +import OpenSSL.EVP.Cipher +import OpenSSL.EVP.PKey +import OpenSSL.PKCS7 +import OpenSSL.Utils +import OpenSSL.X509 +import OpenSSL.X509.Request +import OpenSSL.X509.Revocation +import Prelude hiding (catch) +import System.IO + + +-- |@'PemPasswordCallback'@ represents a callback function to supply a +-- password. +type PemPasswordCallback + = Int -- ^ maximum length of the password to be + -- accepted + -> PemPasswordRWState -- ^ context + -> IO String -- ^ the result password + +type PemPasswordCallback' = Ptr CChar -> Int -> Int -> Ptr () -> IO Int + + +-- |@'PemPasswordRWState'@ represents a context of +-- 'PemPasswordCallback'. +data PemPasswordRWState = PwRead -- ^ The callback was called to get + -- a password to read something + -- encrypted. + | PwWrite -- ^ The callback was called to get + -- a password to encrypt + -- something. + +-- |@'PemPasswordSupply'@ represents a way to supply password. +-- +-- FIXME: using PwTTY causes an error but I don't know why: +-- \"error:0906406D:PEM routines:DEF_CALLBACK:problems getting +-- password\" +data PemPasswordSupply = PwNone -- ^ no password + | PwStr String -- ^ password in a static string + | PwCallback PemPasswordCallback -- ^ get a + -- password + -- by a + -- callback + | PwTTY -- ^ read a password from TTY + + +foreign import ccall "wrapper" + mkPemPasswordCallback :: PemPasswordCallback' -> IO (FunPtr PemPasswordCallback') + + +rwflagToState :: Int -> PemPasswordRWState +rwflagToState 0 = PwRead +rwflagToState 1 = PwWrite + + +callPasswordCB :: PemPasswordCallback -> PemPasswordCallback' +callPasswordCB cb buf bufLen rwflag _ + = let mode = rwflagToState rwflag + try = do passStr <- cb bufLen mode + let passLen = length passStr + + when (passLen > bufLen) + $ failForTooLongPassword bufLen + + pokeArray buf $ map (toEnum . fromEnum) passStr + return passLen + in + try `catch` \ exc -> + do hPutStrLn stderr $ show exc + return 0 -- zero indicates an error + where + failForTooLongPassword :: Int -> IO a + failForTooLongPassword len + = fail ("callPasswordCB: the password which the callback returned is too long: " + ++ "it must be at most " ++ show len ++ " bytes.") + + +{- PKCS#8 -------------------------------------------------------------------- -} + +foreign import ccall safe "PEM_write_bio_PKCS8PrivateKey" + _write_bio_PKCS8PrivateKey :: Ptr BIO_ + -> Ptr EVP_PKEY + -> Ptr EVP_CIPHER + -> Ptr CChar + -> Int + -> FunPtr PemPasswordCallback' + -> Ptr a + -> IO Int + +writePKCS8PrivateKey' :: BIO + -> PKey + -> Maybe (Cipher, PemPasswordSupply) + -> IO () +writePKCS8PrivateKey' bio pkey encryption + = withBioPtr bio $ \ bioPtr -> + withPKeyPtr pkey $ \ pkeyPtr -> + do ret <- case encryption of + Nothing + -> _write_bio_PKCS8PrivateKey bioPtr pkeyPtr nullPtr nullPtr 0 nullFunPtr nullPtr + + Just (_, PwNone) + -> _write_bio_PKCS8PrivateKey bioPtr pkeyPtr nullPtr nullPtr 0 nullFunPtr nullPtr + + Just (cipher, PwStr passStr) + -> withCStringLen passStr $ \ (passPtr, passLen) -> + withCipherPtr cipher $ \ cipherPtr -> + _write_bio_PKCS8PrivateKey bioPtr pkeyPtr cipherPtr passPtr passLen nullFunPtr nullPtr + + Just (cipher, PwCallback cb) + -> withCipherPtr cipher $ \ cipherPtr -> + do cbPtr <- mkPemPasswordCallback $ callPasswordCB cb + ret <- _write_bio_PKCS8PrivateKey bioPtr pkeyPtr cipherPtr nullPtr 0 cbPtr nullPtr + freeHaskellFunPtr cbPtr + return ret + + Just (cipher, PwTTY) + -> withCipherPtr cipher $ \ cipherPtr -> + _write_bio_PKCS8PrivateKey bioPtr pkeyPtr cipherPtr nullPtr 0 nullFunPtr nullPtr + failIf (/= 1) ret + return () + +-- |@'writePKCS8PrivateKey'@ writes a private key to PEM string in +-- PKCS#8 format. +writePKCS8PrivateKey + :: PKey -- ^ private key to write + -> Maybe (Cipher, PemPasswordSupply) -- ^ Either (symmetric cipher + -- algorithm, password + -- supply) or @Nothing@. If + -- @Nothing@ is given the + -- private key is not + -- encrypted. + -> IO String -- ^ the result PEM string +writePKCS8PrivateKey pkey encryption + = do mem <- newMem + writePKCS8PrivateKey' mem pkey encryption + bioRead mem + + +foreign import ccall safe "PEM_read_bio_PrivateKey" + _read_bio_PrivateKey :: Ptr BIO_ + -> Ptr (Ptr EVP_PKEY) + -> FunPtr PemPasswordCallback' + -> Ptr () + -> IO (Ptr EVP_PKEY) + +readPrivateKey' :: BIO -> PemPasswordSupply -> IO PKey +readPrivateKey' bio supply + = withBioPtr bio $ \ bioPtr -> + do pkeyPtr <- case supply of + PwNone + -> withCString "" $ \ strPtr -> + _read_bio_PrivateKey bioPtr nullPtr nullFunPtr (castPtr strPtr) + + PwStr passStr + -> do cbPtr <- mkPemPasswordCallback $ + callPasswordCB $ \ _ _ -> + return passStr + pkeyPtr <- _read_bio_PrivateKey bioPtr nullPtr cbPtr nullPtr + freeHaskellFunPtr cbPtr + return pkeyPtr + PwCallback cb + -> do cbPtr <- mkPemPasswordCallback $ callPasswordCB cb + pkeyPtr <- _read_bio_PrivateKey bioPtr nullPtr cbPtr nullPtr + freeHaskellFunPtr cbPtr + return pkeyPtr + PwTTY + -> _read_bio_PrivateKey bioPtr nullPtr nullFunPtr nullPtr + failIfNull pkeyPtr + wrapPKeyPtr pkeyPtr + +-- |@'readPrivateKey' pem supply@ reads a private key in PEM string. +readPrivateKey :: String -> PemPasswordSupply -> IO PKey +readPrivateKey pemStr supply + = do mem <- newConstMem pemStr + readPrivateKey' mem supply + + +{- Public Key ---------------------------------------------------------------- -} + +foreign import ccall unsafe "PEM_write_bio_PUBKEY" + _write_bio_PUBKEY :: Ptr BIO_ -> Ptr EVP_PKEY -> IO Int + +foreign import ccall unsafe "PEM_read_bio_PUBKEY" + _read_bio_PUBKEY :: Ptr BIO_ + -> Ptr (Ptr EVP_PKEY) + -> FunPtr PemPasswordCallback' + -> Ptr () + -> IO (Ptr EVP_PKEY) + + +writePublicKey' :: BIO -> PKey -> IO () +writePublicKey' bio pkey + = withBioPtr bio $ \ bioPtr -> + withPKeyPtr pkey $ \ pkeyPtr -> + _write_bio_PUBKEY bioPtr pkeyPtr >>= failIf (/= 1) >> return () + +-- |@'writePublicKey' pubkey@ writes a public to PEM string. +writePublicKey :: PKey -> IO String +writePublicKey pkey + = do mem <- newMem + writePublicKey' mem pkey + bioRead mem + +-- Why the heck PEM_read_bio_PUBKEY takes pem_password_cb? Is there +-- any form of encrypted public key? +readPublicKey' :: BIO -> IO PKey +readPublicKey' bio + = withBioPtr bio $ \ bioPtr -> + withCString "" $ \ passPtr -> + _read_bio_PUBKEY bioPtr nullPtr nullFunPtr (castPtr passPtr) + >>= failIfNull + >>= wrapPKeyPtr + +-- |@'readPublicKey' pem@ reads a public key in PEM string. +readPublicKey :: String -> IO PKey +readPublicKey pemStr + = newConstMem pemStr >>= readPublicKey' + + +{- X.509 certificate --------------------------------------------------------- -} + +foreign import ccall unsafe "PEM_write_bio_X509_AUX" + _write_bio_X509_AUX :: Ptr BIO_ + -> Ptr X509_ + -> IO Int + +foreign import ccall safe "PEM_read_bio_X509_AUX" + _read_bio_X509_AUX :: Ptr BIO_ + -> Ptr (Ptr X509_) + -> FunPtr PemPasswordCallback' + -> Ptr () + -> IO (Ptr X509_) + +writeX509' :: BIO -> X509 -> IO () +writeX509' bio x509 + = withBioPtr bio $ \ bioPtr -> + withX509Ptr x509 $ \ x509Ptr -> + _write_bio_X509_AUX bioPtr x509Ptr + >>= failIf (/= 1) + >> return () + +-- |@'writeX509' cert@ writes an X.509 certificate to PEM string. +writeX509 :: X509 -> IO String +writeX509 x509 + = do mem <- newMem + writeX509' mem x509 + bioRead mem + + +-- I believe X.509 isn't encrypted. +readX509' :: BIO -> IO X509 +readX509' bio + = withBioPtr bio $ \ bioPtr -> + withCString "" $ \ passPtr -> + _read_bio_X509_AUX bioPtr nullPtr nullFunPtr (castPtr passPtr) + >>= failIfNull + >>= wrapX509 + +-- |@'readX509' pem@ reads an X.509 certificate in PEM string. +readX509 :: String -> IO X509 +readX509 pemStr + = newConstMem pemStr >>= readX509' + + +{- PKCS#10 certificate request ----------------------------------------------- -} + +foreign import ccall unsafe "PEM_write_bio_X509_REQ" + _write_bio_X509_REQ :: Ptr BIO_ + -> Ptr X509_REQ + -> IO Int + +foreign import ccall unsafe "PEM_write_bio_X509_REQ_NEW" + _write_bio_X509_REQ_NEW :: Ptr BIO_ + -> Ptr X509_REQ + -> IO Int + +foreign import ccall safe "PEM_read_bio_X509_REQ" + _read_bio_X509_REQ :: Ptr BIO_ + -> Ptr (Ptr X509_REQ) + -> FunPtr PemPasswordCallback' + -> Ptr () + -> IO (Ptr X509_REQ) + +-- |@'PemX509ReqFormat'@ represents format of PKCS#10 certificate +-- request. +data PemX509ReqFormat + = ReqNewFormat -- ^ The new format, whose header is \"NEW + -- CERTIFICATE REQUEST\". + | ReqOldFormat -- ^ The old format, whose header is \"CERTIFICATE + -- REQUEST\". + + +writeX509Req' :: BIO -> X509Req -> PemX509ReqFormat -> IO () +writeX509Req' bio req format + = withBioPtr bio $ \ bioPtr -> + withX509ReqPtr req $ \ reqPtr -> + writer bioPtr reqPtr + >>= failIf (/= 1) + >> return () + where + writer = case format of + ReqNewFormat -> _write_bio_X509_REQ_NEW + ReqOldFormat -> _write_bio_X509_REQ + +-- |@'writeX509Req'@ writes a PKCS#10 certificate request to PEM +-- string. +writeX509Req :: X509Req -- ^ request + -> PemX509ReqFormat -- ^ format + -> IO String -- ^ the result PEM string +writeX509Req req format + = do mem <- newMem + writeX509Req' mem req format + bioRead mem + + +readX509Req' :: BIO -> IO X509Req +readX509Req' bio + = withBioPtr bio $ \ bioPtr -> + withCString "" $ \ passPtr -> + _read_bio_X509_REQ bioPtr nullPtr nullFunPtr (castPtr passPtr) + >>= failIfNull + >>= wrapX509Req + +-- |@'readX509Req'@ reads a PKCS#10 certificate request in PEM string. +readX509Req :: String -> IO X509Req +readX509Req pemStr + = newConstMem pemStr >>= readX509Req' + + +{- Certificate Revocation List ----------------------------------------------- -} + +foreign import ccall unsafe "PEM_write_bio_X509_CRL" + _write_bio_X509_CRL :: Ptr BIO_ + -> Ptr X509_CRL + -> IO Int + +foreign import ccall safe "PEM_read_bio_X509_CRL" + _read_bio_X509_CRL :: Ptr BIO_ + -> Ptr (Ptr X509_CRL) + -> FunPtr PemPasswordCallback' + -> Ptr () + -> IO (Ptr X509_CRL) + + +writeCRL' :: BIO -> CRL -> IO () +writeCRL' bio crl + = withBioPtr bio $ \ bioPtr -> + withCRLPtr crl $ \ crlPtr -> + _write_bio_X509_CRL bioPtr crlPtr + >>= failIf (/= 1) + >> return () + +-- |@'writeCRL' crl@ writes a Certificate Revocation List to PEM +-- string. +writeCRL :: CRL -> IO String +writeCRL crl + = do mem <- newMem + writeCRL' mem crl + bioRead mem + + +readCRL' :: BIO -> IO CRL +readCRL' bio + = withBioPtr bio $ \ bioPtr -> + withCString "" $ \ passPtr -> + _read_bio_X509_CRL bioPtr nullPtr nullFunPtr (castPtr passPtr) + >>= failIfNull + >>= wrapCRL + +-- |@'readCRL' pem@ reads a Certificate Revocation List in PEM string. +readCRL :: String -> IO CRL +readCRL pemStr + = newConstMem pemStr >>= readCRL' + + +{- PKCS#7 -------------------------------------------------------------------- -} + +foreign import ccall unsafe "PEM_write_bio_PKCS7" + _write_bio_PKCS7 :: Ptr BIO_ + -> Ptr PKCS7 + -> IO Int + +foreign import ccall safe "PEM_read_bio_PKCS7" + _read_bio_PKCS7 :: Ptr BIO_ + -> Ptr (Ptr PKCS7) + -> FunPtr PemPasswordCallback' + -> Ptr () + -> IO (Ptr PKCS7) + + +writePkcs7' :: BIO -> Pkcs7 -> IO () +writePkcs7' bio pkcs7 + = withBioPtr bio $ \ bioPtr -> + withPkcs7Ptr pkcs7 $ \ pkcs7Ptr -> + _write_bio_PKCS7 bioPtr pkcs7Ptr + >>= failIf (/= 1) + >> return () + +-- |@'writePkcs7' p7@ writes a PKCS#7 structure to PEM string. +writePkcs7 :: Pkcs7 -> IO String +writePkcs7 pkcs7 + = do mem <- newMem + writePkcs7' mem pkcs7 + bioRead mem + + +readPkcs7' :: BIO -> IO Pkcs7 +readPkcs7' bio + = withBioPtr bio $ \ bioPtr -> + withCString "" $ \ passPtr -> + _read_bio_PKCS7 bioPtr nullPtr nullFunPtr (castPtr passPtr) + >>= failIfNull + >>= wrapPkcs7Ptr + +-- |@'readPkcs7' pem@ reads a PKCS#7 structure in PEM string. +readPkcs7 :: String -> IO Pkcs7 +readPkcs7 pemStr + = newConstMem pemStr >>= readPkcs7' diff --git a/OpenSSL/PEM.hsc b/OpenSSL/PEM.hsc --- a/OpenSSL/PEM.hsc +++ b/OpenSSL/PEM.hsc @@ -35,12 +35,12 @@ ) where -import Control.Exception +import Control.Exception hiding (try) import Control.Monad import Foreign import Foreign.C import OpenSSL.BIO -import OpenSSL.EVP.Cipher +import OpenSSL.EVP.Cipher hiding (cipher) import OpenSSL.EVP.PKey import OpenSSL.PKCS7 import OpenSSL.Utils @@ -92,6 +92,7 @@ rwflagToState :: Int -> PemPasswordRWState rwflagToState 0 = PwRead rwflagToState 1 = PwWrite +rwflagToState _ = undefined callPasswordCB :: PemPasswordCallback -> PemPasswordCallback' diff --git a/OpenSSL/PKCS7.hs b/OpenSSL/PKCS7.hs new file mode 100644 --- /dev/null +++ b/OpenSSL/PKCS7.hs @@ -0,0 +1,436 @@ +{-# OPTIONS_GHC -optc-D__GLASGOW_HASKELL__=606 #-} +{-# INCLUDE "HsOpenSSL.h" #-} +{-# 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 +import OpenSSL.EVP.PKey +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 -> Int +flagToInt Pkcs7Text = 1 +{-# LINE 71 "OpenSSL/PKCS7.hsc" #-} +flagToInt Pkcs7NoCerts = 2 +{-# LINE 72 "OpenSSL/PKCS7.hsc" #-} +flagToInt Pkcs7NoSigs = 4 +{-# LINE 73 "OpenSSL/PKCS7.hsc" #-} +flagToInt Pkcs7NoChain = 8 +{-# LINE 74 "OpenSSL/PKCS7.hsc" #-} +flagToInt Pkcs7NoIntern = 16 +{-# LINE 75 "OpenSSL/PKCS7.hsc" #-} +flagToInt Pkcs7NoVerify = 32 +{-# LINE 76 "OpenSSL/PKCS7.hsc" #-} +flagToInt Pkcs7Detached = 64 +{-# LINE 77 "OpenSSL/PKCS7.hsc" #-} +flagToInt Pkcs7Binary = 128 +{-# LINE 78 "OpenSSL/PKCS7.hsc" #-} +flagToInt Pkcs7NoAttr = 256 +{-# LINE 79 "OpenSSL/PKCS7.hsc" #-} +flagToInt Pkcs7NoSmimeCap = 512 +{-# LINE 80 "OpenSSL/PKCS7.hsc" #-} +flagToInt Pkcs7NoOldMimeType = 1024 +{-# LINE 81 "OpenSSL/PKCS7.hsc" #-} +flagToInt Pkcs7CRLFEOL = 2048 +{-# LINE 82 "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] -> 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 + + +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 -> PKey -> [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 :: X509 -- ^ certificate to sign with + -> PKey -- ^ 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 + 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'@ 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' :: Pkcs7 -> PKey -> 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 :: Pkcs7 -- ^ The PKCS#7 structure to decrypt. + -> PKey -- ^ 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_ -> Int -> IO Int + +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 + wrapBioPtr outBioPtr >>= return . Just + + return (pkcs7, outBio) diff --git a/OpenSSL/PKCS7.hsc b/OpenSSL/PKCS7.hsc --- a/OpenSSL/PKCS7.hsc +++ b/OpenSSL/PKCS7.hsc @@ -33,7 +33,7 @@ import Foreign import Foreign.C import OpenSSL.BIO -import OpenSSL.EVP.Cipher +import OpenSSL.EVP.Cipher hiding (cipher) import OpenSSL.EVP.PKey import OpenSSL.Stack import OpenSSL.Utils diff --git a/OpenSSL/RSA.hs b/OpenSSL/RSA.hs new file mode 100644 --- /dev/null +++ b/OpenSSL/RSA.hs @@ -0,0 +1,164 @@ +{-# OPTIONS_GHC -optc-D__GLASGOW_HASKELL__=606 #-} +{-# INCLUDE "HsOpenSSL.h" #-} +{-# LINE 1 "OpenSSL/RSA.hsc" #-} +{- -*- haskell -*- -} +{-# LINE 2 "OpenSSL/RSA.hsc" #-} + +-- #prune + +-- |An interface to RSA public key generator. + + +{-# LINE 8 "OpenSSL/RSA.hsc" #-} + +module OpenSSL.RSA + ( -- * Type + RSA + , RSA_ -- private + , withRSAPtr -- private + + -- * Generating keypair + , RSAGenKeyCallback + , generateKey + + -- * Exploring keypair + , rsaN + , rsaE + , rsaD + , rsaP + , rsaQ + , rsaDMP1 + , rsaDMQ1 + , rsaIQMP + ) + where + +import Control.Monad +import Foreign +import OpenSSL.BN +import OpenSSL.Utils + +-- |@'RSA'@ is an opaque object that represents either RSA public key +-- or public\/private keypair. +newtype RSA = RSA (ForeignPtr RSA_) +data RSA_ + + +foreign import ccall unsafe "&RSA_free" + _free :: FunPtr (Ptr RSA_ -> IO ()) + + +withRSAPtr :: RSA -> (Ptr RSA_ -> IO a) -> IO a +withRSAPtr (RSA rsa) = withForeignPtr rsa + + +{- generation --------------------------------------------------------------- -} + +-- |@'RSAGenKeyCallback'@ represents a callback function to get +-- informed the progress of RSA key generation. +-- +-- * @callback 0 i@ is called after generating the @i@-th potential +-- prime number. +-- +-- * While the number is being tested for primality, @callback 1 j@ is +-- called after the @j@-th iteration (j = 0, 1, ...). +-- +-- * When the @n@-th randomly generated prime is rejected as not +-- suitable for the key, @callback 2 n@ is called. +-- +-- * When a random @p@ has been found with @p@-1 relatively prime to +-- @e@, it is called as @callback 3 0@. +-- +-- * The process is then repeated for prime @q@ with @callback 3 1@. +type RSAGenKeyCallback = Int -> Int -> IO () + +type RSAGenKeyCallback' = Int -> Int -> Ptr () -> IO () + + +foreign import ccall "wrapper" + mkGenKeyCallback :: RSAGenKeyCallback' -> IO (FunPtr RSAGenKeyCallback') + +foreign import ccall safe "RSA_generate_key" + _generate_key :: Int -> Int -> FunPtr RSAGenKeyCallback' -> Ptr a -> IO (Ptr RSA_) + +-- |@'generateKey'@ generates an RSA keypair. +generateKey :: Int -- ^ The number of bits of the public modulus + -- (i.e. key size). Key sizes with @n < 1024@ + -- should be considered insecure. + -> Int -- ^ The public exponent. It is an odd number, + -- typically 3, 17 or 65537. + -> Maybe RSAGenKeyCallback -- ^ A callback function. + -> IO RSA -- ^ The generated keypair. + +generateKey nbits e Nothing + = do ptr <- _generate_key nbits e nullFunPtr nullPtr + failIfNull ptr + newForeignPtr _free ptr >>= return . RSA + +generateKey nbits e (Just cb) + = do cbPtr <- mkGenKeyCallback + $ \ arg1 arg2 _ -> cb arg1 arg2 + ptr <- _generate_key nbits e cbPtr nullPtr + freeHaskellFunPtr cbPtr + failIfNull ptr + newForeignPtr _free ptr >>= return . RSA + + +{- exploration -------------------------------------------------------------- -} + +peekRSAPublic :: (Ptr RSA_ -> IO (Ptr BIGNUM)) -> RSA -> IO Integer +peekRSAPublic peeker rsa + = withRSAPtr rsa $ \ rsaPtr -> + do bn <- peeker rsaPtr + when (bn == nullPtr) $ fail "peekRSAPublic: got a nullPtr" + peekBN (wrapBN bn) + + +peekRSAPrivate :: (Ptr RSA_ -> IO (Ptr BIGNUM)) -> RSA -> IO (Maybe Integer) +peekRSAPrivate peeker rsa + = withRSAPtr rsa $ \ rsaPtr -> + do bn <- peeker rsaPtr + if bn == nullPtr then + return Nothing + else + peekBN (wrapBN bn) >>= return . Just + +-- |@'rsaN' pubKey@ returns the public modulus of the key. +rsaN :: RSA -> IO Integer +rsaN = peekRSAPublic ((\hsc_ptr -> peekByteOff hsc_ptr 16)) +{-# LINE 124 "OpenSSL/RSA.hsc" #-} + +-- |@'rsaE' pubKey@ returns the public exponent of the key. +rsaE :: RSA -> IO Integer +rsaE = peekRSAPublic ((\hsc_ptr -> peekByteOff hsc_ptr 20)) +{-# LINE 128 "OpenSSL/RSA.hsc" #-} + +-- |@'rsaD' privKey@ returns the private exponent of the key. If +-- @privKey@ is not really a private key, the result is @Nothing@. +rsaD :: RSA -> IO (Maybe Integer) +rsaD = peekRSAPrivate ((\hsc_ptr -> peekByteOff hsc_ptr 24)) +{-# LINE 133 "OpenSSL/RSA.hsc" #-} + +-- |@'rsaP' privkey@ returns the secret prime factor @p@ of the key. +rsaP :: RSA -> IO (Maybe Integer) +rsaP = peekRSAPrivate ((\hsc_ptr -> peekByteOff hsc_ptr 28)) +{-# LINE 137 "OpenSSL/RSA.hsc" #-} + +-- |@'rsaQ' privkey@ returns the secret prime factor @q@ of the key. +rsaQ :: RSA -> IO (Maybe Integer) +rsaQ = peekRSAPrivate ((\hsc_ptr -> peekByteOff hsc_ptr 32)) +{-# LINE 141 "OpenSSL/RSA.hsc" #-} + +-- |@'rsaDMP1' privkey@ returns @d mod (p-1)@ of the key. +rsaDMP1 :: RSA -> IO (Maybe Integer) +rsaDMP1 = peekRSAPrivate ((\hsc_ptr -> peekByteOff hsc_ptr 36)) +{-# LINE 145 "OpenSSL/RSA.hsc" #-} + +-- |@'rsaDMQ1' privkey@ returns @d mod (q-1)@ of the key. +rsaDMQ1 :: RSA -> IO (Maybe Integer) +rsaDMQ1 = peekRSAPrivate ((\hsc_ptr -> peekByteOff hsc_ptr 40)) +{-# LINE 149 "OpenSSL/RSA.hsc" #-} + +-- |@'rsaIQMP' privkey@ returns @q^-1 mod p@ of the key. +rsaIQMP :: RSA -> IO (Maybe Integer) +rsaIQMP = peekRSAPrivate ((\hsc_ptr -> peekByteOff hsc_ptr 44)) diff --git a/OpenSSL/Random.hs b/OpenSSL/Random.hs new file mode 100644 --- /dev/null +++ b/OpenSSL/Random.hs @@ -0,0 +1,61 @@ +{-# OPTIONS_GHC -optc-D__GLASGOW_HASKELL__=606 #-} +{-# INCLUDE "HsOpenSSL.h" #-} +{-# LINE 1 "OpenSSL/Random.hsc" #-} +{- -*- haskell -*- -} +{-# LINE 2 "OpenSSL/Random.hsc" #-} + +-- | PRNG services +-- See +-- For random Integer generation, see "OpenSSL.BN" + + +{-# LINE 8 "OpenSSL/Random.hsc" #-} + +module OpenSSL.Random + ( -- * Random byte generation + randBytes + , prandBytes + , add + ) where + +import Foreign +import Foreign.C.Types +import qualified Data.ByteString as BS +import OpenSSL.Utils + +foreign import ccall unsafe "RAND_bytes" + _RAND_bytes :: Ptr CChar -> CInt -> IO CInt + +foreign import ccall unsafe "RAND_pseudo_bytes" + _RAND_pseudo_bytes :: Ptr CChar -> CInt -> IO () + +foreign import ccall unsafe "RAND_add" + _RAND_add :: Ptr CChar -> CInt -> CInt -> IO () + +-- | Return a bytestring consisting of the given number of strongly random +-- bytes +randBytes :: Int -- ^ the number of bytes requested + -> IO BS.ByteString +randBytes n = + allocaArray n $ \bufPtr -> + do _RAND_bytes bufPtr (fromIntegral n) >>= failIf (/= 1) + BS.copyCStringLen (bufPtr, n) + +-- | Return a bytestring consisting of the given number of pseudo random +-- bytes +prandBytes :: Int -- ^ the number of bytes requested + -> IO BS.ByteString +prandBytes n = + allocaArray n $ \bufPtr -> + do _RAND_pseudo_bytes bufPtr (fromIntegral n) + BS.copyCStringLen (bufPtr, n) + +-- | Add data to the entropy pool. It's safe to add sensitive information +-- (e.g. user passwords etc) to the pool. Also, adding data with an entropy +-- of 0 can never hurt. +add :: BS.ByteString -- ^ random data to be added to the pool + -> Int -- ^ the number of bits of entropy in the first argument + -> IO () +add bs entropy = + BS.useAsCStringLen bs $ \(ptr, len) -> + _RAND_add ptr (fromIntegral len) (fromIntegral entropy) diff --git a/OpenSSL/Random.hsc b/OpenSSL/Random.hsc --- a/OpenSSL/Random.hsc +++ b/OpenSSL/Random.hsc @@ -34,7 +34,7 @@ randBytes n = allocaArray n $ \bufPtr -> do _RAND_bytes bufPtr (fromIntegral n) >>= failIf (/= 1) - BS.copyCStringLen (bufPtr, n) + BS.packCStringLen (bufPtr, n) -- | Return a bytestring consisting of the given number of pseudo random -- bytes @@ -43,7 +43,7 @@ prandBytes n = allocaArray n $ \bufPtr -> do _RAND_pseudo_bytes bufPtr (fromIntegral n) - BS.copyCStringLen (bufPtr, n) + BS.packCStringLen (bufPtr, n) -- | Add data to the entropy pool. It's safe to add sensitive information -- (e.g. user passwords etc) to the pool. Also, adding data with an entropy diff --git a/OpenSSL/SSL.hs b/OpenSSL/SSL.hs new file mode 100644 --- /dev/null +++ b/OpenSSL/SSL.hs @@ -0,0 +1,14 @@ +{-# OPTIONS_GHC -optc-D__GLASGOW_HASKELL__=606 #-} +{-# LINE 1 "OpenSSL/SSL.hsc" #-} +module OpenSSL.SSL +{-# LINE 2 "OpenSSL/SSL.hsc" #-} + ( loadErrorStrings + , addAllAlgorithms + ) + where + +foreign import ccall unsafe "SSL_load_error_strings" + loadErrorStrings :: IO () + +foreign import ccall unsafe "HsOpenSSL_OpenSSL_add_all_algorithms" + addAllAlgorithms :: IO () diff --git a/OpenSSL/Stack.hs b/OpenSSL/Stack.hs new file mode 100644 --- /dev/null +++ b/OpenSSL/Stack.hs @@ -0,0 +1,62 @@ +{-# OPTIONS_GHC -optc-D__GLASGOW_HASKELL__=606 #-} +{-# LINE 1 "OpenSSL/Stack.hsc" #-} +module OpenSSL.Stack +{-# LINE 2 "OpenSSL/Stack.hsc" #-} + ( STACK + , mapStack + , withStack + , withForeignStack + ) + where + +import Control.Exception +import Foreign + + +data STACK + + +foreign import ccall unsafe "sk_new_null" + skNewNull :: IO (Ptr STACK) + +foreign import ccall unsafe "sk_free" + skFree :: Ptr STACK -> IO () + +foreign import ccall unsafe "sk_push" + skPush :: Ptr STACK -> Ptr () -> IO () + +foreign import ccall unsafe "sk_num" + skNum :: Ptr STACK -> IO Int + +foreign import ccall unsafe "sk_value" + skValue :: Ptr STACK -> Int -> IO (Ptr ()) + + +mapStack :: (Ptr a -> IO b) -> Ptr STACK -> IO [b] +mapStack m st + = do num <- skNum st + mapM (\ i -> skValue st i >>= return . castPtr >>= m) + $ take num [0..] + + +newStack :: [Ptr a] -> IO (Ptr STACK) +newStack values + = do st <- skNewNull + mapM_ (skPush st . castPtr) values + return st + + +withStack :: [Ptr a] -> (Ptr STACK -> IO b) -> IO b +withStack values 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 diff --git a/OpenSSL/Utils.hs b/OpenSSL/Utils.hs --- a/OpenSSL/Utils.hs +++ b/OpenSSL/Utils.hs @@ -51,6 +51,7 @@ hexByte 13 = 'd' hexByte 14 = 'e' hexByte 15 = 'f' + hexByte _ = undefined -- | Convert a hex string to an integer fromHex :: (Bits i) => String -> i @@ -79,3 +80,4 @@ byteHex 'D' = 13 byteHex 'E' = 14 byteHex 'F' = 15 + byteHex _ = undefined diff --git a/OpenSSL/X509.hs b/OpenSSL/X509.hs new file mode 100644 --- /dev/null +++ b/OpenSSL/X509.hs @@ -0,0 +1,375 @@ +{-# OPTIONS_GHC -optc-D__GLASGOW_HASKELL__=606 #-} +{-# LINE 1 "OpenSSL/X509.hsc" #-} +{- -*- haskell -*- -} +{-# LINE 2 "OpenSSL/X509.hsc" #-} + +-- #prune + +-- |An interface to X.509 certificate. + +module OpenSSL.X509 + ( -- * Type + X509 + , X509_ + + -- * Functions to manipulate certificate + , newX509 + , wrapX509 -- private + , withX509Ptr -- private + , withX509Stack -- private + , unsafeX509ToPtr -- private + , touchX509 -- private + + , compareX509 + + , signX509 + , verifyX509 + + , printX509 + + -- * Accessors + , getVersion + , setVersion + + , getSerialNumber + , setSerialNumber + + , getIssuerName + , setIssuerName + + , getSubjectName + , setSubjectName + + , getNotBefore + , setNotBefore + + , getNotAfter + , setNotAfter + + , getPublicKey + , setPublicKey + + , getSubjectEmail + ) + where + +import Control.Monad +import Data.Time.Clock +import Foreign +import Foreign.C +import OpenSSL.ASN1 +import OpenSSL.BIO +import OpenSSL.EVP.Digest +import OpenSSL.EVP.PKey +import OpenSSL.EVP.Verify +import OpenSSL.Utils +import OpenSSL.Stack +import OpenSSL.X509.Name + +-- |@'X509'@ is an opaque object that represents X.509 certificate. +newtype X509 = X509 (ForeignPtr X509_) +data X509_ + + +foreign import ccall unsafe "X509_new" + _new :: IO (Ptr X509_) + +foreign import ccall unsafe "&X509_free" + _free :: FunPtr (Ptr X509_ -> IO ()) + +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 + +foreign import ccall unsafe "X509_set_version" + _set_version :: Ptr X509_ -> CLong -> IO Int + +foreign import ccall unsafe "X509_get_serialNumber" + _get_serialNumber :: Ptr X509_ -> IO (Ptr ASN1_INTEGER) + +foreign import ccall unsafe "X509_set_serialNumber" + _set_serialNumber :: Ptr X509_ -> Ptr ASN1_INTEGER -> IO Int + +foreign import ccall unsafe "X509_get_issuer_name" + _get_issuer_name :: Ptr X509_ -> IO (Ptr X509_NAME) + +foreign import ccall unsafe "X509_set_issuer_name" + _set_issuer_name :: Ptr X509_ -> Ptr X509_NAME -> IO Int + +foreign import ccall unsafe "X509_get_subject_name" + _get_subject_name :: Ptr X509_ -> IO (Ptr X509_NAME) + +foreign import ccall unsafe "X509_set_subject_name" + _set_subject_name :: Ptr X509_ -> Ptr X509_NAME -> IO Int + +foreign import ccall unsafe "HsOpenSSL_X509_get_notBefore" + _get_notBefore :: Ptr X509_ -> IO (Ptr ASN1_TIME) + +foreign import ccall unsafe "X509_set_notBefore" + _set_notBefore :: Ptr X509_ -> Ptr ASN1_TIME -> IO Int + +foreign import ccall unsafe "HsOpenSSL_X509_get_notAfter" + _get_notAfter :: Ptr X509_ -> IO (Ptr ASN1_TIME) + +foreign import ccall unsafe "X509_set_notAfter" + _set_notAfter :: Ptr X509_ -> Ptr ASN1_TIME -> IO Int + +foreign import ccall unsafe "X509_get_pubkey" + _get_pubkey :: Ptr X509_ -> IO (Ptr EVP_PKEY) + +foreign import ccall unsafe "X509_set_pubkey" + _set_pubkey :: Ptr X509_ -> Ptr EVP_PKEY -> IO Int + +foreign import ccall unsafe "X509_get1_email" + _get1_email :: Ptr X509_ -> IO (Ptr STACK) + +foreign import ccall unsafe "X509_email_free" + _email_free :: Ptr STACK -> IO () + +foreign import ccall unsafe "X509_sign" + _sign :: Ptr X509_ -> Ptr EVP_PKEY -> Ptr EVP_MD -> IO Int + +foreign import ccall unsafe "X509_verify" + _verify :: Ptr X509_ -> Ptr EVP_PKEY -> IO Int + +-- |@'newX509'@ creates an empty certificate. You must set the +-- following properties to and sign it (see 'signX509') to actually +-- use the certificate. +-- +-- [/Version/] See 'setVersion'. +-- +-- [/Serial number/] See 'setSerialNumber'. +-- +-- [/Issuer name/] See 'setIssuerName'. +-- +-- [/Subject name/] See 'setSubjectName'. +-- +-- [/Validity/] See 'setNotBefore' and 'setNotAfter'. +-- +-- [/Public Key/] See 'setPublicKey'. +-- +newX509 :: IO X509 +newX509 = _new >>= failIfNull >>= wrapX509 + + +wrapX509 :: Ptr X509_ -> IO X509 +wrapX509 x509Ptr = newForeignPtr _free x509Ptr >>= return . X509 + + +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 + + +touchX509 :: X509 -> IO () +touchX509 (X509 x509) = touchForeignPtr x509 + +-- |@'compareX509' cert1 cert2@ compares two certificates. +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'@ signs a certificate with an issuer private key. +signX509 :: X509 -- ^ The certificate to be signed. + -> PKey -- ^ The private key to sign with. + -> Maybe Digest -- ^ A hashing algorithm to use. If @Nothing@ + -- the most suitable algorithm for the key + -- is automatically used. + -> IO () +signX509 x509 pkey mDigest + = withX509Ptr x509 $ \ x509Ptr -> + withPKeyPtr pkey $ \ pkeyPtr -> + do digest <- case mDigest of + Just md -> return md + Nothing -> pkeyDefaultMD pkey + withMDPtr digest $ \ digestPtr -> + _sign x509Ptr pkeyPtr digestPtr + >>= failIf (== 0) + return () + +-- |@'verifyX509'@ verifies a signature of certificate with an issuer +-- public key. +verifyX509 :: X509 -- ^ The certificate to be verified. + -> PKey -- ^ The public key to verify with. + -> IO VerifyStatus +verifyX509 x509 pkey + = withX509Ptr x509 $ \ x509Ptr -> + withPKeyPtr pkey $ \ pkeyPtr -> + _verify x509Ptr pkeyPtr + >>= interpret + where + interpret :: Int -> IO VerifyStatus + interpret 1 = return VerifySuccess + interpret 0 = return VerifyFailure + interpret _ = raiseOpenSSLError + +-- |@'printX509' cert@ translates a certificate into human-readable +-- format. +printX509 :: X509 -> IO String +printX509 x509 + = do mem <- newMem + withX509Ptr x509 $ \ x509Ptr -> + withBioPtr mem $ \ memPtr -> + _print memPtr x509Ptr + >>= failIf (/= 1) + bioRead mem + +-- |@'getVersion' cert@ returns the version number of certificate. It +-- seems the number is 0-origin: version 2 means X.509 v3. +getVersion :: X509 -> IO Int +getVersion x509 + = withX509Ptr x509 $ \ x509Ptr -> + liftM fromIntegral $ _get_version x509Ptr + +-- |@'setVersion' cert ver@ updates the version number of certificate. +setVersion :: X509 -> Int -> IO () +setVersion x509 ver + = withX509Ptr x509 $ \ x509Ptr -> + _set_version x509Ptr (fromIntegral ver) + >>= failIf (/= 1) + >> return () + +-- |@'getSerialNumber' cert@ returns the serial number of certificate. +getSerialNumber :: X509 -> IO Integer +getSerialNumber x509 + = withX509Ptr x509 $ \ x509Ptr -> + _get_serialNumber x509Ptr + >>= peekASN1Integer + +-- |@'setSerialNumber' cert num@ updates the serial number of +-- certificate. +setSerialNumber :: X509 -> Integer -> IO () +setSerialNumber x509 serial + = withX509Ptr x509 $ \ x509Ptr -> + withASN1Integer serial $ \ serialPtr -> + _set_serialNumber x509Ptr serialPtr + >>= failIf (/= 1) + >> return () + +-- |@'getIssuerName'@ returns the issuer name of certificate. +getIssuerName :: X509 -- ^ The certificate to examine. + -> Bool -- ^ @True@ if you want the keys of each parts + -- to be of long form (e.g. \"commonName\"), + -- or @False@ if you don't (e.g. \"CN\"). + -> IO [(String, String)] -- ^ Pairs of key and value, + -- for example \[(\"C\", + -- \"JP\"), (\"ST\", + -- \"Some-State\"), ...\]. +getIssuerName x509 wantLongName + = withX509Ptr x509 $ \ x509Ptr -> + do namePtr <- _get_issuer_name x509Ptr + peekX509Name namePtr wantLongName + +-- |@'setIssuerName' cert name@ updates the issuer name of +-- certificate. Keys of each parts may be of either long form or short +-- form. See 'getIssuerName'. +setIssuerName :: X509 -> [(String, String)] -> IO () +setIssuerName x509 issuer + = withX509Ptr x509 $ \ x509Ptr -> + withX509Name issuer $ \ namePtr -> + _set_issuer_name x509Ptr namePtr + >>= failIf (/= 1) + >> return () + +-- |@'getSubjectName' cert wantLongName@ returns the subject name of +-- certificate. See 'getIssuerName'. +getSubjectName :: X509 -> Bool -> IO [(String, String)] +getSubjectName x509 wantLongName + = withX509Ptr x509 $ \ x509Ptr -> + do namePtr <- _get_subject_name x509Ptr + peekX509Name namePtr wantLongName + +-- |@'setSubjectName' cert name@ updates the subject name of +-- certificate. See 'setIssuerName'. +setSubjectName :: X509 -> [(String, String)] -> IO () +setSubjectName x509 subject + = withX509Ptr x509 $ \ x509Ptr -> + withX509Name subject $ \ namePtr -> + _set_subject_name x509Ptr namePtr + >>= failIf (/= 1) + >> return () + +-- |@'getNotBefore' cert@ returns the time when the certificate begins +-- to be valid. +getNotBefore :: X509 -> IO UTCTime +getNotBefore x509 + = withX509Ptr x509 $ \ x509Ptr -> + _get_notBefore x509Ptr + >>= peekASN1Time + +-- |@'setNotBefore' cert utc@ updates the time when the certificate +-- begins to be valid. +setNotBefore :: X509 -> UTCTime -> IO () +setNotBefore x509 utc + = withX509Ptr x509 $ \ x509Ptr -> + withASN1Time utc $ \ time -> + _set_notBefore x509Ptr time + >>= failIf (/= 1) + >> return () + +-- |@'getNotAfter' cert@ returns the time when the certificate +-- expires. +getNotAfter :: X509 -> IO UTCTime +getNotAfter x509 + = withX509Ptr x509 $ \ x509Ptr -> + _get_notAfter x509Ptr + >>= peekASN1Time + +-- |@'setNotAfter' cert utc@ updates the time when the certificate +-- expires. +setNotAfter :: X509 -> UTCTime -> IO () +setNotAfter x509 utc + = withX509Ptr x509 $ \ x509Ptr -> + withASN1Time utc $ \ time -> + _set_notAfter x509Ptr time + >>= failIf (/= 1) + >> return () + +-- |@'getPublicKey' cert@ returns the public key of the subject of +-- certificate. +getPublicKey :: X509 -> IO PKey +getPublicKey x509 + = withX509Ptr x509 $ \ x509Ptr -> + _get_pubkey x509Ptr + >>= failIfNull + >>= wrapPKeyPtr + +-- |@'setPublicKey' cert pubkey@ updates the public key of the subject +-- of certificate. +setPublicKey :: X509 -> PKey -> IO () +setPublicKey x509 pkey + = withX509Ptr x509 $ \ x509Ptr -> + withPKeyPtr pkey $ \ pkeyPtr -> + _set_pubkey x509Ptr pkeyPtr + >>= failIf (/= 1) + >> return () + +-- |@'getSubjectEmail' cert@ returns every subject email addresses in +-- the certificate. +getSubjectEmail :: X509 -> IO [String] +getSubjectEmail x509 + = withX509Ptr x509 $ \ x509Ptr -> + do st <- _get1_email x509Ptr + list <- mapStack peekCString st + _email_free st + return list diff --git a/OpenSSL/X509.hsc b/OpenSSL/X509.hsc --- a/OpenSSL/X509.hsc +++ b/OpenSSL/X509.hsc @@ -56,7 +56,7 @@ import Foreign.C import OpenSSL.ASN1 import OpenSSL.BIO -import OpenSSL.EVP.Digest +import OpenSSL.EVP.Digest hiding (digest) import OpenSSL.EVP.PKey import OpenSSL.EVP.Verify import OpenSSL.Utils diff --git a/OpenSSL/X509/Name.hs b/OpenSSL/X509/Name.hs new file mode 100644 --- /dev/null +++ b/OpenSSL/X509/Name.hs @@ -0,0 +1,87 @@ +{-# OPTIONS_GHC -optc-D__GLASGOW_HASKELL__=606 #-} +{-# INCLUDE "HsOpenSSL.h" #-} +{-# LINE 1 "OpenSSL/X509/Name.hsc" #-} + +{-# LINE 2 "OpenSSL/X509/Name.hsc" #-} + +module OpenSSL.X509.Name + ( X509_NAME + + , allocaX509Name + , withX509Name + , peekX509Name + ) + where + +import Control.Exception +import Foreign +import Foreign.C +import OpenSSL.ASN1 +import OpenSSL.Utils + + +data X509_NAME +data X509_NAME_ENTRY + +foreign import ccall unsafe "X509_NAME_new" + _new :: IO (Ptr X509_NAME) + +foreign import ccall unsafe "X509_NAME_free" + _free :: Ptr X509_NAME -> IO () + +foreign import ccall unsafe "X509_NAME_add_entry_by_txt" + _add_entry_by_txt :: Ptr X509_NAME -> CString -> Int -> Ptr CChar -> Int -> Int -> Int -> IO Int + +foreign import ccall unsafe "X509_NAME_entry_count" + _entry_count :: Ptr X509_NAME -> IO Int + +foreign import ccall unsafe "X509_NAME_get_entry" + _get_entry :: Ptr X509_NAME -> Int -> IO (Ptr X509_NAME_ENTRY) + +foreign import ccall unsafe "X509_NAME_ENTRY_get_object" + _ENTRY_get_object :: Ptr X509_NAME_ENTRY -> IO (Ptr ASN1_OBJECT) + +foreign import ccall unsafe "X509_NAME_ENTRY_get_data" + _ENTRY_get_data :: Ptr X509_NAME_ENTRY -> IO (Ptr ASN1_STRING) + + +allocaX509Name :: (Ptr X509_NAME -> IO a) -> IO a +allocaX509Name m + = bracket _new _free m + + +withX509Name :: [(String, String)] -> (Ptr X509_NAME -> IO a) -> IO a +withX509Name name m + = allocaX509Name $ \ namePtr -> + do mapM_ (addEntry namePtr) name + m namePtr + where + addEntry :: Ptr X509_NAME -> (String, String) -> IO () + addEntry namePtr (key, val) + = withCString key $ \ keyPtr -> + withCStringLen val $ \ (valPtr, valLen) -> + _add_entry_by_txt namePtr keyPtr (4100) valPtr valLen (-1) 0 +{-# LINE 60 "OpenSSL/X509/Name.hsc" #-} + >>= failIf (/= 1) + >> return () + + +peekX509Name :: Ptr X509_NAME -> Bool -> IO [(String, String)] +peekX509Name namePtr wantLongName + = do count <- _entry_count namePtr >>= failIf (< 0) + mapM peekEntry $ take count [0..] + where + peekEntry :: Int -> IO (String, String) + peekEntry n + = do ent <- _get_entry namePtr n >>= failIfNull + obj <- _ENTRY_get_object ent >>= failIfNull + dat <- _ENTRY_get_data ent >>= failIfNull + + nid <- obj2nid obj + key <- if wantLongName then + nid2ln nid + else + nid2sn nid + val <- peekASN1String dat + + return (key, val) diff --git a/OpenSSL/X509/Request.hs b/OpenSSL/X509/Request.hs new file mode 100644 --- /dev/null +++ b/OpenSSL/X509/Request.hs @@ -0,0 +1,252 @@ +{-# OPTIONS_GHC -optc-D__GLASGOW_HASKELL__=606 #-} +{-# LINE 1 "OpenSSL/X509/Request.hsc" #-} +{- -*- haskell -*- -} +{-# LINE 2 "OpenSSL/X509/Request.hsc" #-} + +-- #prune + +-- |An interface to PKCS#10 certificate request. + +module OpenSSL.X509.Request + ( -- * Type + X509Req + , X509_REQ -- private + + -- * Functions to manipulate request + , newX509Req + , wrapX509Req -- private + , withX509ReqPtr -- private + + , signX509Req + , verifyX509Req + + , printX509Req + + , makeX509FromReq + + -- * Accessors + , getVersion + , setVersion + + , getSubjectName + , setSubjectName + + , getPublicKey + , setPublicKey + ) + where + +import Control.Monad +import Foreign +import Foreign.C +import OpenSSL.BIO +import OpenSSL.EVP.Digest +import OpenSSL.EVP.PKey +import OpenSSL.EVP.Verify +import OpenSSL.Utils +import OpenSSL.X509 (X509) +import qualified OpenSSL.X509 as Cert +import OpenSSL.X509.Name + +-- |@'X509Req'@ is an opaque object that represents PKCS#10 +-- certificate request. +newtype X509Req = X509Req (ForeignPtr X509_REQ) +data X509_REQ + + +foreign import ccall unsafe "X509_REQ_new" + _new :: IO (Ptr X509_REQ) + +foreign import ccall unsafe "&X509_REQ_free" + _free :: FunPtr (Ptr X509_REQ -> IO ()) + +foreign import ccall unsafe "X509_REQ_sign" + _sign :: Ptr X509_REQ -> Ptr EVP_PKEY -> Ptr EVP_MD -> IO Int + +foreign import ccall unsafe "X509_REQ_verify" + _verify :: Ptr X509_REQ -> Ptr EVP_PKEY -> IO Int + +foreign import ccall unsafe "X509_REQ_print" + _print :: Ptr BIO_ -> Ptr X509_REQ -> IO Int + +foreign import ccall unsafe "HsOpenSSL_X509_REQ_get_version" + _get_version :: Ptr X509_REQ -> IO CLong + +foreign import ccall unsafe "X509_REQ_set_version" + _set_version :: Ptr X509_REQ -> CLong -> IO Int + +foreign import ccall unsafe "HsOpenSSL_X509_REQ_get_subject_name" + _get_subject_name :: Ptr X509_REQ -> IO (Ptr X509_NAME) + +foreign import ccall unsafe "X509_REQ_set_subject_name" + _set_subject_name :: Ptr X509_REQ -> Ptr X509_NAME -> IO Int + +foreign import ccall unsafe "X509_REQ_get_pubkey" + _get_pubkey :: Ptr X509_REQ -> IO (Ptr EVP_PKEY) + +foreign import ccall unsafe "X509_REQ_set_pubkey" + _set_pubkey :: Ptr X509_REQ -> Ptr EVP_PKEY -> IO Int + +-- |@'newX509Req'@ creates an empty certificate request. You must set +-- the following properties to and sign it (see 'signX509Req') to +-- actually use the certificate request. +-- +-- [/Version/] See 'setVersion'. +-- +-- [/Subject Name/] See 'setSubjectName'. +-- +-- [/Public Key/] See 'setPublicKey'. +-- +newX509Req :: IO X509Req +newX509Req = _new >>= wrapX509Req + + +wrapX509Req :: Ptr X509_REQ -> IO X509Req +wrapX509Req reqPtr = newForeignPtr _free reqPtr >>= return . X509Req + + +withX509ReqPtr :: X509Req -> (Ptr X509_REQ -> IO a) -> IO a +withX509ReqPtr (X509Req req) = withForeignPtr req + +-- |@'signX509Req'@ signs a certificate request with a subject private +-- key. +signX509Req :: X509Req -- ^ The request to be signed. + -> PKey -- ^ The private key to sign with. + -> Maybe Digest -- ^ A hashing algorithm to use. If + -- @Nothing@ the most suitable algorithm + -- for the key is automatically used. + -> IO () +signX509Req req pkey mDigest + = withX509ReqPtr req $ \ reqPtr -> + withPKeyPtr pkey $ \ pkeyPtr -> + do digest <- case mDigest of + Just md -> return md + Nothing -> pkeyDefaultMD pkey + withMDPtr digest $ \ digestPtr -> + _sign reqPtr pkeyPtr digestPtr + >>= failIf (== 0) + return () + +-- |@'verifyX509Req'@ verifies a signature of certificate request with +-- a subject public key. +verifyX509Req :: X509Req -- ^ The request to be verified. + -> PKey -- ^ The public key to verify with. + -> IO VerifyStatus +verifyX509Req req pkey + = withX509ReqPtr req $ \ reqPtr -> + withPKeyPtr pkey $ \ pkeyPtr -> + _verify reqPtr pkeyPtr + >>= interpret + where + interpret :: Int -> IO VerifyStatus + interpret 1 = return VerifySuccess + interpret 0 = return VerifyFailure + interpret _ = raiseOpenSSLError + +-- |@'printX509Req' req@ translates a certificate request into +-- human-readable format. +printX509Req :: X509Req -> IO String +printX509Req req + = do mem <- newMem + withBioPtr mem $ \ memPtr -> + withX509ReqPtr req $ \ reqPtr -> + _print memPtr reqPtr + >>= failIf (/= 1) + bioRead mem + +-- |@'getVersion' req@ returns the version number of certificate +-- request. +getVersion :: X509Req -> IO Int +getVersion req + = withX509ReqPtr req $ \ reqPtr -> + liftM fromIntegral $ _get_version reqPtr + +-- |@'setVersion' req ver@ updates the version number of certificate +-- request. +setVersion :: X509Req -> Int -> IO () +setVersion req ver + = withX509ReqPtr req $ \ reqPtr -> + _set_version reqPtr (fromIntegral ver) + >>= failIf (/= 1) + >> return () + +-- |@'getSubjectName' req wantLongName@ returns the subject name of +-- certificate request. See 'OpenSSL.X509.getSubjectName' of +-- "OpenSSL.X509". +getSubjectName :: X509Req -> Bool -> IO [(String, String)] +getSubjectName req wantLongName + = withX509ReqPtr req $ \ reqPtr -> + do namePtr <- _get_subject_name reqPtr + peekX509Name namePtr wantLongName + +-- |@'setSubjectName' req name@ updates the subject name of +-- certificate request. See 'OpenSSL.X509.setSubjectName' of +-- "OpenSSL.X509". +setSubjectName :: X509Req -> [(String, String)] -> IO () +setSubjectName req subject + = withX509ReqPtr req $ \ reqPtr -> + withX509Name subject $ \ namePtr -> + _set_subject_name reqPtr namePtr + >>= failIf (/= 1) + >> return () + +-- |@'getPublicKey' req@ returns the public key of the subject of +-- certificate request. +getPublicKey :: X509Req -> IO PKey +getPublicKey req + = withX509ReqPtr req $ \ reqPtr -> + _get_pubkey reqPtr + >>= failIfNull + >>= wrapPKeyPtr + +-- |@'setPublicKey' req@ updates the public key of the subject of +-- certificate request. +setPublicKey :: X509Req -> PKey -> IO () +setPublicKey req pkey + = withX509ReqPtr req $ \ reqPtr -> + withPKeyPtr pkey $ \ pkeyPtr -> + _set_pubkey reqPtr pkeyPtr + >>= failIf (/= 1) + >> return () + + +-- |@'makeX509FromReq' req cert@ creates an empty X.509 certificate +-- and copies as much data from the request as possible. The resulting +-- certificate doesn't have the following data and it isn't signed so +-- you must fill them and sign it yourself. +-- +-- * Serial number +-- +-- * Validity (Not Before and Not After) +-- +-- Example: +-- +-- > import Data.Time.Clock +-- > +-- > genCert :: X509 -> EvpPKey -> Integer -> Int -> X509Req -> IO X509 +-- > genCert caCert caKey serial days req +-- > = do cert <- makeX509FromReq req caCert +-- > now <- getCurrentTime +-- > setSerialNumber cert serial +-- > setNotBefore cert $ addUTCTime (-1) now +-- > setNotAfter cert $ addUTCTime (days * 24 * 60 * 60) now +-- > signX509 cert caKey Nothing +-- > return cert +-- +makeX509FromReq :: X509Req + -> X509 + -> IO X509 +makeX509FromReq req caCert + = do reqPubKey <- getPublicKey req + verified <- verifyX509Req req reqPubKey + + when (verified == VerifyFailure) + $ fail "makeX509FromReq: the request isn't properly signed by its own key." + + cert <- Cert.newX509 + Cert.setVersion cert 2 -- Version 2 means X509 v3. It's confusing. + Cert.setIssuerName cert =<< Cert.getSubjectName caCert False + Cert.setSubjectName cert =<< getSubjectName req False + Cert.setPublicKey cert =<< getPublicKey req + + return cert diff --git a/OpenSSL/X509/Request.hsc b/OpenSSL/X509/Request.hsc --- a/OpenSSL/X509/Request.hsc +++ b/OpenSSL/X509/Request.hsc @@ -37,7 +37,7 @@ import Foreign import Foreign.C import OpenSSL.BIO -import OpenSSL.EVP.Digest +import OpenSSL.EVP.Digest hiding (digest) import OpenSSL.EVP.PKey import OpenSSL.EVP.Verify import OpenSSL.Utils diff --git a/OpenSSL/X509/Revocation.hs b/OpenSSL/X509/Revocation.hs new file mode 100644 --- /dev/null +++ b/OpenSSL/X509/Revocation.hs @@ -0,0 +1,331 @@ +{-# OPTIONS_GHC -optc-D__GLASGOW_HASKELL__=606 #-} +{-# INCLUDE "HsOpenSSL.h" #-} +{-# LINE 1 "OpenSSL/X509/Revocation.hsc" #-} +{- -*- haskell -*- -} +{-# LINE 2 "OpenSSL/X509/Revocation.hsc" #-} + +-- #prune + +-- |An interface to Certificate Revocation List. + + +{-# LINE 8 "OpenSSL/X509/Revocation.hsc" #-} + +module OpenSSL.X509.Revocation + ( -- * Types + CRL + , X509_CRL -- privae + , RevokedCertificate(..) + + -- * Functions to manipulate revocation list + , newCRL + , wrapCRL -- private + , withCRLPtr -- private + + , signCRL + , verifyCRL + + , printCRL + + , sortCRL + + -- * Accessors + , getVersion + , setVersion + + , getLastUpdate + , setLastUpdate + + , getNextUpdate + , setNextUpdate + + , getIssuerName + , setIssuerName + + , getRevokedList + , addRevoked + ) + where + +import Control.Monad +import Data.Time.Clock +import Data.Typeable +import Foreign +import Foreign.C +import OpenSSL.ASN1 +import OpenSSL.BIO +import OpenSSL.EVP.Digest +import OpenSSL.EVP.PKey +import OpenSSL.EVP.Verify +import OpenSSL.Stack +import OpenSSL.Utils +import OpenSSL.X509.Name + +-- |@'CRL'@ is an opaque object that represents Certificate Revocation +-- List. +newtype CRL = CRL (ForeignPtr X509_CRL) +data X509_CRL +data X509_REVOKED + +-- |@'RevokedCertificate'@ represents a revoked certificate in a +-- list. Each certificates are supposed to be distinguishable by +-- issuer name and serial number, so it is sufficient to have only +-- serial number on each entries. +data RevokedCertificate + = RevokedCertificate { + revSerialNumber :: Integer + , revRevocationDate :: UTCTime + } + deriving (Show, Eq, Typeable) + + +foreign import ccall unsafe "X509_CRL_new" + _new :: IO (Ptr X509_CRL) + +foreign import ccall unsafe "&X509_CRL_free" + _free :: FunPtr (Ptr X509_CRL -> IO ()) + +foreign import ccall unsafe "X509_CRL_sign" + _sign :: Ptr X509_CRL -> Ptr EVP_PKEY -> Ptr EVP_MD -> IO Int + +foreign import ccall unsafe "X509_CRL_verify" + _verify :: Ptr X509_CRL -> Ptr EVP_PKEY -> IO Int + +foreign import ccall unsafe "X509_CRL_print" + _print :: Ptr BIO_ -> Ptr X509_CRL -> IO Int + +foreign import ccall unsafe "HsOpenSSL_X509_CRL_get_version" + _get_version :: Ptr X509_CRL -> IO CLong + +foreign import ccall unsafe "X509_CRL_set_version" + _set_version :: Ptr X509_CRL -> CLong -> IO Int + +foreign import ccall unsafe "HsOpenSSL_X509_CRL_get_lastUpdate" + _get_lastUpdate :: Ptr X509_CRL -> IO (Ptr ASN1_TIME) + +foreign import ccall unsafe "X509_CRL_set_lastUpdate" + _set_lastUpdate :: Ptr X509_CRL -> Ptr ASN1_TIME -> IO Int + +foreign import ccall unsafe "HsOpenSSL_X509_CRL_get_nextUpdate" + _get_nextUpdate :: Ptr X509_CRL -> IO (Ptr ASN1_TIME) + +foreign import ccall unsafe "X509_CRL_set_nextUpdate" + _set_nextUpdate :: Ptr X509_CRL -> Ptr ASN1_TIME -> IO Int + +foreign import ccall unsafe "HsOpenSSL_X509_CRL_get_issuer" + _get_issuer_name :: Ptr X509_CRL -> IO (Ptr X509_NAME) + +foreign import ccall unsafe "X509_CRL_set_issuer_name" + _set_issuer_name :: Ptr X509_CRL -> Ptr X509_NAME -> IO Int + +foreign import ccall unsafe "HsOpenSSL_X509_CRL_get_REVOKED" + _get_REVOKED :: Ptr X509_CRL -> IO (Ptr STACK) + +foreign import ccall unsafe "X509_CRL_add0_revoked" + _add0_revoked :: Ptr X509_CRL -> Ptr X509_REVOKED -> IO Int + +foreign import ccall unsafe "X509_CRL_sort" + _sort :: Ptr X509_CRL -> IO Int + + + +foreign import ccall unsafe "X509_REVOKED_new" + _new_revoked :: IO (Ptr X509_REVOKED) + +foreign import ccall unsafe "X509_REVOKED_free" + freeRevoked :: Ptr X509_REVOKED -> IO () + +foreign import ccall unsafe "X509_REVOKED_set_serialNumber" + _set_serialNumber :: Ptr X509_REVOKED -> Ptr ASN1_INTEGER -> IO Int + +foreign import ccall unsafe "X509_REVOKED_set_revocationDate" + _set_revocationDate :: Ptr X509_REVOKED -> Ptr ASN1_TIME -> IO Int + +-- |@'newCRL'@ creates an empty revocation list. You must set the +-- following properties to and sign it (see 'signCRL') to actually use +-- the revocation list. If you have any certificates to be listed, you +-- must of course add them (see 'addRevoked') before signing the list. +-- +-- [/Version/] See 'setVersion'. +-- +-- [/Last Update/] See 'setLastUpdate'. +-- +-- [/Next Update/] See 'setNextUpdate'. +-- +-- [/Issuer Name/] See 'setIssuerName'. +-- +newCRL :: IO CRL +newCRL = _new >>= wrapCRL + + +wrapCRL :: Ptr X509_CRL -> IO CRL +wrapCRL crlPtr = newForeignPtr _free crlPtr >>= return . CRL + + +withCRLPtr :: CRL -> (Ptr X509_CRL -> IO a) -> IO a +withCRLPtr (CRL crl) = withForeignPtr crl + +-- |@'signCRL'@ signs a revocation list with an issuer private key. +signCRL :: CRL -- ^ The revocation list to be signed. + -> PKey -- ^ The private key to sign with. + -> Maybe Digest -- ^ A hashing algorithm to use. If @Nothing@ + -- the most suitable algorithm for the key + -- is automatically used. + -> IO () +signCRL crl pkey mDigest + = withCRLPtr crl $ \ crlPtr -> + withPKeyPtr pkey $ \ pkeyPtr -> + do digest <- case mDigest of + Just md -> return md + Nothing -> pkeyDefaultMD pkey + withMDPtr digest $ \ digestPtr -> + _sign crlPtr pkeyPtr digestPtr + >>= failIf (== 0) + return () + +-- |@'verifyCRL'@ verifies a signature of revocation list with an +-- issuer public key. +verifyCRL :: CRL -> PKey -> IO VerifyStatus +verifyCRL crl pkey + = withCRLPtr crl $ \ crlPtr -> + withPKeyPtr pkey $ \ pkeyPtr -> + _verify crlPtr pkeyPtr + >>= interpret + where + interpret :: Int -> IO VerifyStatus + interpret 1 = return VerifySuccess + interpret 0 = return VerifyFailure + interpret _ = raiseOpenSSLError + +-- |@'printCRL'@ translates a revocation list into human-readable +-- format. +printCRL :: CRL -> IO String +printCRL crl + = do mem <- newMem + withBioPtr mem $ \ memPtr -> + withCRLPtr crl $ \ crlPtr -> + _print memPtr crlPtr + >>= failIf (/= 1) + bioRead mem + +-- |@'getVersion' crl@ returns the version number of revocation list. +getVersion :: CRL -> IO Int +getVersion crl + = withCRLPtr crl $ \ crlPtr -> + liftM fromIntegral $ _get_version crlPtr + +-- |@'setVersion' crl ver@ updates the version number of revocation +-- list. +setVersion :: CRL -> Int -> IO () +setVersion crl ver + = withCRLPtr crl $ \ crlPtr -> + _set_version crlPtr (fromIntegral ver) + >>= failIf (/= 1) + >> return () + +-- |@'getLastUpdate' crl@ returns the time when the revocation list +-- has last been updated. +getLastUpdate :: CRL -> IO UTCTime +getLastUpdate crl + = withCRLPtr crl $ \ crlPtr -> + _get_lastUpdate crlPtr + >>= peekASN1Time + +-- |@'setLastUpdate' crl utc@ updates the time when the revocation +-- list has last been updated. +setLastUpdate :: CRL -> UTCTime -> IO () +setLastUpdate crl utc + = withCRLPtr crl $ \ crlPtr -> + withASN1Time utc $ \ time -> + _set_lastUpdate crlPtr time + >>= failIf (/= 1) + >> return () + +-- |@'getNextUpdate' crl@ returns the time when the revocation list +-- will next be updated. +getNextUpdate :: CRL -> IO UTCTime +getNextUpdate crl + = withCRLPtr crl $ \ crlPtr -> + _get_nextUpdate crlPtr + >>= peekASN1Time + +-- |@'setNextUpdate' crl utc@ updates the time when the revocation +-- list will next be updated. +setNextUpdate :: CRL -> UTCTime -> IO () +setNextUpdate crl utc + = withCRLPtr crl $ \ crlPtr -> + withASN1Time utc $ \ time -> + _set_nextUpdate crlPtr time + >>= failIf (/= 1) + >> return () + +-- |@'getIssuerName' crl wantLongName@ returns the issuer name of +-- revocation list. See 'OpenSSL.X509.getIssuerName' of +-- "OpenSSL.X509". +getIssuerName :: CRL -> Bool -> IO [(String, String)] +getIssuerName crl wantLongName + = withCRLPtr crl $ \ crlPtr -> + do namePtr <- _get_issuer_name crlPtr + peekX509Name namePtr wantLongName + +-- |@'setIssuerName' crl name@ updates the issuer name of revocation +-- list. See 'OpenSSL.X509.setIssuerName' of "OpenSSL.X509". +setIssuerName :: CRL -> [(String, String)] -> IO () +setIssuerName crl issuer + = withCRLPtr crl $ \ crlPtr -> + withX509Name issuer $ \ namePtr -> + _set_issuer_name crlPtr namePtr + >>= failIf (/= 1) + >> return () + +-- |@'getRevokedList' crl@ returns the list of revoked certificates. +getRevokedList :: CRL -> IO [RevokedCertificate] +getRevokedList crl + = withCRLPtr crl $ \ crlPtr -> + do stRevoked <- _get_REVOKED crlPtr + mapStack peekRevoked stRevoked + where + peekRevoked :: Ptr X509_REVOKED -> IO RevokedCertificate + peekRevoked rev + = do serial <- peekASN1Integer =<< ((\hsc_ptr -> peekByteOff hsc_ptr 0)) rev +{-# LINE 286 "OpenSSL/X509/Revocation.hsc" #-} + date <- peekASN1Time =<< ((\hsc_ptr -> peekByteOff hsc_ptr 4)) rev +{-# LINE 287 "OpenSSL/X509/Revocation.hsc" #-} + return RevokedCertificate { + revSerialNumber = serial + , revRevocationDate = date + } + +newRevoked :: RevokedCertificate -> IO (Ptr X509_REVOKED) +newRevoked revoked + = do revPtr <- _new_revoked + + seriRet <- withASN1Integer (revSerialNumber revoked) $ \ serialPtr -> + _set_serialNumber revPtr serialPtr + + dateRet <- withASN1Time (revRevocationDate revoked) $ \ datePtr -> + _set_revocationDate revPtr datePtr + + if seriRet /= 1 || dateRet /= 1 then + freeRevoked revPtr >> raiseOpenSSLError + else + return revPtr + +-- |@'addRevoked' crl revoked@ add the certificate to the revocation +-- list. +addRevoked :: CRL -> RevokedCertificate -> IO () +addRevoked crl revoked + = withCRLPtr crl $ \ crlPtr -> + do revPtr <- newRevoked revoked + ret <- _add0_revoked crlPtr revPtr + case ret of + 1 -> return () + _ -> freeRevoked revPtr >> raiseOpenSSLError + +-- |@'sortCRL' crl@ sorts the certificates in the revocation list. +sortCRL :: CRL -> IO () +sortCRL crl + = withCRLPtr crl $ \ crlPtr -> + _sort crlPtr + >>= failIf (/= 1) + >> return () diff --git a/OpenSSL/X509/Revocation.hsc b/OpenSSL/X509/Revocation.hsc --- a/OpenSSL/X509/Revocation.hsc +++ b/OpenSSL/X509/Revocation.hsc @@ -49,7 +49,7 @@ import Foreign.C import OpenSSL.ASN1 import OpenSSL.BIO -import OpenSSL.EVP.Digest +import OpenSSL.EVP.Digest hiding (digest) import OpenSSL.EVP.PKey import OpenSSL.EVP.Verify import OpenSSL.Stack diff --git a/OpenSSL/X509/Store.hs b/OpenSSL/X509/Store.hs new file mode 100644 --- /dev/null +++ b/OpenSSL/X509/Store.hs @@ -0,0 +1,74 @@ +{-# OPTIONS_GHC -optc-D__GLASGOW_HASKELL__=606 #-} +{-# LINE 1 "OpenSSL/X509/Store.hsc" #-} +{- -*- haskell -*- -} +{-# LINE 2 "OpenSSL/X509/Store.hsc" #-} + +-- #prune + +-- |An interface to X.509 certificate store. + +module OpenSSL.X509.Store + ( X509Store + , X509_STORE -- private + + , newX509Store + , withX509StorePtr -- private + + , addCertToStore + , addCRLToStore + ) + where + +import Foreign +import OpenSSL.X509 +import OpenSSL.X509.Revocation +import OpenSSL.Utils + +-- |@'X509Store'@ is an opaque object that represents X.509 +-- certificate store. The certificate store is usually used for chain +-- verification. +newtype X509Store = X509Store (ForeignPtr X509_STORE) +data X509_STORE + + +foreign import ccall unsafe "X509_STORE_new" + _new :: IO (Ptr X509_STORE) + +foreign import ccall unsafe "&X509_STORE_free" + _free :: FunPtr (Ptr X509_STORE -> IO ()) + +foreign import ccall unsafe "X509_STORE_add_cert" + _add_cert :: Ptr X509_STORE -> Ptr X509_ -> IO Int + +foreign import ccall unsafe "X509_STORE_add_crl" + _add_crl :: Ptr X509_STORE -> Ptr X509_CRL -> IO Int + +-- |@'newX509Store'@ creates an empty X.509 certificate store. +newX509Store :: IO X509Store +newX509Store = _new + >>= failIfNull + >>= newForeignPtr _free + >>= return . X509Store + + +withX509StorePtr :: X509Store -> (Ptr X509_STORE -> IO a) -> IO a +withX509StorePtr (X509Store store) + = withForeignPtr store + +-- |@'addCertToStore' store cert@ adds a certificate to store. +addCertToStore :: X509Store -> X509 -> IO () +addCertToStore store cert + = withX509StorePtr store $ \ storePtr -> + withX509Ptr cert $ \ certPtr -> + _add_cert storePtr certPtr + >>= failIf (/= 1) + >> return () + +-- |@'addCRLToStore' store crl@ adds a revocation list to store. +addCRLToStore :: X509Store -> CRL -> IO () +addCRLToStore store crl + = withX509StorePtr store $ \ storePtr -> + withCRLPtr crl $ \ crlPtr -> + _add_crl storePtr crlPtr + >>= failIf (/= 1) + >> return () diff --git a/tests/Base64.hs b/tests/Base64.hs new file mode 100644 --- /dev/null +++ b/tests/Base64.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Unittest for Base64 [en|de]coding. +module Main where + +import Data.Char (ord) +import Data.String +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import OpenSSL.EVP.Base64 + +instance IsString BS.ByteString where + fromString = BS.pack . map (fromIntegral . ord) + +-- Note that this instance packs each charactor as a separate lazy chunk. +-- This is to stress the lazy code - not because it's a good idea generally +instance IsString BSL.ByteString where + fromString = BSL.fromChunks . map (BS.singleton . fromIntegral . ord) + +encodeTests :: [(BS.ByteString, BS.ByteString)] +encodeTests = + [("", "") + ,("a", "YQ==") + ,("aa", "YWE=") + ,("aaa", "YWFh") + ] + +lazyEncodeTests :: [(BSL.ByteString, BSL.ByteString)] +lazyEncodeTests = + [("", "") + ,("a", "YQ==") + ,("aa", "YWE=") + ,("aaa", "YWFh") + ] + +decodeTests :: [(BS.ByteString, BS.ByteString)] +decodeTests = + [("", "") + ,("aGFza2VsbA==", "haskell") + ,("YWJjZGVmZ2hpams=", "abcdefghijk") + ,("YWJjZGVmZ2hpams=\n", "abcdefghijk") + ] + +encoding = all id $ map (\(a, v) -> encodeBase64BS a == v) encodeTests +lazyEncoding = all id $ map (\(a, v) -> encodeBase64LBS a == v) lazyEncodeTests +decoding = all id $ map (\(a, v) -> decodeBase64BS a == v) decodeTests + +main = do + mapM (print . encodeBase64LBS . fst) lazyEncodeTests + if encoding && lazyEncoding && decoding + then putStrLn "PASS" + else putStrLn "FAIL" diff --git a/tests/Cipher.hs b/tests/Cipher.hs new file mode 100644 --- /dev/null +++ b/tests/Cipher.hs @@ -0,0 +1,91 @@ +-- | Tests for the non-EVP ciphers +module Main where + +import Control.Monad (when) +import qualified Data.ByteString as BS + +import OpenSSL.Cipher + +-- | Convert a hex string to a ByteString (e.g. "0011" == BS.pack [0, 0x11]) +hexToBS [] = BS.empty +hexToBS (a : b : rest) = BS.append (BS.singleton ((valueOfHexChar a * 16) + valueOfHexChar b)) + (hexToBS rest) + +valueOfHexChar '0' = 0 +valueOfHexChar '1' = 1 +valueOfHexChar '2' = 2 +valueOfHexChar '3' = 3 +valueOfHexChar '4' = 4 +valueOfHexChar '5' = 5 +valueOfHexChar '6' = 6 +valueOfHexChar '7' = 7 +valueOfHexChar '8' = 8 +valueOfHexChar '9' = 9 +valueOfHexChar 'a' = 10 +valueOfHexChar 'b' = 11 +valueOfHexChar 'c' = 12 +valueOfHexChar 'd' = 13 +valueOfHexChar 'e' = 14 +valueOfHexChar 'f' = 15 +valueOfHexChar 'A' = 10 +valueOfHexChar 'B' = 11 +valueOfHexChar 'C' = 12 +valueOfHexChar 'D' = 13 +valueOfHexChar 'E' = 14 +valueOfHexChar 'F' = 15 + +hexOf 0 = '0' +hexOf 1 = '1' +hexOf 2 = '2' +hexOf 3 = '3' +hexOf 4 = '4' +hexOf 5 = '5' +hexOf 6 = '6' +hexOf 7 = '7' +hexOf 8 = '8' +hexOf 9 = '9' +hexOf 10 = 'a' +hexOf 11 = 'b' +hexOf 12 = 'c' +hexOf 13 = 'd' +hexOf 14 = 'e' +hexOf 15 = 'f' + +-- | A test containing counter mode test vectors +data CTRTest = CTRTest BS.ByteString -- ^ key + BS.ByteString -- ^ IV + BS.ByteString -- ^ plaintext + BS.ByteString -- ^ cipher text + +-- Test vectors from draft-ietf-ipsec-ciph-aes-ctr-05 section 6 +ctrTests = [ + CTRTest (hexToBS "AE6852F8121067CC4BF7A5765577F39E") + (hexToBS "00000030000000000000000000000001") + (hexToBS "53696E676C6520626C6F636B206D7367") + (hexToBS "E4095D4FB7A7B3792D6175A3261311B8"), + CTRTest (hexToBS "7691BE035E5020A8AC6E618529F9A0DC") + (hexToBS "00E0017B27777F3F4A1786F000000001") + (hexToBS "000102030405060708090A0B0C0D0E0F101112131415161718191A1B1C1D1E1F20212223") + (hexToBS "C1CF48A89F2FFDD9CF4652E9EFDB72D74540A42BDE6D7836D59A5CEAAEF3105325B2072F"), + CTRTest (hexToBS "16AF5B145FC9F579C175F93E3BFB0EED863D06CCFDB78515") + (hexToBS "0000004836733C147D6D93CB00000001") + (hexToBS "53696E676C6520626C6F636B206D7367") + (hexToBS "4B55384FE259C9C84E7935A003CBE928"), + CTRTest (hexToBS "FF7A617CE69148E4F1726E2F43581DE2AA62D9F805532EDFF1EED687FB54153D") + (hexToBS "001CC5B751A51D70A1C1114800000001") + (hexToBS "000102030405060708090A0B0C0D0E0F101112131415161718191A1B1C1D1E1F20212223") + (hexToBS "EB6C52821D0BBBF7CE7594462ACA4FAAB407DF866569FD07F48CC0B583D6071F1EC0E6B8") ] + +runCtrTest :: CTRTest -> IO Bool +runCtrTest (CTRTest key iv plaintext ciphertext) = do + ctx <- newAESCtx Encrypt key iv + ct <- aesCTR ctx plaintext + return (ct == ciphertext) + +runCtrTests :: IO Bool +runCtrTests = mapM runCtrTest ctrTests >>= return . all ((==) True) + +main = do + r <- runCtrTests + when (r == False) $ fail "CTR tests failed" + putStrLn "PASS" diff --git a/tests/DSA.hs b/tests/DSA.hs new file mode 100644 --- /dev/null +++ b/tests/DSA.hs @@ -0,0 +1,48 @@ +module Main where + +import System.Time + +import OpenSSL.DSA +import qualified Data.ByteString as BS + +-- | This function just runs the example DSA generation, as given in FIP 186-2, +-- app 5. +test_generateParameters = do + let seed = BS.pack [0xd5, 0x01, 0x4e, 0x4b, + 0x60, 0xef, 0x2b, 0xa8, + 0xb6, 0x21, 0x1b, 0x40, + 0x62, 0xba, 0x32, 0x24, + 0xe0, 0x42, 0x7d, 0xd3] + (a, b, p, q, g) <- generateParameters 512 $ Just seed + return $ (a, p, q, g) == (105, + 0x8df2a494492276aa3d25759bb06869cbeac0d83afb8d0cf7cbb8324f0d7882e5d0762fc5b7210eafc2e9adac32ab7aac49693dfbf83724c2ec0736ee31c80291, + 0xc773218c737ec8ee993b4f2ded30f48edace915f, + 0x626d027839ea0a13413163a55b4cb500299d5522956cefcb3bff10f399ce2c2e71cb9de5fa24babf58e5b79521925c9cc42e9f6f464b088cc572af53e6d78802) + +testMessage = BS.pack [1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20] + +test_signVerify = do + dsa <- generateParametersAndKey 512 Nothing + (a, b) <- signDigestedData dsa testMessage + verifyDigestedData dsa testMessage (a, b) + +test_signVerifySpeed = do + dsa <- generateParametersAndKey 512 Nothing + + let test = do + (a, b) <- signDigestedData dsa testMessage + True <- verifyDigestedData dsa testMessage (a, b) + return () + + starttime <- getClockTime + sequence_ $ take 2000 $ repeat test + endtime <- getClockTime + print $ diffClockTimes endtime starttime + + return True + +main = do + results <- sequence [test_generateParameters, test_signVerify, test_signVerifySpeed] + if all id results + then putStrLn "PASS" + else putStrLn $ "FAIL" ++ show results diff --git a/tests/Makefile b/tests/Makefile new file mode 100644 --- /dev/null +++ b/tests/Makefile @@ -0,0 +1,11 @@ +TESTS = \ + Base64 \ + Cipher \ + DSA \ + $(NULL) + +test: + for i in $(TESTS); do ghc --make $$i; ./$$i; done + +clean: + rm -f *.hi *.o $(TESTS)