HsOpenSSL 0.11.1 → 0.11.1.1
raw patch · 57 files changed
+2813/−2776 lines, 57 filesdep +HUnitdep +HsOpenSSLdep +test-frameworkdep ~bytestringdep ~integer-gmpdep ~networkPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies added: HUnit, HsOpenSSL, test-framework, test-framework-hunit
Dependency ranges changed: bytestring, integer-gmp, network, old-locale, time
API changes (from Hackage documentation)
- OpenSSL.EVP.PKey: class PKey k
- OpenSSL.PKCS7: data PKCS7
- OpenSSL.PKCS7: withPkcs7Ptr :: Pkcs7 -> (Ptr PKCS7 -> IO a) -> IO a
- OpenSSL.PKCS7: wrapPkcs7Ptr :: Ptr PKCS7 -> IO Pkcs7
Files
- ChangeLog +40/−0
- HsOpenSSL.cabal +108/−78
- OpenSSL.hs +110/−0
- OpenSSL.hsc +0/−116
- OpenSSL/ASN1.hsc +3/−4
- OpenSSL/BIO.hs +480/−0
- OpenSSL/BIO.hsc +0/−478
- OpenSSL/BN.hsc +13/−10
- OpenSSL/Cipher.hsc +4/−4
- OpenSSL/DH.hs +2/−1
- OpenSSL/DH/Internal.hs +53/−0
- OpenSSL/DH/Internal.hsc +0/−51
- OpenSSL/DSA.hsc +20/−16
- OpenSSL/ERR.hs +23/−0
- OpenSSL/ERR.hsc +0/−22
- OpenSSL/EVP/Base64.hs +150/−0
- OpenSSL/EVP/Base64.hsc +0/−148
- OpenSSL/EVP/Cipher.hs +96/−0
- OpenSSL/EVP/Cipher.hsc +0/−100
- OpenSSL/EVP/Digest.hsc +18/−14
- OpenSSL/EVP/Internal.hsc +11/−9
- OpenSSL/EVP/Open.hs +91/−0
- OpenSSL/EVP/Open.hsc +0/−89
- OpenSSL/EVP/PKey.hsc +13/−15
- OpenSSL/EVP/Seal.hs +140/−0
- OpenSSL/EVP/Seal.hsc +0/−143
- OpenSSL/EVP/Sign.hs +67/−0
- OpenSSL/EVP/Sign.hsc +0/−70
- OpenSSL/EVP/Verify.hs +82/−0
- OpenSSL/EVP/Verify.hsc +0/−84
- OpenSSL/Objects.hsc +3/−3
- OpenSSL/PEM.hs +521/−0
- OpenSSL/PEM.hsc +0/−523
- OpenSSL/PKCS7.hsc +5/−8
- OpenSSL/RSA.hsc +18/−15
- OpenSSL/Random.hs +51/−0
- OpenSSL/Random.hsc +0/−56
- OpenSSL/SSL.hs +16/−0
- OpenSSL/SSL.hsc +0/−15
- OpenSSL/SSL/Option.hsc +6/−1
- OpenSSL/Session.hsc +8/−4
- OpenSSL/Stack.hs +61/−0
- OpenSSL/Stack.hsc +0/−60
- OpenSSL/X509.hs +4/−4
- OpenSSL/X509/Name.hsc +3/−4
- OpenSSL/X509/Request.hs +253/−0
- OpenSSL/X509/Request.hsc +0/−255
- OpenSSL/X509/Revocation.hsc +5/−7
- OpenSSL/X509/Store.hs +145/−0
- OpenSSL/X509/Store.hsc +0/−148
- Test/OpenSSL/Cipher.hs +78/−0
- Test/OpenSSL/DSA.hs +39/−0
- Test/OpenSSL/EVP/Base64.hs +73/−0
- tests/Base64.hs +0/−71
- tests/Cipher.hs +0/−91
- tests/DSA.hs +0/−48
- tests/Makefile +0/−11
ChangeLog view
@@ -1,3 +1,43 @@+2015-01-06 PHO <pho@cielonegro.org>++ * HsOpenSSL.cabal (Version): Bump version to 0.11.1.1++ * OpenSSL/SSL/Option.hsc: Guard SSL_OP_SAFARI_ECDHE_ECDSA_BUG with+ #if defined(), Reported by Leon Mergen (#37).++2014-12-31 PHO <pho@cielonegro.org>++ * tests/DSA.hs: Rename to Test/OpenSSL/DSA.hs and make it a cabal+ test-case.++ * tests/Cipher.hs: Rename to Test/OpenSSL/Cipher.hs and make it a+ cabal test-case.++ * tests/Base64.hs: Rename to Test/OpenSSL/EVP/Base64.hs and make+ it a cabal test-case.++ * HsOpenSSL.cabal (Install-Includes): Removed. HsOpenSSL.h needs+ not be installed.++ * HsOpenSSL.cabal (Extensions): Removed. Use {-# LANGUAGE #-}+ pragma instead.++ * OpenSSL/EVP/Internal.hsc (VaguePKey, PKey): Turn documentation+ comments into Haddock ones.++ * OpenSSL/EVP/PKey.hsc (module): Do not re-export PKey. It was+ only accidentally re-exported.++ * HsOpenSSL.cabal (Build-Depends): Narrow version ranges that were+ unnecessarily wide.++ * HsOpenSSL.cabal (Build-Depends): ghc-prim is only required when+ fast-bignum is enabled and the compiler is ghc < 6.11.++ * HsOpenSSL.cabal (Build-Depends) [fast-bignum]: Declare that+ integer-gmp >= 1 is not supported yet. Reported by Herbert+ Valerio Riedel (#36).+ 2014-12-23 PHO <pho@cielonegro.org> * OpenSSL/ASN1.hsc (peekASN1Time): Support time-1.5,
HsOpenSSL.cabal view
@@ -12,7 +12,7 @@ <http://hackage.haskell.org/package/tls>, which is a pure Haskell implementation of SSL. .-Version: 0.11.1+Version: 0.11.1.1 License: PublicDomain License-File: COPYING Author: Adam Langley, Mikhail Vorozhtsov, PHO, Taru Karttunen@@ -22,7 +22,7 @@ Bug-Reports: https://github.com/phonohawk/HsOpenSSL/issues Category: Cryptography Tested-With: GHC == 7.6.2-Cabal-Version: >= 1.6+Cabal-Version: >= 1.8 Build-Type: Simple Extra-Source-Files: AUTHORS@@ -37,10 +37,6 @@ examples/Server.hs examples/server.crt examples/server.pem- tests/Base64.hs- tests/Cipher.hs- tests/DSA.hs- tests/Makefile Source-Repository head Type: git@@ -53,78 +49,112 @@ True Library- Build-Depends:- base >= 4 && < 5,- bytestring,- ghc-prim,- network >= 2.1.0.0,- old-locale,- time >= 1.1.1 && < 1.6- -- old-locale is only needed if time >= 1.5, but Cabal does not- -- allow us to express conditional dependencies like this.+ Build-Depends:+ base == 4.*,+ bytestring >= 0.9 && < 0.11,+ network >= 2.1 && < 2.7,+ old-locale >= 1.0 && < 1.1,+ time >= 1.1.1 && < 1.6+ -- old-locale is only needed if time < 1.5, but Cabal does not+ -- allow us to express conditional dependencies like this. - if flag(fast-bignum)- CPP-Options: -DFAST_BIGNUM- if impl(ghc >= 6.11)- Build-Depends: integer-gmp- else- Build-Depends: integer+ if flag(fast-bignum)+ CPP-Options: -DFAST_BIGNUM+ if impl(ghc >= 6.11)+ -- TODO: integer-gmp >= 1 is not supported yet.+ -- https://github.com/phonohawk/HsOpenSSL/issues/36+ Build-Depends: integer-gmp >= 0.2 && < 1+ else+ Build-Depends: ghc-prim, integer - if os(mingw32)- Extra-Libraries: eay32 ssl32- C-Sources: cbits/mutex-win.c- CC-Options: -D MINGW32- CPP-Options: -DCALLCONV=stdcall- else- Extra-Libraries: crypto ssl- C-Sources: cbits/mutex-pthread.c- CC-Options: -D PTHREAD- CPP-Options: -DCALLCONV=ccall+ if os(mingw32)+ Extra-Libraries: eay32 ssl32+ C-Sources: cbits/mutex-win.c+ CC-Options: -D MINGW32+ CPP-Options: -DCALLCONV=stdcall+ else+ Extra-Libraries: crypto ssl+ C-Sources: cbits/mutex-pthread.c+ CC-Options: -D PTHREAD+ CPP-Options: -DCALLCONV=ccall - Exposed-Modules:- OpenSSL- OpenSSL.BN- OpenSSL.EVP.Base64- OpenSSL.EVP.Cipher- OpenSSL.EVP.Digest- OpenSSL.EVP.Internal- 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- OpenSSL.Session- OpenSSL.DH- Other-Modules:- OpenSSL.ASN1- OpenSSL.BIO- OpenSSL.ERR- OpenSSL.Objects- OpenSSL.SSL- OpenSSL.SSL.Option- OpenSSL.Stack- OpenSSL.Utils- OpenSSL.X509.Name- OpenSSL.DH.Internal- Extensions:- ForeignFunctionInterface, EmptyDataDecls, MagicHash,- UnboxedTuples, UnliftedFFITypes, DeriveDataTypeable,- ExistentialQuantification, RankNTypes- ghc-options:- -Wall- C-Sources:- cbits/HsOpenSSL.c- Include-Dirs:- cbits- Install-Includes:- HsOpenSSL.h+ Exposed-Modules:+ OpenSSL+ OpenSSL.BN+ OpenSSL.EVP.Base64+ OpenSSL.EVP.Cipher+ OpenSSL.EVP.Digest+ OpenSSL.EVP.Internal+ 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+ OpenSSL.Session+ OpenSSL.DH+ Other-Modules:+ OpenSSL.ASN1+ OpenSSL.BIO+ OpenSSL.ERR+ OpenSSL.Objects+ OpenSSL.SSL+ OpenSSL.SSL.Option+ OpenSSL.Stack+ OpenSSL.Utils+ OpenSSL.X509.Name+ OpenSSL.DH.Internal+ GHC-Options:+ -Wall+ C-Sources:+ cbits/HsOpenSSL.c+ Include-Dirs:+ cbits++Test-Suite test-cipher+ Type: exitcode-stdio-1.0+ Main-Is: Test/OpenSSL/Cipher.hs+ Build-Depends:+ HsOpenSSL,+ HUnit >= 1.0 && < 1.3,+ base == 4.*,+ bytestring >= 0.9 && < 0.11,+ test-framework >= 0.8 && < 0.9,+ test-framework-hunit >= 0.3 && < 0.4+ GHC-Options:+ -Wall++Test-Suite test-dsa+ Type: exitcode-stdio-1.0+ Main-Is: Test/OpenSSL/DSA.hs+ Build-Depends:+ HsOpenSSL,+ HUnit >= 1.0 && < 1.3,+ base == 4.*,+ bytestring >= 0.9 && < 0.11,+ test-framework >= 0.8 && < 0.9,+ test-framework-hunit >= 0.3 && < 0.4+ GHC-Options:+ -Wall++Test-Suite test-evp-base64+ Type: exitcode-stdio-1.0+ Main-Is: Test/OpenSSL/EVP/Base64.hs+ Build-Depends:+ HsOpenSSL,+ HUnit >= 1.0 && < 1.3,+ base == 4.*,+ bytestring >= 0.9 && < 0.11,+ test-framework >= 0.8 && < 0.9,+ test-framework-hunit >= 0.3 && < 0.4+ GHC-Options:+ -Wall
+ OpenSSL.hs view
@@ -0,0 +1,110 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ForeignFunctionInterface #-}+-- |HsOpenSSL is an 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.+--+-- Please note that this project has started at the time when there+-- were no pure-Haskell implementations of TLS. Now there is tls+-- package (<http://hackage.haskell.org/package/tls>), which looks+-- pretty saner than HsOpenSSL especially for initialisation and error+-- handlings. So PHO (the initial author of HsOpenSSL) wants to+-- encourage you to use and improve the tls package instead as long as+-- possible. The only problem is that the tls package has not received+-- as much review as OpenSSL from cryptography specialists yet, thus+-- we can't assume it's secure enough.+--+-- Features that aren't (yet) supported:+--+-- [/SSL network connection/] ssl(3) functionalities aren't fully+-- covered yet. See "OpenSSL.Session".+--+-- [/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@.+--+-- [/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?+module OpenSSL+ ( withOpenSSL+ )+ where+import Control.Concurrent.MVar+import Control.Monad+import OpenSSL.SSL+import System.IO.Unsafe++#if !MIN_VERSION_base(4,6,0)+import Control.Exception (onException, mask_)+#endif++foreign import ccall "HsOpenSSL_setupMutex"+ setupMutex :: IO ()+++-- |Computation of @'withOpenSSL' action@ initializes the OpenSSL+-- library as necessary, and computes @action@. Every application that+-- uses HsOpenSSL must wrap any operations involving OpenSSL with+-- 'withOpenSSL', or they might crash:+--+-- > module Main where+-- > import OpenSSL+-- >+-- > main :: IO ()+-- > main = withOpenSSL $+-- > do ...+--+-- Since 0.10.3.5, 'withOpenSSL' is safe to be applied+-- redundantly. Library authors may wish to wrap their functions not+-- to force their users to think about initialization:+--+-- > get :: URI -> IO Response+-- > get uri = withOpenSSL $ internalImplementationOfGet uri+--+withOpenSSL :: IO a -> IO a+withOpenSSL io+ -- We don't want our initialisation sequence to be interrupted+ -- halfway.+ = do modifyMVarMasked_ isInitialised $ \ done ->+ do unless done $ do loadErrorStrings+ addAllAlgorithms+ libraryInit+ setupMutex+ return True+ io++#if !MIN_VERSION_base(4,6,0)+{-|+ Like 'modifyMVar_', but the @IO@ action in the second argument is executed with+ asynchronous exceptions masked.+-}+{-# INLINE modifyMVarMasked_ #-}+modifyMVarMasked_ :: MVar a -> (a -> IO a) -> IO ()+modifyMVarMasked_ m io =+ mask_ $ do+ a <- takeMVar m+ a' <- io a `onException` putMVar m a+ putMVar m a'+#endif++-- This variable must be atomically fetched/stored not to initialise+-- the library twice.+isInitialised :: MVar Bool+{-# NOINLINE isInitialised #-}+isInitialised =+ unsafePerformIO $ newMVar False
− OpenSSL.hsc
@@ -1,116 +0,0 @@-{- -*- haskell -*- -}---- |HsOpenSSL is an 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.------ Please note that this project has started at the time when there--- were no pure-Haskell implementations of TLS. Now there is tls--- package (<http://hackage.haskell.org/package/tls>), which looks--- pretty saner than HsOpenSSL especially for initialisation and error--- handlings. So PHO (the initial author of HsOpenSSL) wants to--- encourage you to use and improve the tls package instead as long as--- possible. The only problem is that the tls package has not received--- as much review as OpenSSL from cryptography specialists yet, thus--- we can't assume it's secure enough.------ Features that aren't (yet) supported:------ [/SSL network connection/] ssl(3) functionalities aren't fully--- covered yet. See "OpenSSL.Session".------ [/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?--#include "HsOpenSSL.h"--module OpenSSL- ( withOpenSSL- )- where-import Control.Concurrent.MVar-import Control.Monad-import OpenSSL.SSL-import System.IO.Unsafe--#if !MIN_VERSION_base(4,6,0)-import Control.Exception (onException, mask_)-#endif--foreign import ccall "HsOpenSSL_setupMutex"- setupMutex :: IO ()----- |Computation of @'withOpenSSL' action@ initializes the OpenSSL--- library as necessary, and computes @action@. Every application that--- uses HsOpenSSL must wrap any operations involving OpenSSL with--- 'withOpenSSL', or they might crash:------ > module Main where--- > import OpenSSL--- >--- > main :: IO ()--- > main = withOpenSSL $--- > do ...------ Since 0.10.3.5, 'withOpenSSL' is safe to be applied--- redundantly. Library authors may wish to wrap their functions not--- to force their users to think about initialization:------ > get :: URI -> IO Response--- > get uri = withOpenSSL $ internalImplementationOfGet uri----withOpenSSL :: IO a -> IO a-withOpenSSL io- -- We don't want our initialisation sequence to be interrupted- -- halfway.- = do modifyMVarMasked_ isInitialised $ \ done ->- do unless done $ do loadErrorStrings- addAllAlgorithms- libraryInit- setupMutex- return True- io--#if !MIN_VERSION_base(4,6,0)-{-|- Like 'modifyMVar_', but the @IO@ action in the second argument is executed with- asynchronous exceptions masked.--}-{-# INLINE modifyMVarMasked_ #-}-modifyMVarMasked_ :: MVar a -> (a -> IO a) -> IO ()-modifyMVarMasked_ m io =- mask_ $ do- a <- takeMVar m- a' <- io a `onException` putMVar m a- putMVar m a'-#endif---- This variable must be atomically fetched/stored not to initialise--- the library twice.-isInitialised :: MVar Bool-{-# NOINLINE isInitialised #-}-isInitialised =- unsafePerformIO $ newMVar False
OpenSSL/ASN1.hsc view
@@ -1,5 +1,5 @@-#include "HsOpenSSL.h"-+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ForeignFunctionInterface #-} module OpenSSL.ASN1 ( ASN1_OBJECT , obj2nid@@ -18,8 +18,7 @@ , withASN1Time ) where--+#include "HsOpenSSL.h" import Control.Exception import Data.Time.Clock import Data.Time.Clock.POSIX
+ OpenSSL/BIO.hs view
@@ -0,0 +1,480 @@+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{- --------------------------------------------------------------------------- -}+{- -}+{- 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.Internal (createAndTrim, toForeignPtr)+import Data.ByteString.Unsafe (unsafeUseAsCStringLen)+import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy.Char8 as L+import qualified Data.ByteString.Lazy.Internal as L+import Foreign hiding (new)+import Foreign.C+import Foreign.Concurrent as Conc+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 :: 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_ -> CInt -> IO ()++foreign import ccall unsafe "HsOpenSSL_BIO_should_retry"+ _should_retry :: Ptr BIO_ -> IO CInt+++new :: Ptr BIO_METHOD -> IO BIO+new method+ = _new method >>= failIfNull >>= wrapBioPtr+++wrapBioPtr :: Ptr BIO_ -> IO BIO+wrapBioPtr bioPtr+ = fmap BIO (Conc.newForeignPtr bioPtr (_free bioPtr))+++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+++-- Connect 'b' behind 'a'. It's possible that 1. we only retain 'a'+-- and write to 'a', and 2. we only retain 'b' and read from 'b', so+-- both ForeignPtr's have to touch each other. This involves a+-- circular dependency but that won't be a problem as the garbage+-- collector isn't reference-counting.++-- |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+ Conc.addForeignPtrFinalizer a $ touchForeignPtr b+ Conc.addForeignPtrFinalizer 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 -> CInt -> IO ()+setFlags bio flags+ = withBioPtr bio $ flip _set_flags flags+ ++bioShouldRetry :: BIO -> IO Bool+bioShouldRetry bio+ = withBioPtr bio $ \ bioPtr ->+ fmap (/= 0) (_should_retry bioPtr)+++{- ctrl --------------------------------------------------------------------- -}++foreign import ccall unsafe "HsOpenSSL_BIO_flush"+ _flush :: Ptr BIO_ -> IO CInt++foreign import ccall unsafe "HsOpenSSL_BIO_reset"+ _reset :: Ptr BIO_ -> IO CInt++foreign import ccall unsafe "HsOpenSSL_BIO_eof"+ _eof :: Ptr BIO_ -> IO CInt++-- |@'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 () -- Return value of BIO_reset is not+ -- consistent in every BIO's so we+ -- can't do error-checking.++-- |@'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 ->+ fmap (==1) (_eof bioPtr)+++{- I/O ---------------------------------------------------------------------- -}++foreign import ccall unsafe "BIO_read"+ _read :: Ptr BIO_ -> Ptr CChar -> CInt -> IO CInt++foreign import ccall unsafe "BIO_gets"+ _gets :: Ptr BIO_ -> Ptr CChar -> CInt -> IO CInt++foreign import ccall unsafe "BIO_write"+ _write :: Ptr BIO_ -> Ptr CChar -> CInt -> IO CInt++-- |@'bioRead' bio@ lazily reads all data in @bio@.+bioRead :: BIO -> IO String+bioRead bio+ = liftM L.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 B.ByteString+bioReadBS bio maxLen+ = withBioPtr bio $ \ bioPtr ->+ createAndTrim maxLen $ \ bufPtr ->+ _read bioPtr (castPtr bufPtr) (fromIntegral maxLen) >>= interpret+ where+ interpret :: CInt -> IO Int+ interpret n+ | n == 0 = return 0+ | n == -1 = return 0+ | n < -1 = raiseOpenSSLError+ | otherwise = return (fromIntegral n)++-- |@'bioReadLBS' bio@ lazily reads all data in @bio@, then return a+-- LazyByteString.+bioReadLBS :: BIO -> IO L.ByteString+bioReadLBS bio = fmap L.fromChunks lazyRead+ where+ chunkSize = L.defaultChunkSize+ + lazyRead = unsafeInterleaveIO loop++ loop = do bs <- bioReadBS bio chunkSize+ if B.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 B.unpack (bioGetsBS bio maxLen)++-- |'bioGetsBS' does the same as 'bioGets' but returns ByteString.+bioGetsBS :: BIO -> Int -> IO B.ByteString+bioGetsBS bio maxLen+ = withBioPtr bio $ \ bioPtr ->+ createAndTrim maxLen $ \ bufPtr ->+ _gets bioPtr (castPtr bufPtr) (fromIntegral maxLen) >>= interpret+ where+ interpret :: CInt -> IO Int+ interpret n+ | n == 0 = return 0+ | n == -1 = return 0+ | n < -1 = raiseOpenSSLError+ | otherwise = return (fromIntegral n)++-- |'bioGetsLBS' does the same as 'bioGets' but returns+-- LazyByteString.+bioGetsLBS :: BIO -> Int -> IO L.ByteString+bioGetsLBS bio maxLen+ = bioGetsBS bio maxLen >>= \ bs -> (return . L.fromChunks) [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 . L.pack) str >>= bioWriteLBS bio++-- |@'bioWriteBS' bio bs@ writes @bs@ to @bio@.+bioWriteBS :: BIO -> B.ByteString -> IO ()+bioWriteBS bio bs+ = withBioPtr bio $ \ bioPtr ->+ unsafeUseAsCStringLen bs $ \ (buf, len) ->+ _write bioPtr buf (fromIntegral len) >>= interpret+ where+ interpret :: CInt -> IO ()+ interpret n+ | n == fromIntegral (B.length bs)+ = return ()+ | n == -1 = bioWriteBS bio bs -- full retry+ | n < -1 = raiseOpenSSLError+ | otherwise = bioWriteBS bio (B.drop (fromIntegral n) bs) -- partial retry++-- |@'bioWriteLBS' bio lbs@ lazily writes entire @lbs@ to @bio@. The+-- string doesn't necessarily have to be finite.+bioWriteLBS :: BIO -> L.ByteString -> IO ()+bioWriteLBS bio lbs+ = mapM_ (bioWriteBS bio) $ L.toChunks lbs+++{- 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 :: CInt++-- |@'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_ -> CInt -> IO CInt+++-- |@'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 (fromIntegral 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 -> CInt -> 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 read 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 = newConstMemBS (B.pack str)++-- |@'newConstMemBS' bs@ is like 'newConstMem' but takes a ByteString.+newConstMemBS :: B.ByteString -> IO BIO+newConstMemBS bs+ = let (foreignBuf, off, len) = toForeignPtr bs+ in+ -- Let the BIO's finalizer have a reference to the ByteString.+ withForeignPtr foreignBuf $ \ buf ->+ do bioPtr <- _new_mem_buf (castPtr $ buf `plusPtr` off) (fromIntegral len)+ >>= failIfNull++ bio <- newForeignPtr_ bioPtr+ Conc.addForeignPtrFinalizer bio (_free bioPtr >> touchForeignPtr foreignBuf)+ + return $ BIO bio++-- |@'newConstMemLBS' lbs@ is like 'newConstMem' but takes a+-- LazyByteString.+newConstMemLBS :: L.ByteString -> IO BIO+newConstMemLBS lbs+ = (return . B.concat . L.toChunks) lbs >>= 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
@@ -1,478 +0,0 @@-{- --------------------------------------------------------------------------- -}-{- -}-{- 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.Internal (createAndTrim, toForeignPtr)-import Data.ByteString.Unsafe (unsafeUseAsCStringLen)-import qualified Data.ByteString.Char8 as B-import qualified Data.ByteString.Lazy.Char8 as L-import qualified Data.ByteString.Lazy.Internal as L-import Foreign hiding (new)-import Foreign.C-import Foreign.Concurrent as Conc-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 :: 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_ -> CInt -> IO ()--foreign import ccall unsafe "HsOpenSSL_BIO_should_retry"- _should_retry :: Ptr BIO_ -> IO CInt---new :: Ptr BIO_METHOD -> IO BIO-new method- = _new method >>= failIfNull >>= wrapBioPtr---wrapBioPtr :: Ptr BIO_ -> IO BIO-wrapBioPtr bioPtr- = fmap BIO (Conc.newForeignPtr bioPtr (_free bioPtr))---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----- Connect 'b' behind 'a'. It's possible that 1. we only retain 'a'--- and write to 'a', and 2. we only retain 'b' and read from 'b', so--- both ForeignPtr's have to touch each other. This involves a--- circular dependency but that won't be a problem as the garbage--- collector isn't reference-counting.---- |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- Conc.addForeignPtrFinalizer a $ touchForeignPtr b- Conc.addForeignPtrFinalizer 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 -> CInt -> IO ()-setFlags bio flags- = withBioPtr bio $ flip _set_flags flags- --bioShouldRetry :: BIO -> IO Bool-bioShouldRetry bio- = withBioPtr bio $ \ bioPtr ->- fmap (/= 0) (_should_retry bioPtr)---{- ctrl --------------------------------------------------------------------- -}--foreign import ccall unsafe "HsOpenSSL_BIO_flush"- _flush :: Ptr BIO_ -> IO CInt--foreign import ccall unsafe "HsOpenSSL_BIO_reset"- _reset :: Ptr BIO_ -> IO CInt--foreign import ccall unsafe "HsOpenSSL_BIO_eof"- _eof :: Ptr BIO_ -> IO CInt---- |@'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 () -- Return value of BIO_reset is not- -- consistent in every BIO's so we- -- can't do error-checking.---- |@'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 ->- fmap (==1) (_eof bioPtr)---{- I/O ---------------------------------------------------------------------- -}--foreign import ccall unsafe "BIO_read"- _read :: Ptr BIO_ -> Ptr CChar -> CInt -> IO CInt--foreign import ccall unsafe "BIO_gets"- _gets :: Ptr BIO_ -> Ptr CChar -> CInt -> IO CInt--foreign import ccall unsafe "BIO_write"- _write :: Ptr BIO_ -> Ptr CChar -> CInt -> IO CInt---- |@'bioRead' bio@ lazily reads all data in @bio@.-bioRead :: BIO -> IO String-bioRead bio- = liftM L.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 B.ByteString-bioReadBS bio maxLen- = withBioPtr bio $ \ bioPtr ->- createAndTrim maxLen $ \ bufPtr ->- _read bioPtr (castPtr bufPtr) (fromIntegral maxLen) >>= interpret- where- interpret :: CInt -> IO Int- interpret n- | n == 0 = return 0- | n == -1 = return 0- | n < -1 = raiseOpenSSLError- | otherwise = return (fromIntegral n)---- |@'bioReadLBS' bio@ lazily reads all data in @bio@, then return a--- LazyByteString.-bioReadLBS :: BIO -> IO L.ByteString-bioReadLBS bio = fmap L.fromChunks lazyRead- where- chunkSize = L.defaultChunkSize- - lazyRead = unsafeInterleaveIO loop-- loop = do bs <- bioReadBS bio chunkSize- if B.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 B.unpack (bioGetsBS bio maxLen)---- |'bioGetsBS' does the same as 'bioGets' but returns ByteString.-bioGetsBS :: BIO -> Int -> IO B.ByteString-bioGetsBS bio maxLen- = withBioPtr bio $ \ bioPtr ->- createAndTrim maxLen $ \ bufPtr ->- _gets bioPtr (castPtr bufPtr) (fromIntegral maxLen) >>= interpret- where- interpret :: CInt -> IO Int- interpret n- | n == 0 = return 0- | n == -1 = return 0- | n < -1 = raiseOpenSSLError- | otherwise = return (fromIntegral n)---- |'bioGetsLBS' does the same as 'bioGets' but returns--- LazyByteString.-bioGetsLBS :: BIO -> Int -> IO L.ByteString-bioGetsLBS bio maxLen- = bioGetsBS bio maxLen >>= \ bs -> (return . L.fromChunks) [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 . L.pack) str >>= bioWriteLBS bio---- |@'bioWriteBS' bio bs@ writes @bs@ to @bio@.-bioWriteBS :: BIO -> B.ByteString -> IO ()-bioWriteBS bio bs- = withBioPtr bio $ \ bioPtr ->- unsafeUseAsCStringLen bs $ \ (buf, len) ->- _write bioPtr buf (fromIntegral len) >>= interpret- where- interpret :: CInt -> IO ()- interpret n- | n == fromIntegral (B.length bs)- = return ()- | n == -1 = bioWriteBS bio bs -- full retry- | n < -1 = raiseOpenSSLError- | otherwise = bioWriteBS bio (B.drop (fromIntegral n) bs) -- partial retry---- |@'bioWriteLBS' bio lbs@ lazily writes entire @lbs@ to @bio@. The--- string doesn't necessarily have to be finite.-bioWriteLBS :: BIO -> L.ByteString -> IO ()-bioWriteLBS bio lbs- = mapM_ (bioWriteBS bio) $ L.toChunks lbs---{- 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 :: CInt---- |@'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_ -> CInt -> IO CInt----- |@'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 (fromIntegral 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 -> CInt -> 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 read 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 = newConstMemBS (B.pack str)---- |@'newConstMemBS' bs@ is like 'newConstMem' but takes a ByteString.-newConstMemBS :: B.ByteString -> IO BIO-newConstMemBS bs- = let (foreignBuf, off, len) = toForeignPtr bs- in- -- Let the BIO's finalizer have a reference to the ByteString.- withForeignPtr foreignBuf $ \ buf ->- do bioPtr <- _new_mem_buf (castPtr $ buf `plusPtr` off) (fromIntegral len)- >>= failIfNull-- bio <- newForeignPtr_ bioPtr- Conc.addForeignPtrFinalizer bio (_free bioPtr >> touchForeignPtr foreignBuf)- - return $ BIO bio---- |@'newConstMemLBS' lbs@ is like 'newConstMem' but takes a--- LazyByteString.-newConstMemLBS :: L.ByteString -> IO BIO-newConstMemLBS lbs- = (return . B.concat . L.toChunks) lbs >>= newConstMemBS--{- null --------------------------------------------------------------------- -}--foreign import ccall unsafe "BIO_s_null"- s_null :: IO (Ptr BIO_METHOD)---- |@'newNullBIO'@ creates a null BIO sink\/source. Data written to--- the null sink is discarded, reads return EOF.------ A null sink is useful if, for example, an application wishes to--- digest some data by writing through a digest bio but not send the--- digested data anywhere. Since a BIO chain must normally include a--- source\/sink BIO this can be achieved by adding a null sink BIO to--- the end of the chain.-newNullBIO :: IO BIO-newNullBIO = s_null >>= new
OpenSSL/BN.hsc view
@@ -1,12 +1,15 @@+#if defined(FAST_BIGNUM)+{-# LANGUAGE BangPatterns #-}+#endif+{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE ForeignFunctionInterface #-}-{-# LANGUAGE BangPatterns #-}--#include "HsOpenSSL.h"--{-# OPTIONS_HADDOCK prune #-}-+#if defined(FAST_BIGNUM)+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE UnliftedFFITypes #-}+#endif+{-# OPTIONS_HADDOCK prune #-} -- |BN - multiprecision integer arithmetics- module OpenSSL.BN ( -- * Type BigNum@@ -39,7 +42,7 @@ , prandIntegerOneToNMinusOne ) where-+#include "HsOpenSSL.h" import Control.Exception hiding (try) import qualified Data.ByteString as BS import Foreign.Marshal@@ -48,7 +51,7 @@ import OpenSSL.Utils import System.IO.Unsafe -#ifdef FAST_BIGNUM+#if defined(FAST_BIGNUM) import Foreign.C.Types import GHC.Base # if MIN_VERSION_integer_gmp(0,2,0)@@ -90,7 +93,7 @@ wrapBN = BigNum -#ifndef FAST_BIGNUM+#if !defined(FAST_BIGNUM) {- slow, safe functions ----------------------------------------------------- -}
OpenSSL/Cipher.hsc view
@@ -1,6 +1,5 @@-#include "HsOpenSSL.h"-#include "openssl/aes.h"-+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ForeignFunctionInterface #-} -- | 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@@ -19,7 +18,8 @@ , aesCBC , aesCTR) where-+#include "HsOpenSSL.h"+#include "openssl/aes.h" import Control.Monad (when, unless) import Data.IORef import Foreign
OpenSSL/DH.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ForeignFunctionInterface #-} -- | Diffie-Hellman key exchange module OpenSSL.DH ( DHP
+ OpenSSL/DH/Internal.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ForeignFunctionInterface #-}+module OpenSSL.DH.Internal (+ DH_,+ DHP,+ withDHPPtr,+ wrapDHPPtrWith,+ wrapDHPPtr,+ DH,+ withDHPtr,+ wrapDHPtrWith,+ wrapDHPtr,+ asDH,+ asDHP+ ) where++import Control.Applicative ((<$>))+import Foreign.Ptr (Ptr)+import Foreign.ForeignPtr (ForeignPtr, withForeignPtr)+import qualified Foreign.Concurrent as FC++data DH_+newtype DHP = DHP (ForeignPtr DH_)++withDHPPtr :: DHP -> (Ptr DH_ -> IO a) -> IO a+withDHPPtr (DHP fp) = withForeignPtr fp++wrapDHPPtrWith :: (Ptr DH_ -> IO ()) -> Ptr DH_ -> IO DHP+wrapDHPPtrWith fin p = DHP <$> FC.newForeignPtr p (fin p)++wrapDHPPtr :: Ptr DH_ -> IO DHP+wrapDHPPtr = wrapDHPPtrWith _DH_free++newtype DH = DH (ForeignPtr DH_)++withDHPtr :: DH -> (Ptr DH_ -> IO a) -> IO a+withDHPtr (DH fp) = withForeignPtr fp++wrapDHPtrWith :: (Ptr DH_ -> IO ()) -> Ptr DH_ -> IO DH+wrapDHPtrWith fin p = DH <$> FC.newForeignPtr p (fin p)++wrapDHPtr :: Ptr DH_ -> IO DH+wrapDHPtr = wrapDHPtrWith _DH_free++asDH :: DHP -> DH+asDH (DHP fp) = DH fp++asDHP :: DH -> DHP+asDHP (DH fp) = DHP fp++foreign import ccall "DH_free"+ _DH_free :: Ptr DH_ -> IO ()+
− OpenSSL/DH/Internal.hsc
@@ -1,51 +0,0 @@-module OpenSSL.DH.Internal (- DH_,- DHP,- withDHPPtr,- wrapDHPPtrWith,- wrapDHPPtr,- DH,- withDHPtr,- wrapDHPtrWith,- wrapDHPtr,- asDH,- asDHP- ) where--import Control.Applicative ((<$>))-import Foreign.Ptr (Ptr)-import Foreign.ForeignPtr (ForeignPtr, withForeignPtr)-import qualified Foreign.Concurrent as FC--data DH_-newtype DHP = DHP (ForeignPtr DH_)--withDHPPtr :: DHP -> (Ptr DH_ -> IO a) -> IO a-withDHPPtr (DHP fp) = withForeignPtr fp--wrapDHPPtrWith :: (Ptr DH_ -> IO ()) -> Ptr DH_ -> IO DHP-wrapDHPPtrWith fin p = DHP <$> FC.newForeignPtr p (fin p)--wrapDHPPtr :: Ptr DH_ -> IO DHP-wrapDHPPtr = wrapDHPPtrWith _DH_free--newtype DH = DH (ForeignPtr DH_)--withDHPtr :: DH -> (Ptr DH_ -> IO a) -> IO a-withDHPtr (DH fp) = withForeignPtr fp--wrapDHPtrWith :: (Ptr DH_ -> IO ()) -> Ptr DH_ -> IO DH-wrapDHPtrWith fin p = DH <$> FC.newForeignPtr p (fin p)--wrapDHPtr :: Ptr DH_ -> IO DH-wrapDHPtr = wrapDHPtrWith _DH_free--asDH :: DHP -> DH-asDH (DHP fp) = DH fp--asDHP :: DH -> DHP-asDHP (DH fp) = DHP fp--foreign import ccall "DH_free"- _DH_free :: Ptr DH_ -> IO ()-
OpenSSL/DSA.hsc view
@@ -1,12 +1,9 @@-{- -*- haskell -*- -}--{-# OPTIONS_HADDOCK prune #-}-+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# OPTIONS_HADDOCK prune #-} -- | The Digital Signature Algorithm (FIPS 186-2). -- See <http://www.openssl.org/docs/crypto/dsa.html>--#include "HsOpenSSL.h"- module OpenSSL.DSA ( -- * Type DSAKey(..)@@ -30,16 +27,23 @@ , tupleToDSAPubKey , tupleToDSAKeyPair ) where--import Control.Monad+#include "HsOpenSSL.h"+import Control.Monad import qualified Data.ByteString as BS-import Data.Typeable-import Foreign hiding (unsafePerformIO)-import System.IO.Unsafe (unsafePerformIO)-import Foreign.C (CString)-import Foreign.C.Types-import OpenSSL.BN-import OpenSSL.Utils+import Data.Typeable+import Foreign.C.String (CString)+#if MIN_VERSION_base(4,5,0)+import Foreign.C.Types (CChar(..), CInt(..))+#else+import Foreign.C.Types (CChar, CInt)+#endif+import Foreign.ForeignPtr (ForeignPtr, newForeignPtr, withForeignPtr)+import Foreign.Marshal.Alloc (alloca)+import Foreign.Ptr (FunPtr, Ptr, nullPtr)+import Foreign.Storable (Storable(..))+import OpenSSL.BN+import OpenSSL.Utils+import System.IO.Unsafe (unsafePerformIO) -- | The type of a DSA public key, includes parameters p, q, g and public. newtype DSAPubKey = DSAPubKey (ForeignPtr DSA)
+ OpenSSL/ERR.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE ForeignFunctionInterface #-}+module OpenSSL.ERR+ ( getError+ , peekError++ , errorString+ )+ where+import Foreign+import Foreign.C++foreign import ccall unsafe "ERR_get_error"+ getError :: IO CULong++foreign import ccall unsafe "ERR_peek_error"+ peekError :: IO CULong++foreign import ccall unsafe "ERR_error_string"+ _error_string :: CULong -> CString -> IO CString++errorString :: CULong -> IO String+errorString code+ = _error_string code nullPtr >>= peekCString
− OpenSSL/ERR.hsc
@@ -1,22 +0,0 @@-module OpenSSL.ERR- ( getError- , peekError-- , errorString- )- where-import Foreign-import Foreign.C--foreign import ccall unsafe "ERR_get_error"- getError :: IO CULong--foreign import ccall unsafe "ERR_peek_error"- peekError :: IO CULong--foreign import ccall unsafe "ERR_error_string"- _error_string :: CULong -> CString -> IO CString--errorString :: CULong -> IO String-errorString code- = _error_string code nullPtr >>= peekCString
+ OpenSSL/EVP/Base64.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ForeignFunctionInterface #-}+-- |An interface to Base64 codec.+module OpenSSL.EVP.Base64+ ( -- * Encoding+ encodeBase64+ , encodeBase64BS+ , encodeBase64LBS++ -- * Decoding+ , decodeBase64+ , decodeBase64BS+ , decodeBase64LBS+ )+ where+import Control.Exception (assert)+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+#if MIN_VERSION_base(4,5,0)+import Foreign.C.Types (CChar(..), CInt(..))+#else+import Foreign.C.Types (CChar, CInt)+#endif+import Foreign.Ptr (Ptr, castPtr)+import System.IO.Unsafe (unsafePerformIO)+++-- On encoding, we keep fetching the next block until we get at least+-- 3 bytes. Then we apply B8.concat to the returned [ByteString] and+-- split it at the offset in multiple of 3, then prepend the remaining+-- bytes to the next block.+--+-- On decoding, we apply the same algorithm but we split the input in+-- multiple of 4.+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 -------------------------------------------------------------------- -}++foreign import ccall unsafe "EVP_EncodeBlock"+ _EncodeBlock :: Ptr CChar -> Ptr CChar -> CInt -> IO CInt+++encodeBlock :: B8.ByteString -> B8.ByteString+encodeBlock inBS+ = unsafePerformIO $+ unsafeUseAsCStringLen inBS $ \ (inBuf, inLen) ->+ createAndTrim maxOutLen $ \ outBuf ->+ fmap fromIntegral+ (_EncodeBlock (castPtr outBuf) inBuf (fromIntegral 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.+{-# DEPRECATED encodeBase64 "Use encodeBase64BS or encodeBase64LBS instead." #-}+encodeBase64 :: String -> String+encodeBase64 = L8.unpack . encodeBase64LBS . L8.pack++-- |@'encodeBase64BS' bs@ strictly encodes a chunk of data to Base64.+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 :: L8.ByteString -> L8.ByteString+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+ -- The last remnant.+ (block', B8.empty)+ else+ B8.splitAt (blockLen' - blockLen' `mod` 3) block'+ remain = if B8.null leftover then+ remain'+ else+ L8.fromChunks [leftover] `L8.append` remain'+ encodedBlock = encodeBlock block+ encodedRemain = encodeBase64LBS remain+ in+ L8.fromChunks [encodedBlock] `L8.append` encodedRemain+++{- decode -------------------------------------------------------------------- -}++foreign import ccall unsafe "EVP_DecodeBlock"+ _DecodeBlock :: Ptr CChar -> Ptr CChar -> CInt -> IO CInt+++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 (fromIntegral inLen)+ >>= \ outLen -> return (fromIntegral 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.+{-# DEPRECATED decodeBase64 "Use decodeBase64BS or decodeBase64LBS instead." #-}+decodeBase64 :: String -> String+decodeBase64 = L8.unpack . decodeBase64LBS . L8.pack++-- |@'decodeBase64BS' bs@ strictly decodes a chunk of data from+-- Base64.+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 :: L8.ByteString -> L8.ByteString+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+ L8.fromChunks [leftover] `L8.append` remain'+ decodedBlock = decodeBlock block+ decodedRemain = decodeBase64LBS remain+ in+ L8.fromChunks [decodedBlock] `L8.append` decodedRemain
− OpenSSL/EVP/Base64.hsc
@@ -1,148 +0,0 @@-{- -*- haskell -*- -}---- |An interface to Base64 codec.--module OpenSSL.EVP.Base64- ( -- * Encoding- encodeBase64- , encodeBase64BS- , encodeBase64LBS-- -- * Decoding- , decodeBase64- , decodeBase64BS- , decodeBase64LBS- )- where--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-import Foreign hiding (unsafePerformIO)-import Foreign.C-import System.IO.Unsafe (unsafePerformIO)----- On encoding, we keep fetching the next block until we get at least--- 3 bytes. Then we apply B8.concat to the returned [ByteString] and--- split it at the offset in multiple of 3, then prepend the remaining--- bytes to the next block.------ On decoding, we apply the same algorithm but we split the input in--- multiple of 4.-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 -------------------------------------------------------------------- -}--foreign import ccall unsafe "EVP_EncodeBlock"- _EncodeBlock :: Ptr CChar -> Ptr CChar -> CInt -> IO CInt---encodeBlock :: B8.ByteString -> B8.ByteString-encodeBlock inBS- = unsafePerformIO $- unsafeUseAsCStringLen inBS $ \ (inBuf, inLen) ->- createAndTrim maxOutLen $ \ outBuf ->- fmap fromIntegral- (_EncodeBlock (castPtr outBuf) inBuf (fromIntegral 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.-{-# DEPRECATED encodeBase64 "Use encodeBase64BS or encodeBase64LBS instead." #-}-encodeBase64 :: String -> String-encodeBase64 = L8.unpack . encodeBase64LBS . L8.pack---- |@'encodeBase64BS' bs@ strictly encodes a chunk of data to Base64.-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 :: L8.ByteString -> L8.ByteString-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- -- The last remnant.- (block', B8.empty)- else- B8.splitAt (blockLen' - blockLen' `mod` 3) block'- remain = if B8.null leftover then- remain'- else- L8.fromChunks [leftover] `L8.append` remain'- encodedBlock = encodeBlock block- encodedRemain = encodeBase64LBS remain- in- L8.fromChunks [encodedBlock] `L8.append` encodedRemain---{- decode -------------------------------------------------------------------- -}--foreign import ccall unsafe "EVP_DecodeBlock"- _DecodeBlock :: Ptr CChar -> Ptr CChar -> CInt -> IO CInt---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 (fromIntegral inLen)- >>= \ outLen -> return (fromIntegral 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.-{-# DEPRECATED decodeBase64 "Use decodeBase64BS or decodeBase64LBS instead." #-}-decodeBase64 :: String -> String-decodeBase64 = L8.unpack . decodeBase64LBS . L8.pack---- |@'decodeBase64BS' bs@ strictly decodes a chunk of data from--- Base64.-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 :: L8.ByteString -> L8.ByteString-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- L8.fromChunks [leftover] `L8.append` remain'- decodedBlock = decodeBlock block- decodedRemain = decodeBase64LBS remain- in- L8.fromChunks [decodedBlock] `L8.append` decodedRemain
+ OpenSSL/EVP/Cipher.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE ForeignFunctionInterface #-}+-- |An interface to symmetric cipher algorithms.+module OpenSSL.EVP.Cipher+ ( Cipher+ , getCipherByName+ , getCipherNames++ , CryptoMode(..)++ , cipher+ , cipherBS+ , cipherLBS+ , cipherStrictLBS+ )+ where+import qualified Data.ByteString.Char8 as B8+import qualified Data.ByteString.Lazy.Char8 as L8+import Data.Monoid+import Foreign+import Foreign.C+import OpenSSL.Objects+import OpenSSL.EVP.Internal++foreign import ccall unsafe "EVP_get_cipherbyname"+ _get_cipherbyname :: CString -> IO (Ptr EVP_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++{- encrypt/decrypt ----------------------------------------------------------- -}++-- | Encrypt a lazy bytestring in a strict manner. Does not leak the keys.+cipherStrictLBS :: Cipher -- ^ Cipher+ -> B8.ByteString -- ^ Key+ -> B8.ByteString -- ^ IV+ -> CryptoMode -- ^ Encrypt\/Decrypt+ -> L8.ByteString -- ^ Input+ -> IO L8.ByteString+cipherStrictLBS c key iv mode input =+ do ctx <- cipherInitBS c key iv mode+ xs <- cipherUpdateBS ctx `mapM` L8.toChunks input+ x <- cipherFinalBS ctx+ return $ L8.fromChunks (xs `mappend` [x])++-- |@'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+{-# DEPRECATED cipher "Use cipherBS, cipherLBS or cipherStrictLBS." #-}+cipher c key iv mode input+ = fmap L8.unpack $ cipherLBS c (B8.pack key) (B8.pack iv) mode (L8.pack input)++-- |@'cipherBS'@ strictly encrypts or decrypts a chunk of data.+cipherBS :: Cipher -- ^ algorithm to use+ -> B8.ByteString -- ^ symmetric key+ -> B8.ByteString -- ^ IV+ -> CryptoMode -- ^ operation+ -> B8.ByteString -- ^ input string to encrypt\/decrypt+ -> IO B8.ByteString -- ^ the result string+cipherBS c key iv mode input+ = do ctx <- cipherInitBS 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+ -> B8.ByteString -- ^ symmetric key+ -> B8.ByteString -- ^ IV+ -> CryptoMode -- ^ operation+ -> L8.ByteString -- ^ input string to encrypt\/decrypt+ -> IO L8.ByteString -- ^ the result string+cipherLBS c key iv mode input+ = do ctx <- cipherInitBS c key iv mode+ cipherLazily ctx input+
− OpenSSL/EVP/Cipher.hsc
@@ -1,100 +0,0 @@-{- -*- haskell -*- -}---- |An interface to symmetric cipher algorithms.--#include "HsOpenSSL.h"--module OpenSSL.EVP.Cipher- ( Cipher- , getCipherByName- , getCipherNames-- , CryptoMode(..)-- , cipher- , cipherBS- , cipherLBS- , cipherStrictLBS- )- where-import qualified Data.ByteString.Char8 as B8-import qualified Data.ByteString.Lazy.Char8 as L8-import Data.Monoid-import Foreign-import Foreign.C-import OpenSSL.Objects-import OpenSSL.EVP.Internal--foreign import ccall unsafe "EVP_get_cipherbyname"- _get_cipherbyname :: CString -> IO (Ptr EVP_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--{- encrypt/decrypt ----------------------------------------------------------- -}---- | Encrypt a lazy bytestring in a strict manner. Does not leak the keys.-cipherStrictLBS :: Cipher -- ^ Cipher- -> B8.ByteString -- ^ Key- -> B8.ByteString -- ^ IV- -> CryptoMode -- ^ Encrypt\/Decrypt- -> L8.ByteString -- ^ Input- -> IO L8.ByteString-cipherStrictLBS c key iv mode input =- do ctx <- cipherInitBS c key iv mode- xs <- cipherUpdateBS ctx `mapM` L8.toChunks input- x <- cipherFinalBS ctx- return $ L8.fromChunks (xs `mappend` [x])---- |@'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-{-# DEPRECATED cipher "Use cipherBS, cipherLBS or cipherStrictLBS." #-}-cipher c key iv mode input- = fmap L8.unpack $ cipherLBS c (B8.pack key) (B8.pack iv) mode (L8.pack input)---- |@'cipherBS'@ strictly encrypts or decrypts a chunk of data.-cipherBS :: Cipher -- ^ algorithm to use- -> B8.ByteString -- ^ symmetric key- -> B8.ByteString -- ^ IV- -> CryptoMode -- ^ operation- -> B8.ByteString -- ^ input string to encrypt\/decrypt- -> IO B8.ByteString -- ^ the result string-cipherBS c key iv mode input- = do ctx <- cipherInitBS 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- -> B8.ByteString -- ^ symmetric key- -> B8.ByteString -- ^ IV- -> CryptoMode -- ^ operation- -> L8.ByteString -- ^ input string to encrypt\/decrypt- -> IO L8.ByteString -- ^ the result string-cipherLBS c key iv mode input- = do ctx <- cipherInitBS c key iv mode- cipherLazily ctx input-
OpenSSL/EVP/Digest.hsc view
@@ -1,9 +1,5 @@-{- -*- haskell -*- -}-+{-# LANGUAGE ForeignFunctionInterface #-} -- |An interface to message digest algorithms.--#include "HsOpenSSL.h"- module OpenSSL.EVP.Digest ( Digest , getDigestByName@@ -17,17 +13,25 @@ , pkcs5_pbkdf2_hmac_sha1 ) where--import Data.ByteString.Internal (create)-import Data.ByteString.Unsafe (unsafeUseAsCStringLen)+#include "HsOpenSSL.h"+import Data.ByteString.Internal (create)+import Data.ByteString.Unsafe (unsafeUseAsCStringLen) import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Lazy.Char8 as L8-import Control.Applicative ((<$>))-import Foreign hiding (unsafePerformIO)-import System.IO.Unsafe (unsafePerformIO)-import Foreign.C-import OpenSSL.EVP.Internal-import OpenSSL.Objects+import Control.Applicative ((<$>))+import Foreign.C.String (CString, withCString)+#if MIN_VERSION_base(4,5,0)+import Foreign.C.Types (CChar(..), CInt(..), CSize(..), CUInt(..))+#else+import Foreign.C.Types (CChar, CInt, CSize, CUInt)+#endif+import Foreign.Marshal.Alloc (alloca)+import Foreign.Marshal.Array (allocaArray)+import Foreign.Ptr (Ptr, castPtr, nullPtr)+import Foreign.Storable (peek)+import OpenSSL.EVP.Internal+import OpenSSL.Objects+import System.IO.Unsafe (unsafePerformIO) foreign import ccall unsafe "EVP_get_digestbyname" _get_digestbyname :: CString -> IO (Ptr EVP_MD)
OpenSSL/EVP/Internal.hsc view
@@ -1,3 +1,5 @@+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ForeignFunctionInterface #-} module OpenSSL.EVP.Internal ( Cipher(..), EVP_CIPHER,@@ -285,25 +287,25 @@ {- EVP_PKEY ------------------------------------------------------------------ -} --- VaguePKey is a ForeignPtr to EVP_PKEY, that is either public key or--- a ker pair. We can't tell which at compile time.+-- | VaguePKey is a 'ForeignPtr' to 'EVP_PKEY', that is either public+-- key or a ker pair. We can't tell which at compile time. newtype VaguePKey = VaguePKey (ForeignPtr EVP_PKEY) data EVP_PKEY --- Instances of class PKey can be converted back and forth to--- VaguePKey.+-- | Instances of class 'PKey' can be converted back and forth to+-- 'VaguePKey'. class PKey k where- -- Wrap the key (i.g. RSA) into EVP_PKEY.+ -- | Wrap the key (i.g. RSA) into 'EVP_PKEY'. toPKey :: k -> IO VaguePKey - -- Extract the concrete key from the EVP_PKEY. Returns Nothing if- -- the type mismatches.+ -- | Extract the concrete key from the 'EVP_PKEY'. Returns+ -- 'Nothing' if the type mismatches. fromPKey :: VaguePKey -> IO (Maybe k) - -- Do the same as EVP_PKEY_size().+ -- | Do the same as EVP_PKEY_size(). pkeySize :: k -> Int - -- Return the default digesting algorithm for the key.+ -- | Return the default digesting algorithm for the key. pkeyDefaultMD :: k -> IO Digest foreign import ccall unsafe "EVP_PKEY_new"
+ OpenSSL/EVP/Open.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ForeignFunctionInterface #-}+-- |Asymmetric cipher decryption using encrypted symmetric key. This+-- is an opposite of "OpenSSL.EVP.Seal".+module OpenSSL.EVP.Open+ ( open+ , openBS+ , openLBS+ )+ where+import qualified Data.ByteString.Char8 as B8+import qualified Data.ByteString.Lazy.Char8 as L8+import qualified Data.ByteString.Unsafe as B8+import Foreign.C.String (CString)+#if MIN_VERSION_base(4,5,0)+import Foreign.C.Types (CChar(..), CInt(..))+#else+import Foreign.C.Types (CChar, CInt)+#endif+import Foreign.Ptr (Ptr)+import OpenSSL.EVP.Cipher hiding (cipher)+import OpenSSL.EVP.PKey+import OpenSSL.EVP.Internal+import OpenSSL.Utils+import System.IO.Unsafe (unsafePerformIO)++foreign import ccall unsafe "EVP_OpenInit"+ _OpenInit :: Ptr EVP_CIPHER_CTX+ -> Cipher+ -> Ptr CChar+ -> CInt+ -> CString+ -> Ptr EVP_PKEY+ -> IO CInt+++openInit :: KeyPair key =>+ Cipher+ -> B8.ByteString+ -> B8.ByteString+ -> key+ -> IO CipherCtx+openInit cipher encKey iv pkey+ = do ctx <- newCipherCtx+ withCipherCtxPtr ctx $ \ ctxPtr ->+ B8.unsafeUseAsCStringLen encKey $ \ (encKeyPtr, encKeyLen) ->+ B8.unsafeUseAsCString iv $ \ ivPtr ->+ withPKeyPtr' pkey $ \ pkeyPtr ->+ _OpenInit ctxPtr cipher encKeyPtr (fromIntegral 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 :: KeyPair key =>+ Cipher -- ^ symmetric cipher algorithm to use+ -> String -- ^ encrypted symmetric key to decrypt the input string+ -> String -- ^ IV+ -> key -- ^ private key to decrypt the symmetric key+ -> String -- ^ input string to decrypt+ -> String -- ^ decrypted string+{-# DEPRECATED open "Use openBS or openLBS instead." #-}+open cipher encKey iv pkey input+ = L8.unpack $ openLBS cipher (B8.pack encKey) (B8.pack iv) pkey (L8.pack input)++-- |@'openBS'@ decrypts a chunk of data.+openBS :: KeyPair key =>+ Cipher -- ^ symmetric cipher algorithm to use+ -> B8.ByteString -- ^ encrypted symmetric key to decrypt the input string+ -> B8.ByteString -- ^ IV+ -> key -- ^ private key to decrypt the symmetric key+ -> B8.ByteString -- ^ input string to decrypt+ -> B8.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 :: KeyPair key =>+ Cipher -- ^ symmetric cipher algorithm to use+ -> B8.ByteString -- ^ encrypted symmetric key to decrypt the input string+ -> B8.ByteString -- ^ IV+ -> key -- ^ private key to decrypt the symmetric key+ -> L8.ByteString -- ^ input string to decrypt+ -> L8.ByteString -- ^ decrypted string+openLBS cipher encKey iv pkey input+ = unsafePerformIO $+ do ctx <- openInit cipher encKey iv pkey+ cipherLazily ctx input
− OpenSSL/EVP/Open.hsc
@@ -1,89 +0,0 @@-{- -*- haskell -*- -}---- |Asymmetric cipher decryption using encrypted symmetric key. This--- is an opposite of "OpenSSL.EVP.Seal".--module OpenSSL.EVP.Open- ( open- , openBS- , openLBS- )- where--import qualified Data.ByteString.Char8 as B8-import qualified Data.ByteString.Lazy.Char8 as L8-import qualified Data.ByteString.Unsafe as B8-import Foreign hiding (unsafePerformIO)-import System.IO.Unsafe (unsafePerformIO)-import Foreign.C-import OpenSSL.EVP.Cipher hiding (cipher)-import OpenSSL.EVP.PKey-import OpenSSL.EVP.Internal-import OpenSSL.Utils---foreign import ccall unsafe "EVP_OpenInit"- _OpenInit :: Ptr EVP_CIPHER_CTX- -> Cipher- -> Ptr CChar- -> CInt- -> CString- -> Ptr EVP_PKEY- -> IO CInt---openInit :: KeyPair key =>- Cipher- -> B8.ByteString- -> B8.ByteString- -> key- -> IO CipherCtx-openInit cipher encKey iv pkey- = do ctx <- newCipherCtx- withCipherCtxPtr ctx $ \ ctxPtr ->- B8.unsafeUseAsCStringLen encKey $ \ (encKeyPtr, encKeyLen) ->- B8.unsafeUseAsCString iv $ \ ivPtr ->- withPKeyPtr' pkey $ \ pkeyPtr ->- _OpenInit ctxPtr cipher encKeyPtr (fromIntegral 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 :: KeyPair key =>- Cipher -- ^ symmetric cipher algorithm to use- -> String -- ^ encrypted symmetric key to decrypt the input string- -> String -- ^ IV- -> key -- ^ private key to decrypt the symmetric key- -> String -- ^ input string to decrypt- -> String -- ^ decrypted string-{-# DEPRECATED open "Use openBS or openLBS instead." #-}-open cipher encKey iv pkey input- = L8.unpack $ openLBS cipher (B8.pack encKey) (B8.pack iv) pkey (L8.pack input)---- |@'openBS'@ decrypts a chunk of data.-openBS :: KeyPair key =>- Cipher -- ^ symmetric cipher algorithm to use- -> B8.ByteString -- ^ encrypted symmetric key to decrypt the input string- -> B8.ByteString -- ^ IV- -> key -- ^ private key to decrypt the symmetric key- -> B8.ByteString -- ^ input string to decrypt- -> B8.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 :: KeyPair key =>- Cipher -- ^ symmetric cipher algorithm to use- -> B8.ByteString -- ^ encrypted symmetric key to decrypt the input string- -> B8.ByteString -- ^ IV- -> key -- ^ private key to decrypt the symmetric key- -> L8.ByteString -- ^ input string to decrypt- -> L8.ByteString -- ^ decrypted string-openLBS cipher encKey iv pkey input- = unsafePerformIO $- do ctx <- openInit cipher encKey iv pkey- cipherLazily ctx input
OpenSSL/EVP/PKey.hsc view
@@ -1,19 +1,17 @@-{- -*- haskell -*- -}--{-# OPTIONS_GHC -fno-warn-orphans #-}-+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE Rank2Types #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} -- |An interface to asymmetric cipher keypair.--#include "HsOpenSSL.h"- module OpenSSL.EVP.PKey- ( PKey- , PublicKey(..)+ ( PublicKey(..) , KeyPair(..) , SomePublicKey , SomeKeyPair ) where+#include "HsOpenSSL.h" import Data.Typeable import Data.Maybe import Foreign@@ -57,13 +55,13 @@ = withPKeyPtr pk $ \ pkeyPtr -> do pkeyType <- (#peek EVP_PKEY, type) pkeyPtr :: IO CInt case pkeyType of-#ifndef OPENSSL_NO_RSA+#if !defined(OPENSSL_NO_RSA) (#const EVP_PKEY_RSA) -> do rsaPtr <- _get1_RSA pkeyPtr Just rsa <- absorbRSAPtr rsaPtr f (rsa :: RSAPubKey) #endif-#ifndef OPENSSL_NO_DSA+#if !defined(OPENSSL_NO_DSA) (#const EVP_PKEY_DSA) -> do dsaPtr <- _get1_DSA pkeyPtr Just dsa <- absorbDSAPtr dsaPtr@@ -77,13 +75,13 @@ = withPKeyPtr pk $ \ pkeyPtr -> do pkeyType <- (#peek EVP_PKEY, type) pkeyPtr :: IO CInt case pkeyType of-#ifndef OPENSSL_NO_RSA+#if !defined(OPENSSL_NO_RSA) (#const EVP_PKEY_RSA) -> do rsaPtr <- _get1_RSA pkeyPtr Just rsa <- absorbRSAPtr rsaPtr f (rsa :: RSAKeyPair) #endif-#ifndef OPENSSL_NO_DSA+#if !defined(OPENSSL_NO_DSA) (#const EVP_PKEY_DSA) -> do dsaPtr <- _get1_DSA pkeyPtr Just dsa <- absorbDSAPtr dsaPtr@@ -146,7 +144,7 @@ = withConcreteKeyPair pk (return . Just . SomeKeyPair) -#ifndef OPENSSL_NO_RSA+#if !defined(OPENSSL_NO_RSA) -- The resulting Ptr RSA must be freed by caller. foreign import ccall unsafe "EVP_PKEY_get1_RSA" _get1_RSA :: Ptr EVP_PKEY -> IO (Ptr RSA)@@ -187,7 +185,7 @@ #endif -#ifndef OPENSSL_NO_DSA+#if !defined(OPENSSL_NO_DSA) foreign import ccall unsafe "EVP_PKEY_get1_DSA" _get1_DSA :: Ptr EVP_PKEY -> IO (Ptr DSA)
+ OpenSSL/EVP/Seal.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE ForeignFunctionInterface #-}+-- |Asymmetric cipher decryption using encrypted symmetric key. This+-- is an opposite of "OpenSSL.EVP.Open".+module OpenSSL.EVP.Seal+ ( seal+ , sealBS+ , sealLBS+ )+ where+import qualified Data.ByteString.Char8 as B8+import qualified Data.ByteString.Lazy.Char8 as L8+import Foreign+import Foreign.C+import OpenSSL.EVP.Cipher hiding (cipher)+import OpenSSL.EVP.PKey+import OpenSSL.EVP.Internal+import OpenSSL.Utils+++foreign import ccall unsafe "EVP_SealInit"+ _SealInit :: Ptr EVP_CIPHER_CTX+ -> Cipher+ -> Ptr (Ptr CChar)+ -> Ptr CInt+ -> CString+ -> Ptr (Ptr EVP_PKEY)+ -> CInt+ -> IO CInt+++sealInit :: Cipher+ -> [SomePublicKey]+ -> IO (CipherCtx, [B8.ByteString], B8.ByteString)++sealInit _ []+ = fail "sealInit: at least one public key is required"++sealInit cipher pubKeys+ = do ctx <- newCipherCtx++ -- Allocate a list of buffers to write encrypted symmetric+ -- keys. Each keys will be at most pkeySize bytes long.+ encKeyBufs <- mapM mallocEncKeyBuf pubKeys++ -- encKeyBufs is [Ptr a] but we want Ptr (Ptr CChar).+ encKeyBufsPtr <- newArray encKeyBufs++ -- Allocate a buffer to write lengths of each encrypted+ -- symmetric keys.+ encKeyBufsLenPtr <- mallocArray nKeys++ -- Allocate a buffer to write IV.+ ivPtr <- mallocArray (cipherIvLength cipher)++ -- Create Ptr (Ptr EVP_PKEY) from [PKey]. Don't forget to+ -- apply touchForeignPtr to each PKey's later.+ pkeys <- mapM toPKey pubKeys+ pubKeysPtr <- newArray $ map unsafePKeyToPtr pkeys++ -- Prepare an IO action to free buffers we allocated above.+ let cleanup = do mapM_ free encKeyBufs+ free encKeyBufsPtr+ free encKeyBufsLenPtr+ free ivPtr+ free pubKeysPtr+ mapM_ touchPKey pkeys++ -- Call EVP_SealInit finally.+ ret <- withCipherCtxPtr ctx $ \ ctxPtr ->+ _SealInit ctxPtr cipher encKeyBufsPtr encKeyBufsLenPtr ivPtr pubKeysPtr (fromIntegral nKeys)++ if ret == 0 then+ cleanup >> raiseOpenSSLError+ else+ do encKeysLen <- peekArray nKeys encKeyBufsLenPtr+ encKeys <- mapM B8.packCStringLen $ zip encKeyBufs (fromIntegral `fmap` encKeysLen)+ iv <- B8.packCStringLen (ivPtr, cipherIvLength cipher)+ cleanup+ return (ctx, encKeys, iv)+ where+ nKeys :: Int+ nKeys = length pubKeys++ mallocEncKeyBuf :: (PKey k, Storable a) => k -> IO (Ptr a)+ mallocEncKeyBuf = mallocArray . pkeySize++-- |@'seal'@ lazilly encrypts a stream of data. The input string+-- doesn't necessarily have to be finite.+seal :: Cipher -- ^ symmetric cipher algorithm to use+ -> [SomePublicKey] -- ^ 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)+{-# DEPRECATED seal "Use sealBS or sealLBS instead." #-}+seal cipher pubKeys input+ = do (output, encKeys, iv) <- sealLBS cipher pubKeys $ L8.pack input+ return ( L8.unpack output+ , B8.unpack `fmap` encKeys+ , B8.unpack iv+ )++-- |@'sealBS'@ strictly encrypts a chunk of data.+sealBS :: Cipher -- ^ symmetric cipher algorithm to use+ -> [SomePublicKey] -- ^ list of public keys to encrypt a+ -- symmetric key+ -> B8.ByteString -- ^ input string to encrypt+ -> IO ( B8.ByteString+ , [B8.ByteString]+ , B8.ByteString+ ) -- ^ (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+ -> [SomePublicKey] -- ^ list of public keys to encrypt a+ -- symmetric key+ -> L8.ByteString -- ^ input string to encrypt+ -> IO ( L8.ByteString+ , [B8.ByteString]+ , B8.ByteString+ ) -- ^ (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
@@ -1,143 +0,0 @@-{- -*- haskell -*- -}---- |Asymmetric cipher decryption using encrypted symmetric key. This--- is an opposite of "OpenSSL.EVP.Open".--module OpenSSL.EVP.Seal- ( seal- , sealBS- , sealLBS- )- where--import qualified Data.ByteString.Char8 as B8-import qualified Data.ByteString.Lazy.Char8 as L8-import Foreign-import Foreign.C-import OpenSSL.EVP.Cipher hiding (cipher)-import OpenSSL.EVP.PKey-import OpenSSL.EVP.Internal-import OpenSSL.Utils---foreign import ccall unsafe "EVP_SealInit"- _SealInit :: Ptr EVP_CIPHER_CTX- -> Cipher- -> Ptr (Ptr CChar)- -> Ptr CInt- -> CString- -> Ptr (Ptr EVP_PKEY)- -> CInt- -> IO CInt---sealInit :: Cipher- -> [SomePublicKey]- -> IO (CipherCtx, [B8.ByteString], B8.ByteString)--sealInit _ []- = fail "sealInit: at least one public key is required"--sealInit cipher pubKeys- = do ctx <- newCipherCtx-- -- Allocate a list of buffers to write encrypted symmetric- -- keys. Each keys will be at most pkeySize bytes long.- encKeyBufs <- mapM mallocEncKeyBuf pubKeys-- -- encKeyBufs is [Ptr a] but we want Ptr (Ptr CChar).- encKeyBufsPtr <- newArray encKeyBufs-- -- Allocate a buffer to write lengths of each encrypted- -- symmetric keys.- encKeyBufsLenPtr <- mallocArray nKeys-- -- Allocate a buffer to write IV.- ivPtr <- mallocArray (cipherIvLength cipher)-- -- Create Ptr (Ptr EVP_PKEY) from [PKey]. Don't forget to- -- apply touchForeignPtr to each PKey's later.- pkeys <- mapM toPKey pubKeys- pubKeysPtr <- newArray $ map unsafePKeyToPtr pkeys-- -- Prepare an IO action to free buffers we allocated above.- let cleanup = do mapM_ free encKeyBufs- free encKeyBufsPtr- free encKeyBufsLenPtr- free ivPtr- free pubKeysPtr- mapM_ touchPKey pkeys-- -- Call EVP_SealInit finally.- ret <- withCipherCtxPtr ctx $ \ ctxPtr ->- _SealInit ctxPtr cipher encKeyBufsPtr encKeyBufsLenPtr ivPtr pubKeysPtr (fromIntegral nKeys)-- if ret == 0 then- cleanup >> raiseOpenSSLError- else- do encKeysLen <- peekArray nKeys encKeyBufsLenPtr- encKeys <- mapM B8.packCStringLen $ zip encKeyBufs (fromIntegral `fmap` encKeysLen)- iv <- B8.packCStringLen (ivPtr, cipherIvLength cipher)- cleanup- return (ctx, encKeys, iv)- where- nKeys :: Int- nKeys = length pubKeys-- mallocEncKeyBuf :: (PKey k, Storable a) => k -> IO (Ptr a)- mallocEncKeyBuf = mallocArray . pkeySize---- |@'seal'@ lazilly encrypts a stream of data. The input string--- doesn't necessarily have to be finite.-seal :: Cipher -- ^ symmetric cipher algorithm to use- -> [SomePublicKey] -- ^ 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)-{-# DEPRECATED seal "Use sealBS or sealLBS instead." #-}-seal cipher pubKeys input- = do (output, encKeys, iv) <- sealLBS cipher pubKeys $ L8.pack input- return ( L8.unpack output- , B8.unpack `fmap` encKeys- , B8.unpack iv- )---- |@'sealBS'@ strictly encrypts a chunk of data.-sealBS :: Cipher -- ^ symmetric cipher algorithm to use- -> [SomePublicKey] -- ^ list of public keys to encrypt a- -- symmetric key- -> B8.ByteString -- ^ input string to encrypt- -> IO ( B8.ByteString- , [B8.ByteString]- , B8.ByteString- ) -- ^ (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- -> [SomePublicKey] -- ^ list of public keys to encrypt a- -- symmetric key- -> L8.ByteString -- ^ input string to encrypt- -> IO ( L8.ByteString- , [B8.ByteString]- , B8.ByteString- ) -- ^ (encrypted string, list of encrypted asymmetric- -- keys, IV)-sealLBS cipher pubKeys input- = do (ctx, encKeys, iv) <- sealInit cipher pubKeys- output <- cipherLazily ctx input- return (output, encKeys, iv)
+ OpenSSL/EVP/Sign.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE ForeignFunctionInterface #-}+-- |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 qualified Data.ByteString.Char8 as B8+import qualified Data.ByteString.Internal as B8+import qualified Data.ByteString.Lazy.Char8 as L8+import Control.Applicative ((<$>))+import Foreign+import Foreign.C+import OpenSSL.EVP.Digest+import OpenSSL.EVP.PKey+import OpenSSL.EVP.Internal+import OpenSSL.Utils++foreign import ccall unsafe "EVP_SignFinal"+ _SignFinal :: Ptr EVP_MD_CTX -> Ptr Word8 -> Ptr CUInt+ -> Ptr EVP_PKEY -> IO CInt++signFinal :: KeyPair k => DigestCtx -> k -> IO B8.ByteString+signFinal ctx k = do+ let maxLen = pkeySize k+ withDigestCtxPtr ctx $ \ ctxPtr ->+ withPKeyPtr' k $ \ pkeyPtr ->+ B8.createAndTrim maxLen $ \ bufPtr ->+ alloca $ \ bufLenPtr -> do+ failIf_ (/= 1) =<< _SignFinal ctxPtr bufPtr bufLenPtr pkeyPtr+ fromIntegral <$> peek bufLenPtr++-- |@'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 :: KeyPair key =>+ Digest -- ^ message digest algorithm to use+ -> key -- ^ private key to sign the message digest+ -> String -- ^ input string+ -> IO String -- ^ the result signature+{-# DEPRECATED sign "Use signBS or signLBS instead." #-}+sign md pkey input+ = fmap L8.unpack $ signLBS md pkey $ L8.pack input++-- |@'signBS'@ generates a signature from a chunk of data.+signBS :: KeyPair key =>+ Digest -- ^ message digest algorithm to use+ -> key -- ^ private key to sign the message digest+ -> B8.ByteString -- ^ input string+ -> IO B8.ByteString -- ^ 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 :: KeyPair key =>+ Digest -- ^ message digest algorithm to use+ -> key -- ^ private key to sign the message digest+ -> L8.ByteString -- ^ input string+ -> IO L8.ByteString -- ^ the result signature+signLBS md pkey input+ = do ctx <- digestLazily md input+ sig <- signFinal ctx pkey+ return $ L8.fromChunks [sig]+
− OpenSSL/EVP/Sign.hsc
@@ -1,70 +0,0 @@-{- -*- haskell -*- -}---- |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 qualified Data.ByteString.Char8 as B8-import qualified Data.ByteString.Internal as B8-import qualified Data.ByteString.Lazy.Char8 as L8-import Control.Applicative ((<$>))-import Foreign-import Foreign.C-import OpenSSL.EVP.Digest-import OpenSSL.EVP.PKey-import OpenSSL.EVP.Internal-import OpenSSL.Utils--foreign import ccall unsafe "EVP_SignFinal"- _SignFinal :: Ptr EVP_MD_CTX -> Ptr Word8 -> Ptr CUInt- -> Ptr EVP_PKEY -> IO CInt--signFinal :: KeyPair k => DigestCtx -> k -> IO B8.ByteString-signFinal ctx k = do- let maxLen = pkeySize k- withDigestCtxPtr ctx $ \ ctxPtr ->- withPKeyPtr' k $ \ pkeyPtr ->- B8.createAndTrim maxLen $ \ bufPtr ->- alloca $ \ bufLenPtr -> do- failIf_ (/= 1) =<< _SignFinal ctxPtr bufPtr bufLenPtr pkeyPtr- fromIntegral <$> peek bufLenPtr---- |@'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 :: KeyPair key =>- Digest -- ^ message digest algorithm to use- -> key -- ^ private key to sign the message digest- -> String -- ^ input string- -> IO String -- ^ the result signature-{-# DEPRECATED sign "Use signBS or signLBS instead." #-}-sign md pkey input- = fmap L8.unpack $ signLBS md pkey $ L8.pack input---- |@'signBS'@ generates a signature from a chunk of data.-signBS :: KeyPair key =>- Digest -- ^ message digest algorithm to use- -> key -- ^ private key to sign the message digest- -> B8.ByteString -- ^ input string- -> IO B8.ByteString -- ^ 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 :: KeyPair key =>- Digest -- ^ message digest algorithm to use- -> key -- ^ private key to sign the message digest- -> L8.ByteString -- ^ input string- -> IO L8.ByteString -- ^ the result signature-signLBS md pkey input- = do ctx <- digestLazily md input- sig <- signFinal ctx pkey- return $ L8.fromChunks [sig]-
+ OpenSSL/EVP/Verify.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ForeignFunctionInterface #-}+-- |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 qualified Data.ByteString.Char8 as B8+import qualified Data.ByteString.Lazy.Char8 as L8+import qualified Data.ByteString.Unsafe as B8+import Data.Typeable+import Foreign+import Foreign.C+import OpenSSL.EVP.Digest+import OpenSSL.EVP.PKey+import OpenSSL.EVP.Internal+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 CInt+++verifyFinalBS :: PublicKey k =>+ DigestCtx+ -> B8.ByteString+ -> k+ -> IO VerifyStatus+verifyFinalBS ctx sig k+ = withDigestCtxPtr ctx $ \ ctxPtr ->+ B8.unsafeUseAsCStringLen sig $ \ (buf, len) ->+ withPKeyPtr' k $ \ pkeyPtr ->+ _VerifyFinal ctxPtr buf (fromIntegral len) pkeyPtr >>= interpret+ where+ interpret :: CInt -> 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 :: PublicKey key =>+ Digest -- ^ message digest algorithm to use+ -> String -- ^ message signature+ -> key -- ^ public key to verify the signature+ -> String -- ^ input string to verify+ -> IO VerifyStatus -- ^ the result of verification+{-# DEPRECATED verify "Use verifyBS or verifyLBS instead." #-}+verify md sig pkey input+ = verifyLBS md (B8.pack sig) pkey (L8.pack input)++-- |@'verifyBS'@ verifies a signature and a chunk of data.+verifyBS :: PublicKey key =>+ Digest -- ^ message digest algorithm to use+ -> B8.ByteString -- ^ message signature+ -> key -- ^ public key to verify the signature+ -> B8.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 :: PublicKey key =>+ Digest -- ^ message digest algorithm to use+ -> B8.ByteString -- ^ message signature+ -> key -- ^ public key to verify the signature+ -> L8.ByteString -- ^ 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
@@ -1,84 +0,0 @@-{- -*- haskell -*- -}---- |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 qualified Data.ByteString.Char8 as B8-import qualified Data.ByteString.Lazy.Char8 as L8-import qualified Data.ByteString.Unsafe as B8-import Data.Typeable-import Foreign-import Foreign.C-import OpenSSL.EVP.Digest-import OpenSSL.EVP.PKey-import OpenSSL.EVP.Internal-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 CInt---verifyFinalBS :: PublicKey k =>- DigestCtx- -> B8.ByteString- -> k- -> IO VerifyStatus-verifyFinalBS ctx sig k- = withDigestCtxPtr ctx $ \ ctxPtr ->- B8.unsafeUseAsCStringLen sig $ \ (buf, len) ->- withPKeyPtr' k $ \ pkeyPtr ->- _VerifyFinal ctxPtr buf (fromIntegral len) pkeyPtr >>= interpret- where- interpret :: CInt -> 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 :: PublicKey key =>- Digest -- ^ message digest algorithm to use- -> String -- ^ message signature- -> key -- ^ public key to verify the signature- -> String -- ^ input string to verify- -> IO VerifyStatus -- ^ the result of verification-{-# DEPRECATED verify "Use verifyBS or verifyLBS instead." #-}-verify md sig pkey input- = verifyLBS md (B8.pack sig) pkey (L8.pack input)---- |@'verifyBS'@ verifies a signature and a chunk of data.-verifyBS :: PublicKey key =>- Digest -- ^ message digest algorithm to use- -> B8.ByteString -- ^ message signature- -> key -- ^ public key to verify the signature- -> B8.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 :: PublicKey key =>- Digest -- ^ message digest algorithm to use- -> B8.ByteString -- ^ message signature- -> key -- ^ public key to verify the signature- -> L8.ByteString -- ^ input string to verify- -> IO VerifyStatus -- ^ the result of verification-verifyLBS md sig pkey input- = do ctx <- digestLazily md input- verifyFinalBS ctx sig pkey
OpenSSL/Objects.hsc view
@@ -1,11 +1,11 @@-#include "HsOpenSSL.h"-+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ForeignFunctionInterface #-} module OpenSSL.Objects ( ObjNameType(..) , getObjNames ) where-+#include "HsOpenSSL.h" import Data.IORef import Foreign import Foreign.C
+ OpenSSL/PEM.hs view
@@ -0,0 +1,521 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ForeignFunctionInterface #-}+-- |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++ -- * DH parameters+ , writeDHParams+ , readDHParams+ )+ where+import Control.Exception hiding (try)+import Control.Monad+import qualified Data.ByteString.Char8 as B8+import Data.Maybe+import Foreign+import Foreign.C+import OpenSSL.BIO+import OpenSSL.EVP.Cipher hiding (cipher)+import OpenSSL.EVP.PKey+import OpenSSL.EVP.Internal+import OpenSSL.DH.Internal+import OpenSSL.PKCS7+import OpenSSL.Utils+import OpenSSL.X509+import OpenSSL.X509.Request+import OpenSSL.X509.Revocation+#if !MIN_VERSION_base(4,6,0)+import Prelude hiding (catch)+#endif+import System.IO+++-- |@'PemPasswordCallback'@ represents a callback function to supply a+-- password.+--+-- [@Int@] The maximum length of the password to be accepted.+--+-- [@PemPasswordRWState@] The context.+--+-- [@IO String@] The resulting password.+--+type PemPasswordCallback = Int -> PemPasswordRWState -> IO String+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+ | PwBS B8.ByteString -- ^ password in a static bytestring.+ | 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+rwflagToState _ = undefined+++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 :: SomeException))+ 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+ -> CInt+ -> FunPtr PemPasswordCallback'+ -> Ptr a+ -> IO CInt++writePKCS8PrivateKey' :: KeyPair key =>+ BIO+ -> key+ -> Maybe (Cipher, PemPasswordSupply)+ -> IO ()+writePKCS8PrivateKey' bio key encryption+ = withBioPtr bio $ \ bioPtr ->+ withPKeyPtr' key $ \ 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 (fromIntegral passLen) nullFunPtr nullPtr+ Just (cipher, PwBS passStr)+ -> withBS passStr $ \(passPtr, passLen) ->+ withCipherPtr cipher $ \ cipherPtr ->+ _write_bio_PKCS8PrivateKey bioPtr pkeyPtr cipherPtr passPtr (fromIntegral passLen) nullFunPtr nullPtr+ Just (cipher, PwCallback cb)+ -> withCipherPtr cipher $ \ cipherPtr ->+ bracket (mkPemPasswordCallback $ callPasswordCB cb) freeHaskellFunPtr $ \cbPtr ->+ _write_bio_PKCS8PrivateKey bioPtr pkeyPtr cipherPtr nullPtr 0 cbPtr nullPtr+ + Just (cipher, PwTTY)+ -> withCipherPtr cipher $ \ cipherPtr ->+ _write_bio_PKCS8PrivateKey bioPtr pkeyPtr cipherPtr nullPtr 0 nullFunPtr nullPtr+ failIf_ (/= 1) ret++-- |@'writePKCS8PrivateKey'@ writes a private key to PEM string in+-- PKCS#8 format.+writePKCS8PrivateKey+ :: KeyPair key =>+ key -- ^ 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'+ -> CString+ -> IO (Ptr EVP_PKEY)++readPrivateKey' :: BIO -> PemPasswordSupply -> IO SomeKeyPair+readPrivateKey' bio supply+ = withBioPtr bio $ \ bioPtr ->+ do pkeyPtr <- case supply of+ PwNone+ -> withCString "" $ \ strPtr ->+ _read_bio_PrivateKey bioPtr nullPtr nullFunPtr (castPtr strPtr)+ PwStr passStr+ -> withCString passStr $+ _read_bio_PrivateKey bioPtr nullPtr nullFunPtr+ PwBS passStr+ -> withBS passStr $ \(passPtr,_) ->+ _read_bio_PrivateKey bioPtr nullPtr nullFunPtr passPtr+ PwCallback cb+ -> bracket (mkPemPasswordCallback $ callPasswordCB cb) freeHaskellFunPtr $ \cbPtr ->+ _read_bio_PrivateKey bioPtr nullPtr cbPtr nullPtr+ PwTTY+ -> _read_bio_PrivateKey bioPtr nullPtr nullFunPtr nullPtr + failIfNull_ pkeyPtr+ fmap fromJust (wrapPKeyPtr pkeyPtr >>= fromPKey)++-- |@'readPrivateKey' pem supply@ reads a private key in PEM string.+readPrivateKey :: String -> PemPasswordSupply -> IO SomeKeyPair+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 CInt++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' :: PublicKey key => BIO -> key -> IO ()+writePublicKey' bio key+ = withBioPtr bio $ \ bioPtr ->+ withPKeyPtr' key $ \ pkeyPtr ->+ _write_bio_PUBKEY bioPtr pkeyPtr >>= failIf (/= 1) >> return ()++-- |@'writePublicKey' pubkey@ writes a public to PEM string.+writePublicKey :: PublicKey key => key -> 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 SomePublicKey+readPublicKey' bio+ = withBioPtr bio $ \ bioPtr ->+ withCString "" $ \ passPtr ->+ fmap fromJust+ ( _read_bio_PUBKEY bioPtr nullPtr nullFunPtr (castPtr passPtr)+ >>= failIfNull+ >>= wrapPKeyPtr+ >>= fromPKey+ )++-- |@'readPublicKey' pem@ reads a public key in PEM string.+readPublicKey :: String -> IO SomePublicKey+readPublicKey pemStr+ = newConstMem pemStr >>= readPublicKey'+++{- X.509 certificate --------------------------------------------------------- -}++foreign import ccall unsafe "PEM_write_bio_X509"+ _write_bio_X509 :: Ptr BIO_+ -> Ptr X509_+ -> IO CInt++foreign import ccall safe "PEM_read_bio_X509"+ _read_bio_X509 :: 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 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 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 CInt++foreign import ccall unsafe "PEM_write_bio_X509_REQ_NEW"+ _write_bio_X509_REQ_NEW :: Ptr BIO_+ -> Ptr X509_REQ+ -> IO CInt++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 CInt++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 CInt++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'++{- DH parameters ------------------------------------------------------------- -}++foreign import ccall unsafe "PEM_write_bio_DHparams"+ _write_bio_DH :: Ptr BIO_+ -> Ptr DH_+ -> IO CInt++foreign import ccall safe "PEM_read_bio_DHparams"+ _read_bio_DH :: Ptr BIO_+ -> Ptr (Ptr DH_)+ -> FunPtr PemPasswordCallback'+ -> Ptr ()+ -> IO (Ptr DH_)++writeDHParams' :: BIO -> DHP -> IO ()+writeDHParams' bio dh+ = withBioPtr bio $ \ bioPtr ->+ withDHPPtr dh $ \ dhPtr ->+ _write_bio_DH bioPtr dhPtr >>= failIf_ (/= 1)++-- |@'writeDHParams' dh@ writes DH parameters to PEM string.+writeDHParams :: DHP -> IO String+writeDHParams dh+ = do mem <- newMem+ writeDHParams' mem dh+ bioRead mem++readDHParams' :: BIO -> IO DHP+readDHParams' bio+ = withBioPtr bio $ \ bioPtr ->+ withCString "" $ \ passPtr ->+ _read_bio_DH bioPtr nullPtr nullFunPtr (castPtr passPtr)+ >>= failIfNull+ >>= wrapDHPPtr++-- |@'readDHParams' pem@ reads DH parameters in PEM string.+readDHParams :: String -> IO DHP+readDHParams pemStr+ = newConstMem pemStr >>= readDHParams'+++withBS :: B8.ByteString -> ((Ptr CChar, Int) -> IO t) -> IO t+withBS passStr act =+ B8.useAsCStringLen passStr $ \ (passPtr, passLen) ->+ flip finally (memset passPtr 0 $ fromIntegral passLen) $+ act (castPtr passPtr, passLen)++foreign import ccall unsafe memset :: Ptr a -> CInt -> CSize -> IO ()
− OpenSSL/PEM.hsc
@@ -1,523 +0,0 @@-{- -*- haskell -*- -}---- |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-- -- * DH parameters- , writeDHParams- , readDHParams- )- where--import Control.Exception hiding (try)-import Control.Monad-import qualified Data.ByteString.Char8 as B8-import Data.Maybe-import Foreign-import Foreign.C-import OpenSSL.BIO-import OpenSSL.EVP.Cipher hiding (cipher)-import OpenSSL.EVP.PKey-import OpenSSL.EVP.Internal-import OpenSSL.DH.Internal-import OpenSSL.PKCS7-import OpenSSL.Utils-import OpenSSL.X509-import OpenSSL.X509.Request-import OpenSSL.X509.Revocation-#if !MIN_VERSION_base(4,6,0)-import Prelude hiding (catch)-#endif-import System.IO----- |@'PemPasswordCallback'@ represents a callback function to supply a--- password.------ [@Int@] The maximum length of the password to be accepted.------ [@PemPasswordRWState@] The context.------ [@IO String@] The resulting password.----type PemPasswordCallback = Int -> PemPasswordRWState -> IO String-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- | PwBS B8.ByteString -- ^ password in a static bytestring.- | 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-rwflagToState _ = undefined---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 :: SomeException))- 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- -> CInt- -> FunPtr PemPasswordCallback'- -> Ptr a- -> IO CInt--writePKCS8PrivateKey' :: KeyPair key =>- BIO- -> key- -> Maybe (Cipher, PemPasswordSupply)- -> IO ()-writePKCS8PrivateKey' bio key encryption- = withBioPtr bio $ \ bioPtr ->- withPKeyPtr' key $ \ 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 (fromIntegral passLen) nullFunPtr nullPtr- Just (cipher, PwBS passStr)- -> withBS passStr $ \(passPtr, passLen) ->- withCipherPtr cipher $ \ cipherPtr ->- _write_bio_PKCS8PrivateKey bioPtr pkeyPtr cipherPtr passPtr (fromIntegral passLen) nullFunPtr nullPtr- Just (cipher, PwCallback cb)- -> withCipherPtr cipher $ \ cipherPtr ->- bracket (mkPemPasswordCallback $ callPasswordCB cb) freeHaskellFunPtr $ \cbPtr ->- _write_bio_PKCS8PrivateKey bioPtr pkeyPtr cipherPtr nullPtr 0 cbPtr nullPtr- - Just (cipher, PwTTY)- -> withCipherPtr cipher $ \ cipherPtr ->- _write_bio_PKCS8PrivateKey bioPtr pkeyPtr cipherPtr nullPtr 0 nullFunPtr nullPtr- failIf_ (/= 1) ret---- |@'writePKCS8PrivateKey'@ writes a private key to PEM string in--- PKCS#8 format.-writePKCS8PrivateKey- :: KeyPair key =>- key -- ^ 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'- -> CString- -> IO (Ptr EVP_PKEY)--readPrivateKey' :: BIO -> PemPasswordSupply -> IO SomeKeyPair-readPrivateKey' bio supply- = withBioPtr bio $ \ bioPtr ->- do pkeyPtr <- case supply of- PwNone- -> withCString "" $ \ strPtr ->- _read_bio_PrivateKey bioPtr nullPtr nullFunPtr (castPtr strPtr)- PwStr passStr- -> withCString passStr $- _read_bio_PrivateKey bioPtr nullPtr nullFunPtr- PwBS passStr- -> withBS passStr $ \(passPtr,_) ->- _read_bio_PrivateKey bioPtr nullPtr nullFunPtr passPtr- PwCallback cb- -> bracket (mkPemPasswordCallback $ callPasswordCB cb) freeHaskellFunPtr $ \cbPtr ->- _read_bio_PrivateKey bioPtr nullPtr cbPtr nullPtr- PwTTY- -> _read_bio_PrivateKey bioPtr nullPtr nullFunPtr nullPtr - failIfNull_ pkeyPtr- fmap fromJust (wrapPKeyPtr pkeyPtr >>= fromPKey)---- |@'readPrivateKey' pem supply@ reads a private key in PEM string.-readPrivateKey :: String -> PemPasswordSupply -> IO SomeKeyPair-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 CInt--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' :: PublicKey key => BIO -> key -> IO ()-writePublicKey' bio key- = withBioPtr bio $ \ bioPtr ->- withPKeyPtr' key $ \ pkeyPtr ->- _write_bio_PUBKEY bioPtr pkeyPtr >>= failIf (/= 1) >> return ()---- |@'writePublicKey' pubkey@ writes a public to PEM string.-writePublicKey :: PublicKey key => key -> 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 SomePublicKey-readPublicKey' bio- = withBioPtr bio $ \ bioPtr ->- withCString "" $ \ passPtr ->- fmap fromJust- ( _read_bio_PUBKEY bioPtr nullPtr nullFunPtr (castPtr passPtr)- >>= failIfNull- >>= wrapPKeyPtr- >>= fromPKey- )---- |@'readPublicKey' pem@ reads a public key in PEM string.-readPublicKey :: String -> IO SomePublicKey-readPublicKey pemStr- = newConstMem pemStr >>= readPublicKey'---{- X.509 certificate --------------------------------------------------------- -}--foreign import ccall unsafe "PEM_write_bio_X509"- _write_bio_X509 :: Ptr BIO_- -> Ptr X509_- -> IO CInt--foreign import ccall safe "PEM_read_bio_X509"- _read_bio_X509 :: 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 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 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 CInt--foreign import ccall unsafe "PEM_write_bio_X509_REQ_NEW"- _write_bio_X509_REQ_NEW :: Ptr BIO_- -> Ptr X509_REQ- -> IO CInt--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 CInt--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 CInt--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'--{- DH parameters ------------------------------------------------------------- -}--foreign import ccall unsafe "PEM_write_bio_DHparams"- _write_bio_DH :: Ptr BIO_- -> Ptr DH_- -> IO CInt--foreign import ccall safe "PEM_read_bio_DHparams"- _read_bio_DH :: Ptr BIO_- -> Ptr (Ptr DH_)- -> FunPtr PemPasswordCallback'- -> Ptr ()- -> IO (Ptr DH_)--writeDHParams' :: BIO -> DHP -> IO ()-writeDHParams' bio dh- = withBioPtr bio $ \ bioPtr ->- withDHPPtr dh $ \ dhPtr ->- _write_bio_DH bioPtr dhPtr >>= failIf_ (/= 1)---- |@'writeDHParams' dh@ writes DH parameters to PEM string.-writeDHParams :: DHP -> IO String-writeDHParams dh- = do mem <- newMem- writeDHParams' mem dh- bioRead mem--readDHParams' :: BIO -> IO DHP-readDHParams' bio- = withBioPtr bio $ \ bioPtr ->- withCString "" $ \ passPtr ->- _read_bio_DH bioPtr nullPtr nullFunPtr (castPtr passPtr)- >>= failIfNull- >>= wrapDHPPtr---- |@'readDHParams' pem@ reads DH parameters in PEM string.-readDHParams :: String -> IO DHP-readDHParams pemStr- = newConstMem pemStr >>= readDHParams'---withBS :: B8.ByteString -> ((Ptr CChar, Int) -> IO t) -> IO t-withBS passStr act =- B8.useAsCStringLen passStr $ \ (passPtr, passLen) ->- flip finally (memset passPtr 0 $ fromIntegral passLen) $- act (castPtr passPtr, passLen)--foreign import ccall unsafe memset :: Ptr a -> CInt -> CSize -> IO ()
OpenSSL/PKCS7.hsc view
@@ -1,11 +1,8 @@-{- -*- haskell -*- -}---- #prune-+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# OPTIONS_HADDOCK prune #-} -- |An interface to PKCS#7 structure and S\/MIME message.--#include "HsOpenSSL.h"- module OpenSSL.PKCS7 ( -- * Types Pkcs7@@ -26,7 +23,7 @@ , readSmime ) where-+#include "HsOpenSSL.h" import Data.List import Data.Traversable import Data.Typeable
OpenSSL/RSA.hsc view
@@ -1,11 +1,8 @@-{- -*- haskell -*- -}--{-# OPTIONS_HADDOCK prune #-}-+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# OPTIONS_HADDOCK prune #-} -- |An interface to RSA public key generator.--#include "HsOpenSSL.h"- module OpenSSL.RSA ( -- * Type RSAKey(..)@@ -29,14 +26,20 @@ , rsaKeyPairFinalize -- private ) where--import Control.Monad-import Data.Typeable-import Foreign hiding (unsafePerformIO)-import System.IO.Unsafe (unsafePerformIO)-import Foreign.C-import OpenSSL.BN-import OpenSSL.Utils+#include "HsOpenSSL.h"+import Control.Monad+import Data.Typeable+#if MIN_VERSION_base(4,5,0)+import Foreign.C.Types (CInt(..))+#else+import Foreign.C.Types (CInt)+#endif+import Foreign.ForeignPtr (ForeignPtr, finalizeForeignPtr, newForeignPtr, withForeignPtr)+import Foreign.Ptr (FunPtr, Ptr, freeHaskellFunPtr, nullFunPtr, nullPtr)+import Foreign.Storable (Storable(..))+import OpenSSL.BN+import OpenSSL.Utils+import System.IO.Unsafe (unsafePerformIO) -- |@'RSAPubKey'@ is an opaque object that represents RSA public key. newtype RSAPubKey = RSAPubKey (ForeignPtr RSA)
+ OpenSSL/Random.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE ForeignFunctionInterface #-}+-- | PRNG services+-- See <http://www.openssl.org/docs/crypto/rand.html>+-- For random Integer generation, see "OpenSSL.BN"+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.packCStringLen (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.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+-- 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
@@ -1,56 +0,0 @@-{- -*- haskell -*- -}---- | PRNG services--- See <http://www.openssl.org/docs/crypto/rand.html>--- For random Integer generation, see "OpenSSL.BN"--#include "HsOpenSSL.h"--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.packCStringLen (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.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--- 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/SSL.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE ForeignFunctionInterface #-}+module OpenSSL.SSL+ ( loadErrorStrings+ , addAllAlgorithms+ , libraryInit+ )+ where++foreign import ccall unsafe "SSL_load_error_strings"+ loadErrorStrings :: IO ()++foreign import ccall unsafe "HsOpenSSL_OpenSSL_add_all_algorithms"+ addAllAlgorithms :: IO ()++foreign import ccall unsafe "SSL_library_init"+ libraryInit :: IO ()
− OpenSSL/SSL.hsc
@@ -1,15 +0,0 @@-module OpenSSL.SSL- ( loadErrorStrings- , addAllAlgorithms- , libraryInit- )- where--foreign import ccall unsafe "SSL_load_error_strings"- loadErrorStrings :: IO ()--foreign import ccall unsafe "HsOpenSSL_OpenSSL_add_all_algorithms"- addAllAlgorithms :: IO ()--foreign import ccall unsafe "SSL_library_init"- libraryInit :: IO ()
OpenSSL/SSL/Option.hsc view
@@ -1,4 +1,5 @@--- See https://www.openssl.org/docs/ssl/SSL_CTX_set_options.html+{-# LANGUAGE DeriveDataTypeable #-}+-- | See https://www.openssl.org/docs/ssl/SSL_CTX_set_options.html module OpenSSL.SSL.Option ( SSLOption(..) , optionToIntegral@@ -24,10 +25,12 @@ | SSL_OP_NETSCAPE_REUSE_CIPHER_CHANGE_BUG | SSL_OP_SSLREF2_REUSE_CERT_TYPE_BUG | SSL_OP_MICROSOFT_BIG_SSLV3_BUFFER+#if defined(SSL_OP_SAFARI_ECDHE_ECDSA_BUG) -- | Don't prefer ECDHE-ECDSA ciphers when the client appears to -- be Safari on OS X. OS X 10.8..10.8.3 has broken support for -- ECDHE-ECDSA ciphers. | SSL_OP_SAFARI_ECDHE_ECDSA_BUG+#endif | SSL_OP_SSLEAY_080_CLIENT_DH_BUG | SSL_OP_TLS_D5_BUG | SSL_OP_TLS_BLOCK_PADDING_BUG@@ -141,7 +144,9 @@ optionToIntegral SSL_OP_NETSCAPE_REUSE_CIPHER_CHANGE_BUG = #const SSL_OP_NETSCAPE_REUSE_CIPHER_CHANGE_BUG optionToIntegral SSL_OP_SSLREF2_REUSE_CERT_TYPE_BUG = #const SSL_OP_SSLREF2_REUSE_CERT_TYPE_BUG optionToIntegral SSL_OP_MICROSOFT_BIG_SSLV3_BUFFER = #const SSL_OP_MICROSOFT_BIG_SSLV3_BUFFER+#if defined(SSL_OP_SAFARI_ECDHE_ECDSA_BUG) optionToIntegral SSL_OP_SAFARI_ECDHE_ECDSA_BUG = #const SSL_OP_SAFARI_ECDHE_ECDSA_BUG+#endif optionToIntegral SSL_OP_SSLEAY_080_CLIENT_DH_BUG = #const SSL_OP_SSLEAY_080_CLIENT_DH_BUG optionToIntegral SSL_OP_TLS_D5_BUG = #const SSL_OP_TLS_D5_BUG optionToIntegral SSL_OP_TLS_BLOCK_PADDING_BUG = #const SSL_OP_TLS_BLOCK_PADDING_BUG
OpenSSL/Session.hsc view
@@ -1,8 +1,12 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE NamedFieldPuns #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE NamedFieldPuns #-} -- | Functions for handling SSL connections. These functions use GHC specific -- calls to cooperative the with the scheduler so that 'blocking' functions -- only actually block the Haskell thread, not a whole OS thread.
+ OpenSSL/Stack.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ForeignFunctionInterface #-}+module OpenSSL.Stack+ ( STACK+ , mapStack+ , withStack+ , withForeignStack+ )+ where+import Control.Exception+import Foreign+import Foreign.C+++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 CInt++foreign import ccall unsafe "sk_value"+ skValue :: Ptr STACK -> CInt -> IO (Ptr ())+++mapStack :: (Ptr a -> IO b) -> Ptr STACK -> IO [b]+mapStack m st+ = do num <- skNum st+ mapM (\ i -> fmap castPtr (skValue st i) >>= m)+ $ take (fromIntegral 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+ = bracket (newStack values) skFree+++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/Stack.hsc
@@ -1,60 +0,0 @@-module OpenSSL.Stack- ( STACK- , mapStack- , withStack- , withForeignStack- )- where--import Control.Exception-import Foreign-import Foreign.C---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 CInt--foreign import ccall unsafe "sk_value"- skValue :: Ptr STACK -> CInt -> IO (Ptr ())---mapStack :: (Ptr a -> IO b) -> Ptr STACK -> IO [b]-mapStack m st- = do num <- skNum st- mapM (\ i -> fmap castPtr (skValue st i) >>= m)- $ take (fromIntegral 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- = bracket (newStack values) skFree---withForeignStack :: (fp -> Ptr obj)- -> (fp -> IO ())- -> [fp]- -> (Ptr STACK -> IO ret)- -> IO ret-withForeignStack unsafeFpToPtr touchFp fps action- = do ret <- withStack (map unsafeFpToPtr fps) action- mapM_ touchFp fps- return ret
OpenSSL/X509.hs view
@@ -1,8 +1,8 @@-{-# LANGUAGE CPP #-}-{-# OPTIONS_HADDOCK prune #-}-+{-# LANGUAGE CPP #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# OPTIONS_HADDOCK prune #-} -- |An interface to X.509 certificate.- module OpenSSL.X509 ( -- * Type X509
OpenSSL/X509/Name.hsc view
@@ -1,5 +1,5 @@-#include "HsOpenSSL.h"-+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ForeignFunctionInterface #-} module OpenSSL.X509.Name ( X509_NAME @@ -8,13 +8,12 @@ , peekX509Name ) where-+#include "HsOpenSSL.h" import Control.Exception import Foreign import Foreign.C import OpenSSL.ASN1 import OpenSSL.Utils- data X509_NAME data X509_NAME_ENTRY
+ OpenSSL/X509/Request.hs view
@@ -0,0 +1,253 @@+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# OPTIONS_HADDOCK 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 Data.Maybe+import Foreign+import Foreign.C+import OpenSSL.BIO+import OpenSSL.EVP.Digest hiding (digest)+import OpenSSL.EVP.PKey+import OpenSSL.EVP.Verify+import OpenSSL.EVP.Internal+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 CInt++foreign import ccall unsafe "X509_REQ_verify"+ _verify :: Ptr X509_REQ -> Ptr EVP_PKEY -> IO CInt++foreign import ccall unsafe "X509_REQ_print"+ _print :: Ptr BIO_ -> Ptr X509_REQ -> IO CInt++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 CInt++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 CInt++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 CInt++-- |@'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 = fmap X509Req . newForeignPtr _free+++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 :: KeyPair key =>+ X509Req -- ^ The request to be signed.+ -> key -- ^ 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)++-- |@'verifyX509Req'@ verifies a signature of certificate request with+-- a subject public key.+verifyX509Req :: PublicKey key =>+ X509Req -- ^ The request to be verified.+ -> key -- ^ The public key to verify with.+ -> IO VerifyStatus+verifyX509Req req pkey+ = withX509ReqPtr req $ \ reqPtr ->+ withPKeyPtr' pkey $ \ pkeyPtr ->+ _verify reqPtr pkeyPtr+ >>= interpret+ where+ interpret :: CInt -> 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 SomePublicKey+getPublicKey req+ = withX509ReqPtr req $ \ reqPtr ->+ fmap fromJust+ ( _get_pubkey reqPtr+ >>= failIfNull+ >>= wrapPKeyPtr+ >>= fromPKey+ )++-- |@'setPublicKey' req@ updates the public key of the subject of+-- certificate request.+setPublicKey :: PublicKey key => X509Req -> key -> 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
@@ -1,255 +0,0 @@-{- -*- haskell -*- -}--{-# OPTIONS_HADDOCK 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 Data.Maybe-import Foreign-import Foreign.C-import OpenSSL.BIO-import OpenSSL.EVP.Digest hiding (digest)-import OpenSSL.EVP.PKey-import OpenSSL.EVP.Verify-import OpenSSL.EVP.Internal-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 CInt--foreign import ccall unsafe "X509_REQ_verify"- _verify :: Ptr X509_REQ -> Ptr EVP_PKEY -> IO CInt--foreign import ccall unsafe "X509_REQ_print"- _print :: Ptr BIO_ -> Ptr X509_REQ -> IO CInt--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 CInt--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 CInt--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 CInt---- |@'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 = fmap X509Req . newForeignPtr _free---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 :: KeyPair key =>- X509Req -- ^ The request to be signed.- -> key -- ^ 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)---- |@'verifyX509Req'@ verifies a signature of certificate request with--- a subject public key.-verifyX509Req :: PublicKey key =>- X509Req -- ^ The request to be verified.- -> key -- ^ The public key to verify with.- -> IO VerifyStatus-verifyX509Req req pkey- = withX509ReqPtr req $ \ reqPtr ->- withPKeyPtr' pkey $ \ pkeyPtr ->- _verify reqPtr pkeyPtr- >>= interpret- where- interpret :: CInt -> 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 SomePublicKey-getPublicKey req- = withX509ReqPtr req $ \ reqPtr ->- fmap fromJust- ( _get_pubkey reqPtr- >>= failIfNull- >>= wrapPKeyPtr- >>= fromPKey- )---- |@'setPublicKey' req@ updates the public key of the subject of--- certificate request.-setPublicKey :: PublicKey key => X509Req -> key -> IO ()-setPublicKey req pkey- = withX509ReqPtr req $ \ reqPtr ->- withPKeyPtr' pkey $ \ pkeyPtr ->- _set_pubkey reqPtr pkeyPtr- >>= failIf (/= 1)- >> return ()----- |@'makeX509FromReq' req cert@ creates an empty X.509 certificate--- and copies as much data from the request as possible. The resulting--- certificate doesn't have the following data and it isn't signed so--- you must fill them and sign it yourself.------ * Serial number------ * Validity (Not Before and Not After)------ Example:------ > import Data.Time.Clock--- >--- > genCert :: X509 -> EvpPKey -> Integer -> Int -> X509Req -> IO X509--- > genCert caCert caKey serial days req--- > = do cert <- makeX509FromReq req caCert--- > now <- getCurrentTime--- > setSerialNumber cert serial--- > setNotBefore cert $ addUTCTime (-1) now--- > setNotAfter cert $ addUTCTime (days * 24 * 60 * 60) now--- > signX509 cert caKey Nothing--- > return cert----makeX509FromReq :: X509Req- -> X509- -> IO X509-makeX509FromReq req caCert- = do reqPubKey <- getPublicKey req- verified <- verifyX509Req req reqPubKey-- when (verified == VerifyFailure)- $ fail "makeX509FromReq: the request isn't properly signed by its own key."-- cert <- Cert.newX509- Cert.setVersion cert 2 -- Version 2 means X509 v3. It's confusing.- Cert.setIssuerName cert =<< Cert.getSubjectName caCert False- Cert.setSubjectName cert =<< getSubjectName req False- Cert.setPublicKey cert =<< getPublicKey req-- return cert
OpenSSL/X509/Revocation.hsc view
@@ -1,11 +1,8 @@-{- -*- haskell -*- -}--{-# OPTIONS_HADDOCK prune #-}-+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# OPTIONS_HADDOCK prune #-} -- |An interface to Certificate Revocation List.--#include "HsOpenSSL.h"- module OpenSSL.X509.Revocation ( -- * Types CRL@@ -42,6 +39,7 @@ , getRevoked ) where+#include "HsOpenSSL.h" import Control.Monad #if OPENSSL_VERSION_NUMBER < 0x10000000 import Data.List
+ OpenSSL/X509/Store.hs view
@@ -0,0 +1,145 @@+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# OPTIONS_HADDOCK prune #-}+-- |An interface to X.509 certificate store.+module OpenSSL.X509.Store+ ( X509Store+ , X509_STORE -- private++ , newX509Store++ , wrapX509Store -- private+ , withX509StorePtr -- private++ , addCertToStore+ , addCRLToStore++ , X509StoreCtx+ , X509_STORE_CTX -- private++ , withX509StoreCtxPtr -- private+ , wrapX509StoreCtx -- private++ , getStoreCtxCert+ , getStoreCtxIssuer+ , getStoreCtxCRL+ , getStoreCtxChain+ )+ where+import Control.Applicative ((<$>))+import Control.Exception (throwIO, mask_)+import Foreign+import Foreign.C+import Foreign.Concurrent as FC+import OpenSSL.X509+import OpenSSL.X509.Revocation+import OpenSSL.Stack+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 :: Ptr X509_STORE -> IO ()++foreign import ccall unsafe "X509_STORE_add_cert"+ _add_cert :: Ptr X509_STORE -> Ptr X509_ -> IO CInt++foreign import ccall unsafe "X509_STORE_add_crl"+ _add_crl :: Ptr X509_STORE -> Ptr X509_CRL -> IO CInt++-- |@'newX509Store'@ creates an empty X.509 certificate store.+newX509Store :: IO X509Store+newX509Store = _new+ >>= failIfNull+ >>= \ ptr -> wrapX509Store (_free ptr) ptr++wrapX509Store :: IO () -> Ptr X509_STORE -> IO X509Store+wrapX509Store finaliser ptr+ = do fp <- newForeignPtr_ ptr+ FC.addForeignPtrFinalizer fp finaliser+ return $ X509Store fp++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 ()++data X509_STORE_CTX+newtype X509StoreCtx = X509StoreCtx (ForeignPtr X509_STORE_CTX)++foreign import ccall unsafe "X509_STORE_CTX_get_current_cert"+ _store_ctx_get_current_cert :: Ptr X509_STORE_CTX -> IO (Ptr X509_)++foreign import ccall unsafe "HsOpenSSL_X509_STORE_CTX_get0_current_issuer"+ _store_ctx_get0_current_issuer :: Ptr X509_STORE_CTX -> IO (Ptr X509_)++foreign import ccall unsafe "HsOpenSSL_X509_STORE_CTX_get0_current_crl"+ _store_ctx_get0_current_crl :: Ptr X509_STORE_CTX -> IO (Ptr X509_CRL)++foreign import ccall unsafe "X509_STORE_CTX_get_chain"+ _store_ctx_get_chain :: Ptr X509_STORE_CTX -> IO (Ptr STACK)++foreign import ccall unsafe "HsOpenSSL_X509_ref"+ _x509_ref :: Ptr X509_ -> IO ()++foreign import ccall unsafe "HsOpenSSL_X509_CRL_ref"+ _crl_ref :: Ptr X509_CRL -> IO ()++withX509StoreCtxPtr :: X509StoreCtx -> (Ptr X509_STORE_CTX -> IO a) -> IO a+withX509StoreCtxPtr (X509StoreCtx fp) = withForeignPtr fp++wrapX509StoreCtx :: IO () -> Ptr X509_STORE_CTX -> IO X509StoreCtx+wrapX509StoreCtx finaliser ptr =+ X509StoreCtx <$> FC.newForeignPtr ptr finaliser++getStoreCtxCert :: X509StoreCtx -> IO X509+getStoreCtxCert ctx = withX509StoreCtxPtr ctx $ \pCtx -> do+ pCert <- _store_ctx_get_current_cert pCtx+ if pCert == nullPtr+ then throwIO $ userError "BUG: NULL certificate in X509_STORE_CTX"+ else mask_ $ _x509_ref pCert >> wrapX509 pCert++getStoreCtxIssuer :: X509StoreCtx -> IO (Maybe X509)+getStoreCtxIssuer ctx = withX509StoreCtxPtr ctx $ \pCtx -> do+ pCert <- _store_ctx_get0_current_issuer pCtx+ if pCert == nullPtr+ then return Nothing+ else fmap Just $ mask_ $ _x509_ref pCert >> wrapX509 pCert++getStoreCtxCRL :: X509StoreCtx -> IO (Maybe CRL)+getStoreCtxCRL ctx = withX509StoreCtxPtr ctx $ \pCtx -> do+ pCrl <- _store_ctx_get0_current_crl pCtx+ if pCrl == nullPtr+ then return Nothing+ else fmap Just $ mask_ $ _crl_ref pCrl >> wrapCRL pCrl++getStoreCtxChain :: X509StoreCtx -> IO [X509]+getStoreCtxChain ctx = withX509StoreCtxPtr ctx $ \pCtx -> do+ stack <- _store_ctx_get_chain pCtx+ (`mapStack` stack) $ \pCert -> mask_ $ _x509_ref pCert >> wrapX509 pCert+
− OpenSSL/X509/Store.hsc
@@ -1,148 +0,0 @@-{- -*- haskell -*- -}--{-# OPTIONS_HADDOCK prune #-}---- |An interface to X.509 certificate store.--module OpenSSL.X509.Store- ( X509Store- , X509_STORE -- private-- , newX509Store-- , wrapX509Store -- private- , withX509StorePtr -- private-- , addCertToStore- , addCRLToStore-- , X509StoreCtx- , X509_STORE_CTX -- private-- , withX509StoreCtxPtr -- private- , wrapX509StoreCtx -- private-- , getStoreCtxCert- , getStoreCtxIssuer- , getStoreCtxCRL- , getStoreCtxChain- )- where--import Control.Applicative ((<$>))-import Control.Exception (throwIO, mask_)-import Foreign-import Foreign.C-import Foreign.Concurrent as FC-import OpenSSL.X509-import OpenSSL.X509.Revocation-import OpenSSL.Stack-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 :: Ptr X509_STORE -> IO ()--foreign import ccall unsafe "X509_STORE_add_cert"- _add_cert :: Ptr X509_STORE -> Ptr X509_ -> IO CInt--foreign import ccall unsafe "X509_STORE_add_crl"- _add_crl :: Ptr X509_STORE -> Ptr X509_CRL -> IO CInt---- |@'newX509Store'@ creates an empty X.509 certificate store.-newX509Store :: IO X509Store-newX509Store = _new- >>= failIfNull- >>= \ ptr -> wrapX509Store (_free ptr) ptr--wrapX509Store :: IO () -> Ptr X509_STORE -> IO X509Store-wrapX509Store finaliser ptr- = do fp <- newForeignPtr_ ptr- FC.addForeignPtrFinalizer fp finaliser- return $ X509Store fp--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 ()--data X509_STORE_CTX-newtype X509StoreCtx = X509StoreCtx (ForeignPtr X509_STORE_CTX)--foreign import ccall unsafe "X509_STORE_CTX_get_current_cert"- _store_ctx_get_current_cert :: Ptr X509_STORE_CTX -> IO (Ptr X509_)--foreign import ccall unsafe "HsOpenSSL_X509_STORE_CTX_get0_current_issuer"- _store_ctx_get0_current_issuer :: Ptr X509_STORE_CTX -> IO (Ptr X509_)--foreign import ccall unsafe "HsOpenSSL_X509_STORE_CTX_get0_current_crl"- _store_ctx_get0_current_crl :: Ptr X509_STORE_CTX -> IO (Ptr X509_CRL)--foreign import ccall unsafe "X509_STORE_CTX_get_chain"- _store_ctx_get_chain :: Ptr X509_STORE_CTX -> IO (Ptr STACK)--foreign import ccall unsafe "HsOpenSSL_X509_ref"- _x509_ref :: Ptr X509_ -> IO ()--foreign import ccall unsafe "HsOpenSSL_X509_CRL_ref"- _crl_ref :: Ptr X509_CRL -> IO ()--withX509StoreCtxPtr :: X509StoreCtx -> (Ptr X509_STORE_CTX -> IO a) -> IO a-withX509StoreCtxPtr (X509StoreCtx fp) = withForeignPtr fp--wrapX509StoreCtx :: IO () -> Ptr X509_STORE_CTX -> IO X509StoreCtx-wrapX509StoreCtx finaliser ptr =- X509StoreCtx <$> FC.newForeignPtr ptr finaliser--getStoreCtxCert :: X509StoreCtx -> IO X509-getStoreCtxCert ctx = withX509StoreCtxPtr ctx $ \pCtx -> do- pCert <- _store_ctx_get_current_cert pCtx- if pCert == nullPtr- then throwIO $ userError "BUG: NULL certificate in X509_STORE_CTX"- else mask_ $ _x509_ref pCert >> wrapX509 pCert--getStoreCtxIssuer :: X509StoreCtx -> IO (Maybe X509)-getStoreCtxIssuer ctx = withX509StoreCtxPtr ctx $ \pCtx -> do- pCert <- _store_ctx_get0_current_issuer pCtx- if pCert == nullPtr- then return Nothing- else fmap Just $ mask_ $ _x509_ref pCert >> wrapX509 pCert--getStoreCtxCRL :: X509StoreCtx -> IO (Maybe CRL)-getStoreCtxCRL ctx = withX509StoreCtxPtr ctx $ \pCtx -> do- pCrl <- _store_ctx_get0_current_crl pCtx- if pCrl == nullPtr- then return Nothing- else fmap Just $ mask_ $ _crl_ref pCrl >> wrapCRL pCrl--getStoreCtxChain :: X509StoreCtx -> IO [X509]-getStoreCtxChain ctx = withX509StoreCtxPtr ctx $ \pCtx -> do- stack <- _store_ctx_get_chain pCtx- (`mapStack` stack) $ \pCert -> mask_ $ _x509_ref pCert >> wrapX509 pCert-
+ Test/OpenSSL/Cipher.hs view
@@ -0,0 +1,78 @@+-- | Tests for the non-EVP ciphers+module Main (main) where+import qualified Data.ByteString as BS+import OpenSSL.Cipher+import qualified Test.Framework as TF+import qualified Test.Framework.Providers.HUnit as TF+import Test.HUnit++-- | Convert a hex string to a ByteString (e.g. "0011" == BS.pack [0, 0x11])+hexToBS :: String -> BS.ByteString+hexToBS [] = BS.empty+hexToBS (a : b : rest) = BS.append (BS.singleton ((valueOfHexChar a * 16) + valueOfHexChar b))+ (hexToBS rest)+hexToBS xs = error ("hexToBS: invalid hex string: " ++ xs)++valueOfHexChar :: Integral a => Char -> a+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+valueOfHexChar x = error ("valueOfHexChar: invalid char: " ++ show x)++-- | 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]+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 -> Test+runCtrTest (CTRTest key iv plaintext ciphertext) =+ TestCase $ do+ ctx <- newAESCtx Encrypt key iv+ ct <- aesCTR ctx plaintext+ assertEqual "" ciphertext ct++tests :: Test+tests = TestList $ map runCtrTest ctrTests++main :: IO ()+main = TF.defaultMain $ TF.hUnitTestToTests tests
+ Test/OpenSSL/DSA.hs view
@@ -0,0 +1,39 @@+module Main (main) where+import qualified Data.ByteString as BS+import OpenSSL.DSA+import qualified Test.Framework as TF+import qualified Test.Framework.Providers.HUnit as TF+import Test.HUnit++-- | This function just runs the example DSA generation, as given in FIP 186-2,+-- app 5.+test_generateParameters :: Test+test_generateParameters = TestCase $ 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, _, p, q, g) <- generateDSAParameters 512 $ Just seed+ assertEqual "generateParameters"+ ( 105+ , 0x8df2a494492276aa3d25759bb06869cbeac0d83afb8d0cf7cbb8324f0d7882e5d0762fc5b7210eafc2e9adac32ab7aac49693dfbf83724c2ec0736ee31c80291+ , 0xc773218c737ec8ee993b4f2ded30f48edace915f+ , 0x626d027839ea0a13413163a55b4cb500299d5522956cefcb3bff10f399ce2c2e71cb9de5fa24babf58e5b79521925c9cc42e9f6f464b088cc572af53e6d78802+ ) (a, p, q, g)++testMessage :: BS.ByteString+testMessage = BS.pack [1..20]++test_signVerify :: Test+test_signVerify = TestCase $ do+ dsa <- generateDSAParametersAndKey 512 Nothing+ (a, b) <- signDigestedDataWithDSA dsa testMessage+ valid <- verifyDigestedDataWithDSA dsa testMessage (a, b)+ assertBool "signVerify" valid++tests :: Test+tests = TestList [test_generateParameters, test_signVerify]++main :: IO ()+main = TF.defaultMain $ TF.hUnitTestToTests tests
+ Test/OpenSSL/EVP/Base64.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+-- | Unittest for Base64 [en|de]coding.+module Main (main) where+#if !MIN_VERSION_bytestring(0,9,1)+import Data.Char (ord)+import Data.String+#endif+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL+import OpenSSL.EVP.Base64+import qualified Test.Framework as TF+import qualified Test.Framework.Providers.HUnit as TF+import Test.HUnit++-- NOTE: bytestring-0.9.0.4 has these instances too, while+-- bytestring-0.9.0.3 does not. If our bytestring is 0.9.0.4 we'll+-- have duplicate instances, but that's not our fault, is it?+#if !MIN_VERSION_bytestring(0,9,1)+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)+#endif++encodeTests :: Test+encodeTests =+ TestLabel "encode" $+ TestList $ map (\(a, v) -> encodeBase64BS a ~?= v) pairs+ where+ pairs :: [(BS.ByteString, BS.ByteString)]+ pairs = [ ("" , "" )+ , ("a" , "YQ==")+ , ("aa" , "YWE=")+ , ("aaa", "YWFh")+ ]++lazyEncodeTests :: Test+lazyEncodeTests =+ TestLabel "lazyEncode" $+ TestList $ map (\(a, v) -> encodeBase64LBS a ~?= v) pairs+ where+ pairs :: [(BSL.ByteString, BSL.ByteString)]+ pairs = [ ("" , "" )+ , ("a" , "YQ==")+ , ("aa" , "YWE=")+ , ("aaa", "YWFh")+ ]++decodeTests :: Test+decodeTests =+ TestLabel "decode" $+ TestList $ map (\(a, v) -> decodeBase64BS a ~?= v) pairs+ where+ pairs :: [(BS.ByteString, BS.ByteString)]+ pairs = [ ("" , "" )+ , ("aGFza2VsbA==" , "haskell" )+ , ("YWJjZGVmZ2hpams=" , "abcdefghijk")+ , ("YWJjZGVmZ2hpams=\n", "abcdefghijk")+ ]++tests :: Test+tests = TestList+ [ encodeTests+ , lazyEncodeTests+ , decodeTests+ ]++main :: IO ()+main = TF.defaultMain $ TF.hUnitTestToTests tests
− tests/Base64.hs
@@ -1,71 +0,0 @@-{-# 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--{-- Comment by PHO:-- These instance declarations now seem to be part of- Data.ByteString. What should we do then?-- Base64.hs:12:9:- Duplicate instance declarations:- instance IsString BS.ByteString -- Defined at Base64.hs:12:9-30- instance IsString BS.ByteString -- Defined in Data.ByteString.Char8-- Base64.hs:17:9:- Duplicate instance declarations:- instance IsString BSL.ByteString -- Defined at Base64.hs:17:9-31- instance IsString BSL.ByteString- -- Defined in Data.ByteString.Lazy.Char8--}-{--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
@@ -1,91 +0,0 @@--- | Tests for the non-EVP ciphers-module Main where--import Control.Monad (unless)-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 = fmap (all (== True)) (mapM runCtrTest ctrTests)--main = do- r <- runCtrTests- unless r $ fail "CTR tests failed"- putStrLn "PASS"
− tests/DSA.hs
@@ -1,48 +0,0 @@-module Main where--import Control.Monad-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) <- generateDSAParameters 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 <- generateDSAParametersAndKey 512 Nothing- (a, b) <- signDigestedDataWithDSA dsa testMessage- verifyDigestedDataWithDSA dsa testMessage (a, b)--test_signVerifySpeed = do- dsa <- generateDSAParametersAndKey 512 Nothing-- let test = do- (a, b) <- signDigestedDataWithDSA dsa testMessage- True <- verifyDigestedDataWithDSA dsa testMessage (a, b)- return ()-- starttime <- getClockTime- replicateM_ 2000 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
@@ -1,11 +0,0 @@-TESTS = \- Base64 \- Cipher \- DSA \- $(NULL)--test:- for i in $(TESTS); do ghc --make $$i; ./$$i; done--clean:- rm -f *.hi *.o $(TESTS)