diff --git a/AUTHORS b/AUTHORS new file mode 100644 --- /dev/null +++ b/AUTHORS @@ -0,0 +1,4 @@ +This is a list of contributors to the HsOpenSSL. + +* Adam Langley +* PHO diff --git a/HsOpenSSL.cabal b/HsOpenSSL.cabal --- a/HsOpenSSL.cabal +++ b/HsOpenSSL.cabal @@ -2,10 +2,10 @@ Synopsis: (Part of) OpenSSL binding for Haskell Description: HsOpenSSL is a (part of) OpenSSL binding for Haskell. It can - generate RSA keys, read and write PEM files, generate message - digests, sign and verify messages, encrypt and decrypt + generate RSA and DSA keys, read and write PEM files, generate + message digests, sign and verify messages, encrypt and decrypt messages. -Version: 0.1.1 +Version: 0.2 License: PublicDomain License-File: COPYING Author: PHO @@ -28,6 +28,7 @@ OpenSSL.EVP.Verify OpenSSL.PEM OpenSSL.PKCS7 + OpenSSL.DSA OpenSSL.RSA OpenSSL.X509 OpenSSL.X509.Revocation @@ -54,6 +55,7 @@ Install-Includes: HsOpenSSL.h Extra-Source-Files: + AUTHORS HsOpenSSL.buildinfo.in NEWS cbits/HsOpenSSL.h diff --git a/NEWS b/NEWS --- a/NEWS +++ b/NEWS @@ -1,3 +1,14 @@ +Changes from 0.1.1. to 0.2 +-------------------------- +* Applied patches by Adam Langley: + - OpenSSL.DSA: Add DSA support + - OpenSSL.BN: Add support for fast Integer<->BN conversions + - OpenSSL.BN: New BN utility function, newBN + - OpenSSL.BN: FIX: set the BN ptr to NULL before calling BN_dec2bn, + otherwise that function thinks that there's a valid BN there + - OpenSSL.Utils: Add utility functions to print and read hex numbers + + Changes from 0.1 to 0.1.1 ------------------------- * Moved hidden modules from Exposed-Modules to Other-Modules. diff --git a/OpenSSL.hsc b/OpenSSL.hsc --- a/OpenSSL.hsc +++ b/OpenSSL.hsc @@ -1,10 +1,10 @@ {- -*- haskell -*- -} -- |HsOpenSSL is a (part of) OpenSSL binding for Haskell. It can --- generate RSA keys, read and write PEM files, generate message --- digests, sign and verify messages, encrypt and decrypt messages. --- But since OpenSSL is a very large library, it is uneasy to cover --- everything in it. +-- generate RSA and DSA keys, read and write PEM files, generate +-- message digests, sign and verify messages, encrypt and decrypt +-- messages. But since OpenSSL is a very large library, it is uneasy +-- to cover everything in it. -- -- Features that aren't (yet) supported: -- @@ -19,7 +19,7 @@ -- (EVP) is available. But I believe no one will complain about the -- absence of functions like @RSA_public_encrypt@. -- --- [/Key generation of DSA and Diffie-Hellman algorithms/] Only RSA +-- [/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 diff --git a/OpenSSL/BN.hsc b/OpenSSL/BN.hsc --- a/OpenSSL/BN.hsc +++ b/OpenSSL/BN.hsc @@ -1,3 +1,5 @@ +#include "HsOpenSSL.h" + module OpenSSL.BN ( BigNum , BIGNUM @@ -5,15 +7,31 @@ , allocaBN , withBN , peekBN + , newBN + +#ifdef __GLASGOW_HASKELL__ + , integerToBN + , bnToInteger +#endif ) where import Control.Exception -import Control.Monad import Foreign + + +#ifndef __GLASGOW_HASKELL__ +import Control.Monad import Foreign.C import OpenSSL.Utils - +#else +import Foreign.C.Types +import Data.Word (Word32) +import GHC.Base +import GHC.Num +import GHC.Prim +import GHC.IOBase (IO(..)) +#endif type BigNum = Ptr BIGNUM data BIGNUM = BIGNUM @@ -25,6 +43,16 @@ foreign import ccall unsafe "BN_free" _free :: BigNum -> IO () + +allocaBN :: (BigNum -> IO a) -> IO a +allocaBN m + = bracket _new _free m + + +#ifndef __GLASGOW_HASKELL__ + +{- slow, safe functions ----------------------------------------------------- -} + foreign import ccall unsafe "BN_bn2dec" _bn2dec :: BigNum -> IO CString @@ -34,17 +62,12 @@ foreign import ccall unsafe "HsOpenSSL_OPENSSL_free" _openssl_free :: Ptr a -> IO () - -allocaBN :: (BigNum -> IO a) -> IO a -allocaBN m - = bracket _new _free m - - withBN :: Integer -> (BigNum -> IO a) -> IO a withBN dec m = withCString (show dec) $ \ strPtr -> alloca $ \ bnPtr -> - do _dec2bn bnPtr strPtr + do poke bnPtr nullPtr + _dec2bn bnPtr strPtr >>= failIf (== 0) bracket (peek bnPtr) _free m @@ -53,8 +76,122 @@ peekBN bn = do strPtr <- _bn2dec bn when (strPtr == nullPtr) $ fail "BN_bn2dec failed" - str <- peekCString strPtr _openssl_free strPtr return $ read str + + +-- | Return a new, alloced bignum +newBN :: Integer -> IO BigNum +newBN i = do + withCString (show i) (\str -> do + alloca (\bnptr -> do + poke bnptr nullPtr + _dec2bn bnptr str >>= failIf (== 0) + peek bnptr)) + +#else + +{- fast, dangerous functions ------------------------------------------------ -} + +-- Both BN (the OpenSSL library) and GMP (used by GHC) use the same internal +-- representation for numbers: an array of words, least-significant first. Thus +-- we can move from Integer's to BIGNUMs very quickly: by copying in the worst +-- case and by just alloca'ing and pointing into the Integer in the fast case. +-- Note that, in the fast case, it's very important that any foreign function +-- calls be "unsafe", that is, they don't call back into Haskell. Otherwise the +-- GC could do nasty things to the data which we thought that we had a pointer +-- to + +foreign import ccall unsafe "memcpy" + _copy_in :: ByteArray## -> Ptr () -> CSize -> IO () + +foreign import ccall unsafe "memcpy" + _copy_out :: Ptr () -> ByteArray## -> CSize -> IO () + +-- These are taken from Data.Binary's disabled fast Integer support +data ByteArray = BA {-# UNPACK #-} !ByteArray## +data MBA = MBA {-# UNPACK #-} !(MutableByteArray## RealWorld) + +newByteArray :: Int## -> IO MBA +newByteArray sz = IO $ \s -> + case newByteArray## sz s of { (## s', arr ##) -> + (## s', MBA arr ##) } + +freezeByteArray :: MutableByteArray## RealWorld -> IO ByteArray +freezeByteArray arr = IO $ \s -> + case unsafeFreezeByteArray## arr s of { (## s', arr' ##) -> + (## s', BA arr' ##) } + +-- | Convert a BIGNUM to an Integer +bnToInteger :: BigNum -> IO Integer +bnToInteger bn = do + nlimbs <- (#peek BIGNUM, top) bn :: IO CSize + case nlimbs of + 0 -> return 0 + 1 -> do (I## i) <- (#peek BIGNUM, d) bn >>= peek + negative <- (#peek BIGNUM, neg) bn :: IO Word32 + if negative == 0 + then return $ S## i + else return $ 0 - (S## i) + otherwise -> do + let (I## nlimbsi) = fromIntegral nlimbs + (I## limbsize) = (#size unsigned long) + (MBA arr) <- newByteArray (nlimbsi *## limbsize) + (BA ba) <- freezeByteArray arr + limbs <- (#peek BIGNUM, d) bn + _copy_in ba limbs $ fromIntegral $ nlimbs * (#size unsigned long) + negative <- (#peek BIGNUM, neg) bn :: IO Word32 + if negative == 0 + then return $ J## nlimbsi ba + else return $ 0 - (J## nlimbsi ba) + +-- | This is a GHC specific, fast conversion between Integers and OpenSSL +-- bignums. It returns a malloced BigNum. +integerToBN :: Integer -> IO BigNum +integerToBN (S## v) = do + bnptr <- mallocBytes (#size BIGNUM) + limbs <- malloc :: IO (Ptr Word32) + poke limbs $ fromIntegral $ abs $ I## v + (#poke BIGNUM, d) bnptr limbs + -- This is needed to give GHC enough type information since #poke just + -- uses an offset + let one :: Word32 + one = 1 + (#poke BIGNUM, flags) bnptr one + (#poke BIGNUM, top) bnptr one + (#poke BIGNUM, dmax) bnptr one + (#poke BIGNUM, neg) bnptr (if (I## v) < 0 then one else 0) + return bnptr + +integerToBN v@(J## nlimbs_ bytearray) + | v >= 0 = do + let nlimbs = (I## nlimbs_) + bnptr <- mallocBytes (#size BIGNUM) + limbs <- mallocBytes ((#size unsigned) * nlimbs) + (#poke BIGNUM, d) bnptr limbs + (#poke BIGNUM, flags) bnptr (1 :: Word32) + _copy_out limbs bytearray (fromIntegral $ (#size unsigned) * nlimbs) + (#poke BIGNUM, top) bnptr ((fromIntegral nlimbs) :: Word32) + (#poke BIGNUM, dmax) bnptr ((fromIntegral nlimbs) :: Word32) + (#poke BIGNUM, neg) bnptr (0 :: Word32) + return bnptr + | otherwise = do bnptr <- integerToBN (0-v) + (#poke BIGNUM, neg) bnptr (1 :: Word32) + return bnptr + +-- TODO: we could make a function which doesn't even allocate BN data if we +-- wanted to be very fast and dangerout. The BIGNUM could point right into the +-- Integer's data. However, I'm not sure about the semantics of the GC; which +-- might move the Integer data around. + +withBN :: Integer -> (BigNum -> IO a) -> IO a +withBN dec m = bracket (integerToBN dec) _free m + +peekBN :: BigNum -> IO Integer +peekBN = bnToInteger + +newBN = integerToBN + +#endif diff --git a/OpenSSL/DSA.hsc b/OpenSSL/DSA.hsc new file mode 100644 --- /dev/null +++ b/OpenSSL/DSA.hsc @@ -0,0 +1,213 @@ +{- -*- haskell -*- -} + +-- | The Digital Signature Algorithm (FIPS 186-2). +-- See + +#include "HsOpenSSL.h" + +module OpenSSL.DSA + ( -- * Type + DSA + + -- * Key and parameter generation + , generateParameters + , generateKey + , generateParametersAndKey + + -- * Signing and verification + , signDigestedData + , verifyDigestedData + + -- * Extracting fields of DSA objects + , dsaP + , dsaQ + , dsaG + , dsaPrivate + , dsaPublic + , dsaToTuple + , tupleToDSA + ) where + +import Control.Monad +import Foreign +import Foreign.C (CString) +import Foreign.C.Types +import OpenSSL.BN +import OpenSSL.Utils +import qualified Data.ByteString as BS + +-- | The type of a DSA key, includes parameters p, q, g. +newtype DSA = DSA (ForeignPtr DSA_) + +data DSA_ + +foreign import ccall unsafe "&DSA_free" + _free :: FunPtr (Ptr DSA_ -> IO ()) + +foreign import ccall unsafe "DSA_free" + dsa_free :: Ptr DSA_ -> IO () + +foreign import ccall unsafe "BN_free" + _bn_free :: BigNum -> IO () + +foreign import ccall unsafe "DSA_new" + _dsa_new :: IO (Ptr DSA_) + +foreign import ccall unsafe "DSA_generate_key" + _dsa_generate_key :: Ptr DSA_ -> IO () + +foreign import ccall unsafe "HsOpenSSL_dsa_sign" + _dsa_sign :: Ptr DSA_ -> CString -> Int -> Ptr BigNum -> Ptr BigNum -> IO Int + +foreign import ccall unsafe "HsOpenSSL_dsa_verify" + _dsa_verify :: Ptr DSA_ -> CString -> Int -> BigNum -> BigNum -> IO Int + +withDSAPtr :: DSA -> (Ptr DSA_ -> IO a) -> IO a +withDSAPtr (DSA ptr) = withForeignPtr ptr + +foreign import ccall safe "DSA_generate_parameters" + _generate_params :: Int -> Ptr CChar -> Int -> Ptr CInt -> Ptr CInt -> Ptr () -> Ptr () -> IO (Ptr DSA_) + +peekDSA :: (Ptr DSA_ -> IO BigNum) -> DSA -> IO (Maybe Integer) +peekDSA peeker (DSA dsa) = do + withForeignPtr dsa (\ptr -> do + bn <- peeker ptr + if bn == nullPtr + then return Nothing + else peekBN bn >>= return . Just) + +-- | Generate DSA parameters (*not* a key, but required for a key). This is a +-- compute intensive operation. See FIPS 186-2, app 2. This agrees with the +-- test vectors given in FIP 186-2, app 5 +generateParameters :: Int -- ^ The number of bits in the generated prime: 512 <= x <= 1024 + -> Maybe BS.ByteString -- ^ optional seed, its length must be 20 bytes + -> IO (Int, Int, Integer, Integer, Integer) -- ^ (iteration count, generator count, p, q, g) +generateParameters nbits mseed = do + when (nbits < 512 || nbits > 1024) $ fail "Invalid DSA bit size" + alloca (\i1 -> do + alloca (\i2 -> do + (\x -> case mseed of + Nothing -> x (nullPtr, 0) + Just seed -> BS.useAsCStringLen seed x) (\(seedptr, seedlen) -> do + ptr <- _generate_params nbits seedptr seedlen i1 i2 nullPtr nullPtr + failIfNull ptr + itcount <- peek i1 + gencount <- peek i2 + p <- (#peek DSA, p) ptr >>= peekBN + q <- (#peek DSA, q) ptr >>= peekBN + g <- (#peek DSA, g) ptr >>= peekBN + dsa_free ptr + return (fromIntegral itcount, fromIntegral gencount, p, q, g)))) + +{- +-- | This function just runs the example DSA generation, as given in FIP 186-2, +-- app 5. The return values should be: +-- (105, +-- "8df2a494492276aa3d25759bb06869cbeac0d83afb8d0cf7cbb8324f0d7882e5d0762fc5b7210 +-- eafc2e9adac32ab7aac49693dfbf83724c2ec0736ee31c80291", +-- "c773218c737ec8ee993b4f2ded30f48edace915f", +-- "626d027839ea0a13413163a55b4cb500299d5522956cefcb3bff10f399ce2c2e71cb9de5fa24 +-- babf58e5b79521925c9cc42e9f6f464b088cc572af53e6d78802"), as given at the bottom of +-- page 21 +test_generateParameters = do + let seed = BS.pack [0xd5, 0x01, 0x4e, 0x4b, + 0x60, 0xef, 0x2b, 0xa8, + 0xb6, 0x21, 0x1b, 0x40, + 0x62, 0xba, 0x32, 0x24, + 0xe0, 0x42, 0x7d, 0xd3] + (a, b, p, q, g) <- generateParameters 512 $ Just seed + return (a, toHex p, toHex q, g) +-} + +-- | Generate a new DSA key, given valid parameters +generateKey :: Integer -- ^ p + -> Integer -- ^ q + -> Integer -- ^ g + -> IO DSA +generateKey p q g = do + ptr <- _dsa_new + newBN p >>= (#poke DSA, p) ptr + newBN q >>= (#poke DSA, q) ptr + newBN g >>= (#poke DSA, g) ptr + _dsa_generate_key ptr + newForeignPtr _free ptr >>= return . DSA + +dsaP :: DSA -> IO (Maybe Integer) +dsaP = peekDSA (#peek DSA, p) + +dsaQ :: DSA -> IO (Maybe Integer) +dsaQ = peekDSA (#peek DSA, q) + +dsaG :: DSA -> IO (Maybe Integer) +dsaG = peekDSA (#peek DSA, g) + +dsaPublic :: DSA -> IO (Maybe Integer) +dsaPublic = peekDSA (#peek DSA, pub_key) + +dsaPrivate :: DSA -> IO (Maybe Integer) +dsaPrivate = peekDSA (#peek DSA, priv_key) + +-- | Convert a DSA object to a tuple of its members in the order p, q, g, +-- public, private. If this is a public key, private will be Nothing +dsaToTuple :: DSA -> IO (Integer, Integer, Integer, Integer, Maybe Integer) +dsaToTuple dsa = do + Just p <- peekDSA (#peek DSA, p) dsa + Just q <- peekDSA (#peek DSA, q) dsa + Just g <- peekDSA (#peek DSA, g) dsa + Just pub <- peekDSA (#peek DSA, pub_key) dsa + private <- peekDSA (#peek DSA, priv_key) dsa + + return (p, q, g, pub, private) + +-- | Convert a tuple of members (in the same format as from dsaToTuple) into a +-- DSA object +tupleToDSA :: (Integer, Integer, Integer, Integer, Maybe Integer) -> IO DSA +tupleToDSA (p, q, g, pub, mpriv) = do + ptr <- _dsa_new + newBN p >>= (#poke DSA, p) ptr + newBN q >>= (#poke DSA, q) ptr + newBN g >>= (#poke DSA, g) ptr + newBN pub >>= (#poke DSA, pub_key) ptr + case mpriv of + Just priv -> newBN priv >>= (#poke DSA, priv_key) ptr + Nothing -> (#poke DSA, priv_key) ptr nullPtr + newForeignPtr _free ptr >>= return . DSA + +-- | A utility function to generate both the parameters and the key pair at the +-- same time. Saves serialising and deserialising the parameters too +generateParametersAndKey :: Int -- ^ The number of bits in the generated prime: 512 <= x <= 1024 + -> Maybe BS.ByteString -- ^ optional seed, its length must be 20 bytes + -> IO DSA +generateParametersAndKey nbits mseed = do + (\x -> case mseed of + Nothing -> x (nullPtr, 0) + Just seed -> BS.useAsCStringLen seed x) (\(seedptr, seedlen) -> do + ptr <- _generate_params nbits seedptr seedlen nullPtr nullPtr nullPtr nullPtr + failIfNull ptr + _dsa_generate_key ptr + newForeignPtr _free ptr >>= return . DSA) + +-- | Sign pre-digested data. The DSA specs call for SHA1 to be used so, if you +-- use anything else, YMMV. Returns a pair of Integers which, together, are +-- the signature +signDigestedData :: DSA -> BS.ByteString -> IO (Integer, Integer) +signDigestedData dsa bytes = do + BS.useAsCStringLen bytes (\(ptr, len) -> do + alloca (\rptr -> do + alloca (\sptr -> do + withDSAPtr dsa (\dsaptr -> do + _dsa_sign dsaptr ptr len rptr sptr >>= failIf (== 0) + r <- peek rptr >>= peekBN + peek rptr >>= _bn_free + s <- peek sptr >>= peekBN + peek sptr >>= _bn_free + return (r, s))))) + +-- | Verify pre-digested data given a signature. +verifyDigestedData :: DSA -> BS.ByteString -> (Integer, Integer) -> IO Bool +verifyDigestedData dsa bytes (r, s) = do + BS.useAsCStringLen bytes (\(ptr, len) -> do + withBN r (\bnR -> do + withBN s (\bnS -> do + withDSAPtr dsa (\dsaptr -> do + _dsa_verify dsaptr ptr len bnR bnS >>= return . (== 1))))) diff --git a/OpenSSL/Utils.hs b/OpenSSL/Utils.hs --- a/OpenSSL/Utils.hs +++ b/OpenSSL/Utils.hs @@ -2,12 +2,15 @@ ( failIfNull , failIf , raiseOpenSSLError + , toHex + , fromHex ) where import Foreign import OpenSSL.ERR - +import Data.Bits ((.&.), (.|.), shiftR, shiftL) +import Data.List (unfoldr) failIfNull :: Ptr a -> IO (Ptr a) failIfNull ptr @@ -25,3 +28,54 @@ raiseOpenSSLError :: IO a raiseOpenSSLError = getError >>= errorString >>= fail + +-- | Convert an integer to a hex string +toHex :: (Bits i) => i -> String +toHex = reverse . map hexByte . unfoldr step where + step 0 = Nothing + step i = Just (i .&. 0xf, i `shiftR` 4) + + hexByte 0 = '0' + hexByte 1 = '1' + hexByte 2 = '2' + hexByte 3 = '3' + hexByte 4 = '4' + hexByte 5 = '5' + hexByte 6 = '6' + hexByte 7 = '7' + hexByte 8 = '8' + hexByte 9 = '9' + hexByte 10 = 'a' + hexByte 11 = 'b' + hexByte 12 = 'c' + hexByte 13 = 'd' + hexByte 14 = 'e' + hexByte 15 = 'f' + +-- | Convert a hex string to an integer +fromHex :: (Bits i) => String -> i +fromHex = foldl step 0 where + step acc hexchar = (acc `shiftL` 4) .|. (byteHex hexchar) + + byteHex '0' = 0 + byteHex '1' = 1 + byteHex '2' = 2 + byteHex '3' = 3 + byteHex '4' = 4 + byteHex '5' = 5 + byteHex '6' = 6 + byteHex '7' = 7 + byteHex '8' = 8 + byteHex '9' = 9 + byteHex 'a' = 10 + byteHex 'b' = 11 + byteHex 'c' = 12 + byteHex 'd' = 13 + byteHex 'e' = 14 + byteHex 'f' = 15 + byteHex 'A' = 10 + byteHex 'B' = 11 + byteHex 'C' = 12 + byteHex 'D' = 13 + byteHex 'E' = 14 + byteHex 'F' = 15 diff --git a/cbits/HsOpenSSL.c b/cbits/HsOpenSSL.c --- a/cbits/HsOpenSSL.c +++ b/cbits/HsOpenSSL.c @@ -181,3 +181,24 @@ CRYPTO_set_dynlock_destroy_callback(HsOpenSSL_dynlockDestroyCallback); } +/* DSA ************************************************************************/ + +/* OpenSSL sadly wants to ASN1 encode the resulting bignums so we use this + * function to skip that. Returns > 0 on success */ +int HsOpenSSL_dsa_sign(DSA *dsa, const unsigned char *ddata, int dlen, + BIGNUM **r, BIGNUM **s) { + DSA_SIG *const sig = dsa->meth->dsa_do_sign(ddata, dlen, dsa); + if (!sig) return 0; + *r = sig->r; + *s = sig->s; + free(sig); + return 1; +} + +int HsOpenSSL_dsa_verify(DSA *dsa, const unsigned char *ddata, int dlen, + BIGNUM *r, BIGNUM *s) { + DSA_SIG sig; + sig.r = r; + sig.s = s; + return dsa->meth->dsa_do_verify(ddata, dlen, &sig, dsa); +} diff --git a/cbits/HsOpenSSL.h b/cbits/HsOpenSSL.h --- a/cbits/HsOpenSSL.h +++ b/cbits/HsOpenSSL.h @@ -14,6 +14,7 @@ #include #include #include +#include /* OpenSSL ********************************************************************/ void HsOpenSSL_OpenSSL_add_all_algorithms(); @@ -59,5 +60,12 @@ /* Threads ********************************************************************/ void HsOpenSSL_setupMutex(); + +/* DSA ************************************************************************/ +int HsOpenSSL_dsa_sign(DSA *dsa, const unsigned char *ddata, int len, + BIGNUM **r, BIGNUM **s); +int HsOpenSSL_dsa_verify(DSA *dsa, const unsigned char *ddata, int len, + BIGNUM *r, BIGNUM *s); + #endif diff --git a/examples/GenRSAKey.hs b/examples/GenRSAKey.hs --- a/examples/GenRSAKey.hs +++ b/examples/GenRSAKey.hs @@ -1,7 +1,5 @@ import Control.Monad hiding (join) import OpenSSL -import OpenSSL.BN -import OpenSSL.BIO import OpenSSL.EVP.PKey import OpenSSL.PEM import OpenSSL.RSA diff --git a/examples/HelloWorld.hs b/examples/HelloWorld.hs --- a/examples/HelloWorld.hs +++ b/examples/HelloWorld.hs @@ -2,7 +2,6 @@ import Data.List import Data.Maybe import OpenSSL -import OpenSSL.BN import OpenSSL.EVP.Cipher import OpenSSL.EVP.Open import OpenSSL.EVP.PKey