{-# OPTIONS_GHC -optc-D__GLASGOW_HASKELL__=606 #-}
{-# INCLUDE "HsOpenSSL.h" #-}
{-# LINE 1 "OpenSSL/DSA.hsc" #-}
{- -*- haskell -*- -}
{-# LINE 2 "OpenSSL/DSA.hsc" #-}

-- #prune

-- | The Digital Signature Algorithm (FIPS 186-2).
--   See <http://www.openssl.org/docs/crypto/dsa.html>


{-# LINE 9 "OpenSSL/DSA.hsc" #-}

module OpenSSL.DSA
    ( -- * Type
      DSA
    , DSA_ -- private
    , withDSAPtr -- private

      -- * Key and parameter generation
    , generateParameters
    , generateKey
    , generateParametersAndKey

      -- * Signing and verification
    , signDigestedData
    , verifyDigestedData

      -- * Extracting fields of DSA objects
    , dsaP
    , dsaQ
    , dsaG
    , dsaPrivate
    , dsaPublic
    , dsaToTuple
    , tupleToDSA
    ) where

import           Control.Monad
import           Foreign
import           Foreign.C (CString)
import           Foreign.C.Types
import           OpenSSL.BN
import           OpenSSL.Utils
import qualified Data.ByteString as BS

-- | The type of a DSA key, includes parameters p, q, g.
newtype DSA = DSA (ForeignPtr DSA_)

data DSA_

foreign import ccall unsafe "&DSA_free"
        _free :: FunPtr (Ptr DSA_ -> IO ())

foreign import ccall unsafe "DSA_free"
        dsa_free :: Ptr DSA_ -> IO ()

foreign import ccall unsafe "BN_free"
        _bn_free :: Ptr BIGNUM -> IO ()

foreign import ccall unsafe "DSA_new"
        _dsa_new :: IO (Ptr DSA_)

foreign import ccall unsafe "DSA_generate_key"
        _dsa_generate_key :: Ptr DSA_ -> IO ()

foreign import ccall unsafe "HsOpenSSL_dsa_sign"
        _dsa_sign :: Ptr DSA_ -> CString -> Int -> Ptr (Ptr BIGNUM) -> Ptr (Ptr BIGNUM) -> IO Int

foreign import ccall unsafe "HsOpenSSL_dsa_verify"
        _dsa_verify :: Ptr DSA_ -> CString -> Int -> Ptr BIGNUM -> Ptr BIGNUM -> IO Int

withDSAPtr :: DSA -> (Ptr DSA_ -> IO a) -> IO a
withDSAPtr (DSA ptr) = withForeignPtr ptr

foreign import ccall safe "DSA_generate_parameters"
        _generate_params :: Int -> Ptr CChar -> Int -> Ptr CInt -> Ptr CInt -> Ptr () -> Ptr () -> IO (Ptr DSA_)

peekDSA :: (Ptr DSA_ -> IO (Ptr BIGNUM)) -> DSA -> IO (Maybe Integer)
peekDSA peeker (DSA dsa) = do
  withForeignPtr dsa (\ptr -> do
    bn <- peeker ptr
    if bn == nullPtr
       then return Nothing
       else peekBN (wrapBN bn) >>= return . Just)

-- | Generate DSA parameters (*not* a key, but required for a key). This is a
--   compute intensive operation. See FIPS 186-2, app 2. This agrees with the
--   test vectors given in FIP 186-2, app 5
generateParameters :: Int  -- ^ The number of bits in the generated prime: 512 <= x <= 1024
                   -> Maybe BS.ByteString  -- ^ optional seed, its length must be 20 bytes
                   -> IO (Int, Int, Integer, Integer, Integer)  -- ^ (iteration count, generator count, p, q, g)
generateParameters nbits mseed = do
  when (nbits < 512 || nbits > 1024) $ fail "Invalid DSA bit size"
  alloca (\i1 -> do
    alloca (\i2 -> do
      (\x -> case mseed of
                  Nothing -> x (nullPtr, 0)
                  Just seed -> BS.useAsCStringLen seed x) (\(seedptr, seedlen) -> do
        ptr <- _generate_params nbits seedptr seedlen i1 i2 nullPtr nullPtr
        failIfNull ptr
        itcount <- peek i1
        gencount <- peek i2
        p <- ((\hsc_ptr -> peekByteOff hsc_ptr 12)) ptr >>= peekBN . wrapBN
{-# LINE 101 "OpenSSL/DSA.hsc" #-}
        q <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) ptr >>= peekBN . wrapBN
{-# LINE 102 "OpenSSL/DSA.hsc" #-}
        g <- ((\hsc_ptr -> peekByteOff hsc_ptr 20)) ptr >>= peekBN . wrapBN
{-# LINE 103 "OpenSSL/DSA.hsc" #-}
        dsa_free ptr
        return (fromIntegral itcount, fromIntegral gencount, p, q, g))))

{-
-- | This function just runs the example DSA generation, as given in FIP 186-2,
--   app 5. The return values should be:
--   (105,
--    "8df2a494492276aa3d25759bb06869cbeac0d83afb8d0cf7cbb8324f0d7882e5d0762fc5b7210
--     eafc2e9adac32ab7aac49693dfbf83724c2ec0736ee31c80291",
--     "c773218c737ec8ee993b4f2ded30f48edace915f",
--     "626d027839ea0a13413163a55b4cb500299d5522956cefcb3bff10f399ce2c2e71cb9de5fa24
--      babf58e5b79521925c9cc42e9f6f464b088cc572af53e6d78802"), as given at the bottom of
--    page 21
test_generateParameters = do
  let seed = BS.pack [0xd5, 0x01, 0x4e, 0x4b,
                      0x60, 0xef, 0x2b, 0xa8,
                      0xb6, 0x21, 0x1b, 0x40,
                      0x62, 0xba, 0x32, 0x24,
                      0xe0, 0x42, 0x7d, 0xd3]
  (a, b, p, q, g) <- generateParameters 512 $ Just seed
  return (a, toHex p, toHex q, g)
-}

-- | Generate a new DSA key, given valid parameters
generateKey :: Integer  -- ^ p
            -> Integer  -- ^ q
            -> Integer  -- ^ g
            -> IO DSA
generateKey p q g = do
  ptr <- _dsa_new
  newBN p >>= return . unwrapBN >>= ((\hsc_ptr -> pokeByteOff hsc_ptr 12)) ptr
{-# LINE 134 "OpenSSL/DSA.hsc" #-}
  newBN q >>= return . unwrapBN >>= ((\hsc_ptr -> pokeByteOff hsc_ptr 16)) ptr
{-# LINE 135 "OpenSSL/DSA.hsc" #-}
  newBN g >>= return . unwrapBN >>= ((\hsc_ptr -> pokeByteOff hsc_ptr 20)) ptr
{-# LINE 136 "OpenSSL/DSA.hsc" #-}
  _dsa_generate_key ptr
  newForeignPtr _free ptr >>= return . DSA

-- |Return the public prime number of the key.
dsaP :: DSA -> IO (Maybe Integer)
dsaP = peekDSA ((\hsc_ptr -> peekByteOff hsc_ptr 12))
{-# LINE 142 "OpenSSL/DSA.hsc" #-}

-- |Return the public 160-bit subprime, @q | p-1@ of the key.
dsaQ :: DSA -> IO (Maybe Integer)
dsaQ = peekDSA ((\hsc_ptr -> peekByteOff hsc_ptr 16))
{-# LINE 146 "OpenSSL/DSA.hsc" #-}

-- |Return the public generator of subgroup of the key.
dsaG :: DSA -> IO (Maybe Integer)
dsaG = peekDSA ((\hsc_ptr -> peekByteOff hsc_ptr 20))
{-# LINE 150 "OpenSSL/DSA.hsc" #-}

-- |Return the public key @y = g^x@.
dsaPublic :: DSA -> IO (Maybe Integer)
dsaPublic = peekDSA ((\hsc_ptr -> peekByteOff hsc_ptr 24))
{-# LINE 154 "OpenSSL/DSA.hsc" #-}

-- |Return the private key @x@.
dsaPrivate :: DSA -> IO (Maybe Integer)
dsaPrivate = peekDSA ((\hsc_ptr -> peekByteOff hsc_ptr 28))
{-# LINE 158 "OpenSSL/DSA.hsc" #-}

-- | Convert a DSA object to a tuple of its members in the order p, q, g,
--   public, private. If this is a public key, private will be Nothing
dsaToTuple :: DSA -> IO (Integer, Integer, Integer, Integer, Maybe Integer)
dsaToTuple dsa = do
  Just p <- peekDSA ((\hsc_ptr -> peekByteOff hsc_ptr 12)) dsa
{-# LINE 164 "OpenSSL/DSA.hsc" #-}
  Just q <- peekDSA ((\hsc_ptr -> peekByteOff hsc_ptr 16)) dsa
{-# LINE 165 "OpenSSL/DSA.hsc" #-}
  Just g <- peekDSA ((\hsc_ptr -> peekByteOff hsc_ptr 20)) dsa
{-# LINE 166 "OpenSSL/DSA.hsc" #-}
  Just pub <- peekDSA ((\hsc_ptr -> peekByteOff hsc_ptr 24)) dsa
{-# LINE 167 "OpenSSL/DSA.hsc" #-}
  private <- peekDSA ((\hsc_ptr -> peekByteOff hsc_ptr 28)) dsa
{-# LINE 168 "OpenSSL/DSA.hsc" #-}

  return (p, q, g, pub, private)

-- | Convert a tuple of members (in the same format as from dsaToTuple) into a
--   DSA object
tupleToDSA :: (Integer, Integer, Integer, Integer, Maybe Integer) -> IO DSA
tupleToDSA (p, q, g, pub, mpriv) = do
  ptr <- _dsa_new
  newBN p >>= return . unwrapBN >>= ((\hsc_ptr -> pokeByteOff hsc_ptr 12)) ptr
{-# LINE 177 "OpenSSL/DSA.hsc" #-}
  newBN q >>= return . unwrapBN >>= ((\hsc_ptr -> pokeByteOff hsc_ptr 16)) ptr
{-# LINE 178 "OpenSSL/DSA.hsc" #-}
  newBN g >>= return . unwrapBN >>= ((\hsc_ptr -> pokeByteOff hsc_ptr 20)) ptr
{-# LINE 179 "OpenSSL/DSA.hsc" #-}
  newBN pub >>= return . unwrapBN >>= ((\hsc_ptr -> pokeByteOff hsc_ptr 24)) ptr
{-# LINE 180 "OpenSSL/DSA.hsc" #-}
  case mpriv of
       Just priv -> newBN priv >>= return . unwrapBN >>= ((\hsc_ptr -> pokeByteOff hsc_ptr 28)) ptr
{-# LINE 182 "OpenSSL/DSA.hsc" #-}
       Nothing -> ((\hsc_ptr -> pokeByteOff hsc_ptr 28)) ptr nullPtr
{-# LINE 183 "OpenSSL/DSA.hsc" #-}
  newForeignPtr _free ptr >>= return . DSA

-- | A utility function to generate both the parameters and the key pair at the
--   same time. Saves serialising and deserialising the parameters too
generateParametersAndKey :: Int  -- ^ The number of bits in the generated prime: 512 <= x <= 1024
                         -> Maybe BS.ByteString  -- ^ optional seed, its length must be 20 bytes
                         -> IO DSA
generateParametersAndKey nbits mseed = do
  (\x -> case mseed of
              Nothing -> x (nullPtr, 0)
              Just seed -> BS.useAsCStringLen seed x) (\(seedptr, seedlen) -> do
    ptr <- _generate_params nbits seedptr seedlen nullPtr nullPtr nullPtr nullPtr
    failIfNull ptr
    _dsa_generate_key ptr
    newForeignPtr _free ptr >>= return . DSA)

-- | Sign pre-digested data. The DSA specs call for SHA1 to be used so, if you
--   use anything else, YMMV. Returns a pair of Integers which, together, are
--   the signature
signDigestedData :: DSA -> BS.ByteString -> IO (Integer, Integer)
signDigestedData dsa bytes = do
  BS.useAsCStringLen bytes (\(ptr, len) -> do
    alloca (\rptr -> do
      alloca (\sptr -> do
        withDSAPtr dsa (\dsaptr -> do
          _dsa_sign dsaptr ptr len rptr sptr >>= failIf (== 0)
          r <- peek rptr >>= peekBN . wrapBN
          peek rptr >>= _bn_free
          s <- peek sptr >>= peekBN . wrapBN
          peek sptr >>= _bn_free
          return (r, s)))))

-- | Verify pre-digested data given a signature.
verifyDigestedData :: DSA -> BS.ByteString -> (Integer, Integer) -> IO Bool
verifyDigestedData dsa bytes (r, s) = do
  BS.useAsCStringLen bytes (\(ptr, len) -> do
    withBN r (\bnR -> do
      withBN s (\bnS -> do
        withDSAPtr dsa (\dsaptr -> do
          _dsa_verify dsaptr ptr len (unwrapBN bnR) (unwrapBN bnS) >>= return . (== 1)))))