diff --git a/AUTHORS b/AUTHORS --- a/AUTHORS +++ b/AUTHORS @@ -1,4 +1,4 @@ This is a list of contributors to the HsOpenSSL. * Adam Langley -* PHO +* PHO diff --git a/HsOpenSSL.cabal b/HsOpenSSL.cabal --- a/HsOpenSSL.cabal +++ b/HsOpenSSL.cabal @@ -5,10 +5,10 @@ generate RSA and DSA keys, read and write PEM files, generate message digests, sign and verify messages, encrypt and decrypt messages. -Version: 0.4.1 +Version: 0.4.2 License: PublicDomain License-File: COPYING -Author: PHO +Author: Adam Langley , PHO Maintainer: PHO Stability: experimental Homepage: http://ccm.sherry.jp/HsOpenSSL/ diff --git a/NEWS b/NEWS --- a/NEWS +++ b/NEWS @@ -1,3 +1,10 @@ +Changes from 0.4.1 to 0.4.2 +--------------------------- +* No .hs files which are generated from .hsc files should be in the + tarball. If any .hs files are outdated, Cabal seems to compile the + outdated files instead of newer .hsc files. + + Changes from 0.4 to 0.4.1 ------------------------- * Applied patches by Adam Langley: diff --git a/OpenSSL.hs b/OpenSSL.hs deleted file mode 100644 --- a/OpenSSL.hs +++ /dev/null @@ -1,79 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/OpenSSL/ASN1.hs +++ /dev/null @@ -1,168 +0,0 @@ -{-# 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/BIO.hs b/OpenSSL/BIO.hs deleted file mode 100644 --- a/OpenSSL/BIO.hs +++ /dev/null @@ -1,476 +0,0 @@ -{-# 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/BN.hs b/OpenSSL/BN.hs deleted file mode 100644 --- a/OpenSSL/BN.hs +++ /dev/null @@ -1,354 +0,0 @@ -{-# 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/Cipher.hs b/OpenSSL/Cipher.hs deleted file mode 100644 --- a/OpenSSL/Cipher.hs +++ /dev/null @@ -1,123 +0,0 @@ -{-# 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/DSA.hs b/OpenSSL/DSA.hs deleted file mode 100644 --- a/OpenSSL/DSA.hs +++ /dev/null @@ -1,249 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/OpenSSL/ERR.hs +++ /dev/null @@ -1,36 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/OpenSSL/EVP/Base64.hs +++ /dev/null @@ -1,140 +0,0 @@ -{-# 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/Cipher.hs b/OpenSSL/EVP/Cipher.hs deleted file mode 100644 --- a/OpenSSL/EVP/Cipher.hs +++ /dev/null @@ -1,227 +0,0 @@ -{-# 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/Digest.hs b/OpenSSL/EVP/Digest.hs deleted file mode 100644 --- a/OpenSSL/EVP/Digest.hs +++ /dev/null @@ -1,207 +0,0 @@ -{-# 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/Open.hs b/OpenSSL/EVP/Open.hs deleted file mode 100644 --- a/OpenSSL/EVP/Open.hs +++ /dev/null @@ -1,82 +0,0 @@ -{-# 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/PKey.hs b/OpenSSL/EVP/PKey.hs deleted file mode 100644 --- a/OpenSSL/EVP/PKey.hs +++ /dev/null @@ -1,139 +0,0 @@ -{-# 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/Seal.hs b/OpenSSL/EVP/Seal.hs deleted file mode 100644 --- a/OpenSSL/EVP/Seal.hs +++ /dev/null @@ -1,137 +0,0 @@ -{-# 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/Sign.hs b/OpenSSL/EVP/Sign.hs deleted file mode 100644 --- a/OpenSSL/EVP/Sign.hs +++ /dev/null @@ -1,70 +0,0 @@ -{-# 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/Verify.hs b/OpenSSL/EVP/Verify.hs deleted file mode 100644 --- a/OpenSSL/EVP/Verify.hs +++ /dev/null @@ -1,79 +0,0 @@ -{-# 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/Objects.hs b/OpenSSL/Objects.hs deleted file mode 100644 --- a/OpenSSL/Objects.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/OpenSSL/PEM.hs +++ /dev/null @@ -1,462 +0,0 @@ -{-# 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/PKCS7.hs b/OpenSSL/PKCS7.hs deleted file mode 100644 --- a/OpenSSL/PKCS7.hs +++ /dev/null @@ -1,436 +0,0 @@ -{-# 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/RSA.hs b/OpenSSL/RSA.hs deleted file mode 100644 --- a/OpenSSL/RSA.hs +++ /dev/null @@ -1,164 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/OpenSSL/Random.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# 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/Stack.hs b/OpenSSL/Stack.hs deleted file mode 100644 --- a/OpenSSL/Stack.hs +++ /dev/null @@ -1,62 +0,0 @@ -{-# 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/X509.hs b/OpenSSL/X509.hs deleted file mode 100644 --- a/OpenSSL/X509.hs +++ /dev/null @@ -1,375 +0,0 @@ -{-# 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/Name.hs b/OpenSSL/X509/Name.hs deleted file mode 100644 --- a/OpenSSL/X509/Name.hs +++ /dev/null @@ -1,87 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/OpenSSL/X509/Request.hs +++ /dev/null @@ -1,252 +0,0 @@ -{-# 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/Revocation.hs b/OpenSSL/X509/Revocation.hs deleted file mode 100644 --- a/OpenSSL/X509/Revocation.hs +++ /dev/null @@ -1,331 +0,0 @@ -{-# 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/Store.hs b/OpenSSL/X509/Store.hs deleted file mode 100644 --- a/OpenSSL/X509/Store.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# 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 ()