module OpenSSL.DSA
(
DSA
, DSA_
, withDSAPtr
, generateParameters
, generateKey
, generateParametersAndKey
, signDigestedData
, verifyDigestedData
, 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
newtype DSA = DSA (ForeignPtr DSA_)
data DSA_
foreign import ccall unsafe "&DSA_free"
_free :: FunPtr (Ptr DSA_ -> IO ())
foreign import ccall unsafe "DSA_free"
dsa_free :: Ptr DSA_ -> IO ()
foreign import ccall unsafe "BN_free"
_bn_free :: Ptr BIGNUM -> IO ()
foreign import ccall unsafe "DSA_new"
_dsa_new :: IO (Ptr DSA_)
foreign import ccall unsafe "DSA_generate_key"
_dsa_generate_key :: Ptr DSA_ -> IO ()
foreign import ccall unsafe "HsOpenSSL_dsa_sign"
_dsa_sign :: Ptr DSA_ -> CString -> CInt -> Ptr (Ptr BIGNUM) -> Ptr (Ptr BIGNUM) -> IO CInt
foreign import ccall unsafe "HsOpenSSL_dsa_verify"
_dsa_verify :: Ptr DSA_ -> CString -> CInt -> Ptr BIGNUM -> Ptr BIGNUM -> IO CInt
withDSAPtr :: DSA -> (Ptr DSA_ -> IO a) -> IO a
withDSAPtr (DSA ptr) = withForeignPtr ptr
foreign import ccall safe "DSA_generate_parameters"
_generate_params :: CInt -> Ptr CChar -> CInt -> Ptr CInt -> Ptr CInt -> Ptr () -> Ptr () -> IO (Ptr DSA_)
peekDSA :: (Ptr DSA_ -> IO (Ptr BIGNUM)) -> DSA -> IO (Maybe Integer)
peekDSA peeker (DSA dsa) = do
withForeignPtr dsa (\ptr -> do
bn <- peeker ptr
if bn == nullPtr
then return Nothing
else peekBN (wrapBN bn) >>= return . Just)
generateParameters :: Int
-> Maybe BS.ByteString
-> IO (Int, Int, Integer, Integer, Integer)
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 (fromIntegral nbits) seedptr (fromIntegral seedlen) i1 i2 nullPtr nullPtr
failIfNull ptr
itcount <- peek i1
gencount <- peek i2
p <- ((\hsc_ptr -> peekByteOff hsc_ptr 12)) ptr >>= peekBN . wrapBN
q <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) ptr >>= peekBN . wrapBN
g <- ((\hsc_ptr -> peekByteOff hsc_ptr 20)) ptr >>= peekBN . wrapBN
dsa_free ptr
return (fromIntegral itcount, fromIntegral gencount, p, q, g))))
generateKey :: Integer
-> Integer
-> Integer
-> IO DSA
generateKey p q g = do
ptr <- _dsa_new
newBN p >>= return . unwrapBN >>= ((\hsc_ptr -> pokeByteOff hsc_ptr 12)) ptr
newBN q >>= return . unwrapBN >>= ((\hsc_ptr -> pokeByteOff hsc_ptr 16)) ptr
newBN g >>= return . unwrapBN >>= ((\hsc_ptr -> pokeByteOff hsc_ptr 20)) ptr
_dsa_generate_key ptr
newForeignPtr _free ptr >>= return . DSA
dsaP :: DSA -> IO (Maybe Integer)
dsaP = peekDSA ((\hsc_ptr -> peekByteOff hsc_ptr 12))
dsaQ :: DSA -> IO (Maybe Integer)
dsaQ = peekDSA ((\hsc_ptr -> peekByteOff hsc_ptr 16))
dsaG :: DSA -> IO (Maybe Integer)
dsaG = peekDSA ((\hsc_ptr -> peekByteOff hsc_ptr 20))
dsaPublic :: DSA -> IO (Maybe Integer)
dsaPublic = peekDSA ((\hsc_ptr -> peekByteOff hsc_ptr 24))
dsaPrivate :: DSA -> IO (Maybe Integer)
dsaPrivate = peekDSA ((\hsc_ptr -> peekByteOff hsc_ptr 28))
dsaToTuple :: DSA -> IO (Integer, Integer, Integer, Integer, Maybe Integer)
dsaToTuple dsa = do
Just p <- peekDSA ((\hsc_ptr -> peekByteOff hsc_ptr 12)) dsa
Just q <- peekDSA ((\hsc_ptr -> peekByteOff hsc_ptr 16)) dsa
Just g <- peekDSA ((\hsc_ptr -> peekByteOff hsc_ptr 20)) dsa
Just pub <- peekDSA ((\hsc_ptr -> peekByteOff hsc_ptr 24)) dsa
private <- peekDSA ((\hsc_ptr -> peekByteOff hsc_ptr 28)) dsa
return (p, q, g, pub, private)
tupleToDSA :: (Integer, Integer, Integer, Integer, Maybe Integer) -> IO DSA
tupleToDSA (p, q, g, pub, mpriv) = do
ptr <- _dsa_new
newBN p >>= return . unwrapBN >>= ((\hsc_ptr -> pokeByteOff hsc_ptr 12)) ptr
newBN q >>= return . unwrapBN >>= ((\hsc_ptr -> pokeByteOff hsc_ptr 16)) ptr
newBN g >>= return . unwrapBN >>= ((\hsc_ptr -> pokeByteOff hsc_ptr 20)) ptr
newBN pub >>= return . unwrapBN >>= ((\hsc_ptr -> pokeByteOff hsc_ptr 24)) ptr
case mpriv of
Just priv -> newBN priv >>= return . unwrapBN >>= ((\hsc_ptr -> pokeByteOff hsc_ptr 28)) ptr
Nothing -> ((\hsc_ptr -> pokeByteOff hsc_ptr 28)) ptr nullPtr
newForeignPtr _free ptr >>= return . DSA
generateParametersAndKey :: Int
-> Maybe BS.ByteString
-> 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 (fromIntegral nbits) seedptr (fromIntegral seedlen) nullPtr nullPtr nullPtr nullPtr
failIfNull ptr
_dsa_generate_key ptr
newForeignPtr _free ptr >>= return . DSA)
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 (fromIntegral len) rptr sptr >>= failIf (== 0)
r <- peek rptr >>= peekBN . wrapBN
peek rptr >>= _bn_free
s <- peek sptr >>= peekBN . wrapBN
peek sptr >>= _bn_free
return (r, s)))))
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 (fromIntegral len) (unwrapBN bnR) (unwrapBN bnS) >>= return . (== 1)))))