HsOpenSSL 0.4.1 → 0.4.2
raw patch · 29 files changed
+10/−4947 lines, 29 files
Files
- AUTHORS +1/−1
- HsOpenSSL.cabal +2/−2
- NEWS +7/−0
- OpenSSL.hs +0/−79
- OpenSSL/ASN1.hs +0/−168
- OpenSSL/BIO.hs +0/−476
- OpenSSL/BN.hs +0/−354
- OpenSSL/Cipher.hs +0/−123
- OpenSSL/DSA.hs +0/−249
- OpenSSL/ERR.hs +0/−36
- OpenSSL/EVP/Base64.hs +0/−140
- OpenSSL/EVP/Cipher.hs +0/−227
- OpenSSL/EVP/Digest.hs +0/−207
- OpenSSL/EVP/Open.hs +0/−82
- OpenSSL/EVP/PKey.hs +0/−139
- OpenSSL/EVP/Seal.hs +0/−137
- OpenSSL/EVP/Sign.hs +0/−70
- OpenSSL/EVP/Verify.hs +0/−79
- OpenSSL/Objects.hs +0/−74
- OpenSSL/PEM.hs +0/−462
- OpenSSL/PKCS7.hs +0/−436
- OpenSSL/RSA.hs +0/−164
- OpenSSL/Random.hs +0/−61
- OpenSSL/Stack.hs +0/−62
- OpenSSL/X509.hs +0/−375
- OpenSSL/X509/Name.hs +0/−87
- OpenSSL/X509/Request.hs +0/−252
- OpenSSL/X509/Revocation.hs +0/−331
- OpenSSL/X509/Store.hs +0/−74
AUTHORS view
@@ -1,4 +1,4 @@ This is a list of contributors to the HsOpenSSL. * Adam Langley <agl@imperialviolet.org>-* PHO <phonohawk@ps.sakura.ne.jp>+* PHO <pho@cielonegro.org>
HsOpenSSL.cabal view
@@ -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 <pho at cielonegro.org>+Author: Adam Langley <agl at imperialviolet.org>, PHO <pho at cielonegro.org> Maintainer: PHO <pho at cielonegro.org> Stability: experimental Homepage: http://ccm.sherry.jp/HsOpenSSL/
NEWS view
@@ -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:
− OpenSSL.hs
@@ -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
− OpenSSL/ASN1.hs
@@ -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
− OpenSSL/BIO.hs
@@ -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
− OpenSSL/BN.hs
@@ -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)
− OpenSSL/Cipher.hs
@@ -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'
− OpenSSL/DSA.hs
@@ -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 <http://www.openssl.org/docs/crypto/dsa.html>---{-# 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)))))
− OpenSSL/ERR.hs
@@ -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
− OpenSSL/EVP/Base64.hs
@@ -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)
− OpenSSL/EVP/Cipher.hs
@@ -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)
− OpenSSL/EVP/Digest.hs
@@ -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)
− OpenSSL/EVP/Open.hs
@@ -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
− OpenSSL/EVP/PKey.hs
@@ -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
− OpenSSL/EVP/Seal.hs
@@ -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)
− OpenSSL/EVP/Sign.hs
@@ -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
− OpenSSL/EVP/Verify.hs
@@ -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
− OpenSSL/Objects.hs
@@ -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
− OpenSSL/PEM.hs
@@ -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'
− OpenSSL/PKCS7.hs
@@ -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)
− OpenSSL/RSA.hs
@@ -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))
− OpenSSL/Random.hs
@@ -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 <http://www.openssl.org/docs/crypto/rand.html>--- 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)
− OpenSSL/Stack.hs
@@ -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
− OpenSSL/X509.hs
@@ -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
− OpenSSL/X509/Name.hs
@@ -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)
− OpenSSL/X509/Request.hs
@@ -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
− OpenSSL/X509/Revocation.hs
@@ -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 ()
− OpenSSL/X509/Store.hs
@@ -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 ()