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