diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,43 @@ +2015-01-06 PHO + + * 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 + + * 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 * OpenSSL/ASN1.hsc (peekASN1Time): Support time-1.5, diff --git a/HsOpenSSL.cabal b/HsOpenSSL.cabal --- a/HsOpenSSL.cabal +++ b/HsOpenSSL.cabal @@ -12,7 +12,7 @@ , 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 diff --git a/OpenSSL.hs b/OpenSSL.hs new file mode 100644 --- /dev/null +++ b/OpenSSL.hs @@ -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 (), 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 diff --git a/OpenSSL.hsc b/OpenSSL.hsc deleted file mode 100644 --- a/OpenSSL.hsc +++ /dev/null @@ -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 (), 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 diff --git a/OpenSSL/ASN1.hsc b/OpenSSL/ASN1.hsc --- a/OpenSSL/ASN1.hsc +++ b/OpenSSL/ASN1.hsc @@ -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 diff --git a/OpenSSL/BIO.hs b/OpenSSL/BIO.hs new file mode 100644 --- /dev/null +++ b/OpenSSL/BIO.hs @@ -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 diff --git a/OpenSSL/BIO.hsc b/OpenSSL/BIO.hsc deleted file mode 100644 --- a/OpenSSL/BIO.hsc +++ /dev/null @@ -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 diff --git a/OpenSSL/BN.hsc b/OpenSSL/BN.hsc --- a/OpenSSL/BN.hsc +++ b/OpenSSL/BN.hsc @@ -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 ----------------------------------------------------- -} diff --git a/OpenSSL/Cipher.hsc b/OpenSSL/Cipher.hsc --- a/OpenSSL/Cipher.hsc +++ b/OpenSSL/Cipher.hsc @@ -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 diff --git a/OpenSSL/DH.hs b/OpenSSL/DH.hs --- a/OpenSSL/DH.hs +++ b/OpenSSL/DH.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ForeignFunctionInterface #-} -- | Diffie-Hellman key exchange module OpenSSL.DH ( DHP diff --git a/OpenSSL/DH/Internal.hs b/OpenSSL/DH/Internal.hs new file mode 100644 --- /dev/null +++ b/OpenSSL/DH/Internal.hs @@ -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 () + diff --git a/OpenSSL/DH/Internal.hsc b/OpenSSL/DH/Internal.hsc deleted file mode 100644 --- a/OpenSSL/DH/Internal.hsc +++ /dev/null @@ -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 () - diff --git a/OpenSSL/DSA.hsc b/OpenSSL/DSA.hsc --- a/OpenSSL/DSA.hsc +++ b/OpenSSL/DSA.hsc @@ -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 - -#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) diff --git a/OpenSSL/ERR.hs b/OpenSSL/ERR.hs new file mode 100644 --- /dev/null +++ b/OpenSSL/ERR.hs @@ -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 diff --git a/OpenSSL/ERR.hsc b/OpenSSL/ERR.hsc deleted file mode 100644 --- a/OpenSSL/ERR.hsc +++ /dev/null @@ -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 diff --git a/OpenSSL/EVP/Base64.hs b/OpenSSL/EVP/Base64.hs new file mode 100644 --- /dev/null +++ b/OpenSSL/EVP/Base64.hs @@ -0,0 +1,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 diff --git a/OpenSSL/EVP/Base64.hsc b/OpenSSL/EVP/Base64.hsc deleted file mode 100644 --- a/OpenSSL/EVP/Base64.hsc +++ /dev/null @@ -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 diff --git a/OpenSSL/EVP/Cipher.hs b/OpenSSL/EVP/Cipher.hs new file mode 100644 --- /dev/null +++ b/OpenSSL/EVP/Cipher.hs @@ -0,0 +1,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 + diff --git a/OpenSSL/EVP/Cipher.hsc b/OpenSSL/EVP/Cipher.hsc deleted file mode 100644 --- a/OpenSSL/EVP/Cipher.hsc +++ /dev/null @@ -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 - diff --git a/OpenSSL/EVP/Digest.hsc b/OpenSSL/EVP/Digest.hsc --- a/OpenSSL/EVP/Digest.hsc +++ b/OpenSSL/EVP/Digest.hsc @@ -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) diff --git a/OpenSSL/EVP/Internal.hsc b/OpenSSL/EVP/Internal.hsc --- a/OpenSSL/EVP/Internal.hsc +++ b/OpenSSL/EVP/Internal.hsc @@ -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" diff --git a/OpenSSL/EVP/Open.hs b/OpenSSL/EVP/Open.hs new file mode 100644 --- /dev/null +++ b/OpenSSL/EVP/Open.hs @@ -0,0 +1,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 diff --git a/OpenSSL/EVP/Open.hsc b/OpenSSL/EVP/Open.hsc deleted file mode 100644 --- a/OpenSSL/EVP/Open.hsc +++ /dev/null @@ -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 diff --git a/OpenSSL/EVP/PKey.hsc b/OpenSSL/EVP/PKey.hsc --- a/OpenSSL/EVP/PKey.hsc +++ b/OpenSSL/EVP/PKey.hsc @@ -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) diff --git a/OpenSSL/EVP/Seal.hs b/OpenSSL/EVP/Seal.hs new file mode 100644 --- /dev/null +++ b/OpenSSL/EVP/Seal.hs @@ -0,0 +1,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) diff --git a/OpenSSL/EVP/Seal.hsc b/OpenSSL/EVP/Seal.hsc deleted file mode 100644 --- a/OpenSSL/EVP/Seal.hsc +++ /dev/null @@ -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) diff --git a/OpenSSL/EVP/Sign.hs b/OpenSSL/EVP/Sign.hs new file mode 100644 --- /dev/null +++ b/OpenSSL/EVP/Sign.hs @@ -0,0 +1,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] + diff --git a/OpenSSL/EVP/Sign.hsc b/OpenSSL/EVP/Sign.hsc deleted file mode 100644 --- a/OpenSSL/EVP/Sign.hsc +++ /dev/null @@ -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] - diff --git a/OpenSSL/EVP/Verify.hs b/OpenSSL/EVP/Verify.hs new file mode 100644 --- /dev/null +++ b/OpenSSL/EVP/Verify.hs @@ -0,0 +1,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 diff --git a/OpenSSL/EVP/Verify.hsc b/OpenSSL/EVP/Verify.hsc deleted file mode 100644 --- a/OpenSSL/EVP/Verify.hsc +++ /dev/null @@ -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 diff --git a/OpenSSL/Objects.hsc b/OpenSSL/Objects.hsc --- a/OpenSSL/Objects.hsc +++ b/OpenSSL/Objects.hsc @@ -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 diff --git a/OpenSSL/PEM.hs b/OpenSSL/PEM.hs new file mode 100644 --- /dev/null +++ b/OpenSSL/PEM.hs @@ -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 () diff --git a/OpenSSL/PEM.hsc b/OpenSSL/PEM.hsc deleted file mode 100644 --- a/OpenSSL/PEM.hsc +++ /dev/null @@ -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 () diff --git a/OpenSSL/PKCS7.hsc b/OpenSSL/PKCS7.hsc --- a/OpenSSL/PKCS7.hsc +++ b/OpenSSL/PKCS7.hsc @@ -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 diff --git a/OpenSSL/RSA.hsc b/OpenSSL/RSA.hsc --- a/OpenSSL/RSA.hsc +++ b/OpenSSL/RSA.hsc @@ -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) diff --git a/OpenSSL/Random.hs b/OpenSSL/Random.hs new file mode 100644 --- /dev/null +++ b/OpenSSL/Random.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +-- | PRNG services +-- See +-- 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) diff --git a/OpenSSL/Random.hsc b/OpenSSL/Random.hsc deleted file mode 100644 --- a/OpenSSL/Random.hsc +++ /dev/null @@ -1,56 +0,0 @@ -{- -*- haskell -*- -} - --- | PRNG services --- See --- 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) diff --git a/OpenSSL/SSL.hs b/OpenSSL/SSL.hs new file mode 100644 --- /dev/null +++ b/OpenSSL/SSL.hs @@ -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 () diff --git a/OpenSSL/SSL.hsc b/OpenSSL/SSL.hsc deleted file mode 100644 --- a/OpenSSL/SSL.hsc +++ /dev/null @@ -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 () diff --git a/OpenSSL/SSL/Option.hsc b/OpenSSL/SSL/Option.hsc --- a/OpenSSL/SSL/Option.hsc +++ b/OpenSSL/SSL/Option.hsc @@ -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 diff --git a/OpenSSL/Session.hsc b/OpenSSL/Session.hsc --- a/OpenSSL/Session.hsc +++ b/OpenSSL/Session.hsc @@ -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. diff --git a/OpenSSL/Stack.hs b/OpenSSL/Stack.hs new file mode 100644 --- /dev/null +++ b/OpenSSL/Stack.hs @@ -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 diff --git a/OpenSSL/Stack.hsc b/OpenSSL/Stack.hsc deleted file mode 100644 --- a/OpenSSL/Stack.hsc +++ /dev/null @@ -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 diff --git a/OpenSSL/X509.hs b/OpenSSL/X509.hs --- a/OpenSSL/X509.hs +++ b/OpenSSL/X509.hs @@ -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 diff --git a/OpenSSL/X509/Name.hsc b/OpenSSL/X509/Name.hsc --- a/OpenSSL/X509/Name.hsc +++ b/OpenSSL/X509/Name.hsc @@ -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 diff --git a/OpenSSL/X509/Request.hs b/OpenSSL/X509/Request.hs new file mode 100644 --- /dev/null +++ b/OpenSSL/X509/Request.hs @@ -0,0 +1,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 diff --git a/OpenSSL/X509/Request.hsc b/OpenSSL/X509/Request.hsc deleted file mode 100644 --- a/OpenSSL/X509/Request.hsc +++ /dev/null @@ -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 diff --git a/OpenSSL/X509/Revocation.hsc b/OpenSSL/X509/Revocation.hsc --- a/OpenSSL/X509/Revocation.hsc +++ b/OpenSSL/X509/Revocation.hsc @@ -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 diff --git a/OpenSSL/X509/Store.hs b/OpenSSL/X509/Store.hs new file mode 100644 --- /dev/null +++ b/OpenSSL/X509/Store.hs @@ -0,0 +1,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 + diff --git a/OpenSSL/X509/Store.hsc b/OpenSSL/X509/Store.hsc deleted file mode 100644 --- a/OpenSSL/X509/Store.hsc +++ /dev/null @@ -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 - diff --git a/Test/OpenSSL/Cipher.hs b/Test/OpenSSL/Cipher.hs new file mode 100644 --- /dev/null +++ b/Test/OpenSSL/Cipher.hs @@ -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 diff --git a/Test/OpenSSL/DSA.hs b/Test/OpenSSL/DSA.hs new file mode 100644 --- /dev/null +++ b/Test/OpenSSL/DSA.hs @@ -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 diff --git a/Test/OpenSSL/EVP/Base64.hs b/Test/OpenSSL/EVP/Base64.hs new file mode 100644 --- /dev/null +++ b/Test/OpenSSL/EVP/Base64.hs @@ -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 diff --git a/tests/Base64.hs b/tests/Base64.hs deleted file mode 100644 --- a/tests/Base64.hs +++ /dev/null @@ -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" diff --git a/tests/Cipher.hs b/tests/Cipher.hs deleted file mode 100644 --- a/tests/Cipher.hs +++ /dev/null @@ -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" diff --git a/tests/DSA.hs b/tests/DSA.hs deleted file mode 100644 --- a/tests/DSA.hs +++ /dev/null @@ -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 diff --git a/tests/Makefile b/tests/Makefile deleted file mode 100644 --- a/tests/Makefile +++ /dev/null @@ -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)