HsOpenSSL-0.3.1: OpenSSL/BN.hs

{-# OPTIONS_GHC -optc-D__GLASGOW_HASKELL__=606 #-}
{-# INCLUDE "HsOpenSSL.h" #-}
{-# LINE 1 "OpenSSL/BN.hsc" #-}

{-# LINE 2 "OpenSSL/BN.hsc" #-}

-- #prune

-- |BN - multiprecision integer arithmetics

module OpenSSL.BN
    ( -- * Type
      BigNum
    , BIGNUM

      -- * Allocation
    , allocaBN
    , withBN

    , newBN
    , wrapBN -- private
    , unwrapBN -- private

      -- * Conversion from\/to Integer
    , peekBN

{-# LINE 23 "OpenSSL/BN.hsc" #-}
    , integerToBN
    , bnToInteger

{-# LINE 26 "OpenSSL/BN.hsc" #-}
    , integerToMPI
    , mpiToInteger

      -- * Computation
    , modexp

      -- * Random number generation
    , randIntegerUptoNMinusOneSuchThat
    , prandIntegerUptoNMinusOneSuchThat
    , randIntegerZeroToNMinusOne
    , prandIntegerZeroToNMinusOne
    , randIntegerOneToNMinusOne
    , prandIntegerOneToNMinusOne
    )
    where

import           Control.Exception
import           Foreign
import qualified Data.ByteString as BS
import           OpenSSL.Utils


{-# LINE 51 "OpenSSL/BN.hsc" #-}
import           Foreign.C.Types
import           Data.Word (Word32)
import           GHC.Base
import           GHC.Num
import           GHC.Prim
import           GHC.IOBase (IO(..))

{-# LINE 58 "OpenSSL/BN.hsc" #-}

-- |'BigNum' is an opaque object representing a big number.
newtype BigNum = BigNum (Ptr BIGNUM)
data BIGNUM


foreign import ccall unsafe "BN_new"
        _new :: IO (Ptr BIGNUM)

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

-- |@'allocaBN' f@ allocates a 'BigNum' and computes @f@. Then it
-- frees the 'BigNum'.
allocaBN :: (BigNum -> IO a) -> IO a
allocaBN m
    = bracket _new _free (m . wrapBN)


unwrapBN :: BigNum -> Ptr BIGNUM
unwrapBN (BigNum p) = p


wrapBN :: Ptr BIGNUM -> BigNum
wrapBN = BigNum



{-# LINE 130 "OpenSSL/BN.hsc" #-}

{- 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 <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) (unwrapBN bn) :: IO CSize
{-# LINE 166 "OpenSSL/BN.hsc" #-}
  case nlimbs of
    0 -> return 0
    1 -> do (I# i) <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) (unwrapBN bn) >>= peek
{-# LINE 169 "OpenSSL/BN.hsc" #-}
            negative <- ((\hsc_ptr -> peekByteOff hsc_ptr 12)) (unwrapBN bn) :: IO Word32
{-# LINE 170 "OpenSSL/BN.hsc" #-}
            if negative == 0
               then return $ S# i
               else return $ 0 - (S# i)
    otherwise -> do
      let (I# nlimbsi) = fromIntegral nlimbs
          (I# limbsize) = ((4))
{-# LINE 176 "OpenSSL/BN.hsc" #-}
      (MBA arr) <- newByteArray (nlimbsi *# limbsize)
      (BA ba) <- freezeByteArray arr
      limbs <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) (unwrapBN bn)
{-# LINE 179 "OpenSSL/BN.hsc" #-}
      _copy_in ba limbs $ fromIntegral $ nlimbs * ((4))
{-# LINE 180 "OpenSSL/BN.hsc" #-}
      negative <- ((\hsc_ptr -> peekByteOff hsc_ptr 12)) (unwrapBN bn) :: IO Word32
{-# LINE 181 "OpenSSL/BN.hsc" #-}
      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 0 = do
  bnptr <- mallocBytes ((20))
{-# LINE 190 "OpenSSL/BN.hsc" #-}
  ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) bnptr nullPtr
{-# LINE 191 "OpenSSL/BN.hsc" #-}
  -- This is needed to give GHC enough type information
  let one :: Word32
      one = 1
      zero :: Word32
      zero = 0
  ((\hsc_ptr -> pokeByteOff hsc_ptr 16)) bnptr one
{-# LINE 197 "OpenSSL/BN.hsc" #-}
  ((\hsc_ptr -> pokeByteOff hsc_ptr 4)) bnptr zero
{-# LINE 198 "OpenSSL/BN.hsc" #-}
  ((\hsc_ptr -> pokeByteOff hsc_ptr 8)) bnptr zero
{-# LINE 199 "OpenSSL/BN.hsc" #-}
  ((\hsc_ptr -> pokeByteOff hsc_ptr 12)) bnptr zero
{-# LINE 200 "OpenSSL/BN.hsc" #-}
  return (wrapBN bnptr)

integerToBN (S# v) = do
  bnptr <- mallocBytes ((20))
{-# LINE 204 "OpenSSL/BN.hsc" #-}
  limbs <- malloc :: IO (Ptr Word32)
  poke limbs $ fromIntegral $ abs $ I# v
  ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) bnptr limbs
{-# LINE 207 "OpenSSL/BN.hsc" #-}
  -- This is needed to give GHC enough type information since #poke just
  -- uses an offset
  let one :: Word32
      one = 1
  ((\hsc_ptr -> pokeByteOff hsc_ptr 16)) bnptr one
{-# LINE 212 "OpenSSL/BN.hsc" #-}
  ((\hsc_ptr -> pokeByteOff hsc_ptr 4)) bnptr one
{-# LINE 213 "OpenSSL/BN.hsc" #-}
  ((\hsc_ptr -> pokeByteOff hsc_ptr 8)) bnptr one
{-# LINE 214 "OpenSSL/BN.hsc" #-}
  ((\hsc_ptr -> pokeByteOff hsc_ptr 12)) bnptr (if (I# v) < 0 then one else 0)
{-# LINE 215 "OpenSSL/BN.hsc" #-}
  return (wrapBN bnptr)

integerToBN v@(J# nlimbs_ bytearray)
  | v >= 0 = do
      let nlimbs = (I# nlimbs_)
      bnptr <- mallocBytes ((20))
{-# LINE 221 "OpenSSL/BN.hsc" #-}
      limbs <- mallocBytes (((4)) * nlimbs)
{-# LINE 222 "OpenSSL/BN.hsc" #-}
      ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) bnptr limbs
{-# LINE 223 "OpenSSL/BN.hsc" #-}
      ((\hsc_ptr -> pokeByteOff hsc_ptr 16)) bnptr (1 :: Word32)
{-# LINE 224 "OpenSSL/BN.hsc" #-}
      _copy_out limbs bytearray (fromIntegral $ ((4)) * nlimbs)
{-# LINE 225 "OpenSSL/BN.hsc" #-}
      ((\hsc_ptr -> pokeByteOff hsc_ptr 4)) bnptr ((fromIntegral nlimbs) :: Word32)
{-# LINE 226 "OpenSSL/BN.hsc" #-}
      ((\hsc_ptr -> pokeByteOff hsc_ptr 8)) bnptr ((fromIntegral nlimbs) :: Word32)
{-# LINE 227 "OpenSSL/BN.hsc" #-}
      ((\hsc_ptr -> pokeByteOff hsc_ptr 12)) bnptr (0 :: Word32)
{-# LINE 228 "OpenSSL/BN.hsc" #-}
      return (wrapBN bnptr)
  | otherwise = do bnptr <- integerToBN (0-v)
                   ((\hsc_ptr -> pokeByteOff hsc_ptr 12)) (unwrapBN bnptr) (1 :: Word32)
{-# LINE 231 "OpenSSL/BN.hsc" #-}
                   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' n f@ converts n to a 'BigNum' and computes @f@. Then it
-- frees the 'BigNum'.
withBN :: Integer -> (BigNum -> IO a) -> IO a
withBN dec m = bracket (integerToBN dec) (_free . unwrapBN) m

-- |This is an alias to 'bnToInteger'.
peekBN :: BigNum -> IO Integer
peekBN = bnToInteger

-- |This is an alias to 'integerToBN'.
newBN :: Integer -> IO BigNum
newBN = integerToBN

foreign import ccall unsafe "BN_bn2mpi"
        _bn2mpi :: Ptr BIGNUM -> Ptr CChar -> IO CInt

foreign import ccall unsafe "BN_mpi2bn"
        _mpi2bn :: Ptr CChar -> CInt -> Ptr BIGNUM -> IO (Ptr BIGNUM)


{-# LINE 258 "OpenSSL/BN.hsc" #-}

-- | Convert a BigNum to an MPI: a serialisation of large ints which has a
--   4-byte, big endian length followed by the bytes of the number in
--   most-significant-first order.
bnToMPI :: BigNum -> IO BS.ByteString
bnToMPI bn = do
  bytes <- _bn2mpi (unwrapBN bn) nullPtr
  allocaBytes (fromIntegral bytes) (\buffer -> do
    _bn2mpi (unwrapBN bn) buffer
    BS.copyCStringLen (buffer, fromIntegral bytes))

-- | Convert an MPI into a BigNum. See bnToMPI for details of the format
mpiToBN :: BS.ByteString -> IO BigNum
mpiToBN mpi = do
  BS.useAsCStringLen mpi (\(ptr, len) -> do
    _mpi2bn ptr (fromIntegral len) nullPtr) >>= return . wrapBN

-- | Convert an Integer to an MPI. SEe bnToMPI for the format
integerToMPI :: Integer -> IO BS.ByteString
integerToMPI v = bracket (integerToBN v) (_free . unwrapBN) bnToMPI

-- | Convert an MPI to an Integer. SEe bnToMPI for the format
mpiToInteger :: BS.ByteString -> IO Integer
mpiToInteger mpi = do
  bn <- mpiToBN mpi
  v <- bnToInteger bn
  _free (unwrapBN bn)
  return v

foreign import ccall unsafe "BN_mod_exp"
        _mod_exp :: Ptr BIGNUM -> Ptr BIGNUM -> Ptr BIGNUM -> Ptr BIGNUM -> BNCtx -> IO (Ptr BIGNUM)

type BNCtx = Ptr BNCTX
data BNCTX = BNCTX

foreign import ccall unsafe "BN_CTX_new"
        _BN_ctx_new :: IO BNCtx

foreign import ccall unsafe "BN_CTX_free"
        _BN_ctx_free :: BNCtx -> IO ()

withBNCtx :: (BNCtx -> IO a) -> IO a
withBNCtx f = bracket _BN_ctx_new _BN_ctx_free f

-- |@'modexp' a p m@ computes @a@ to the @p@-th power modulo @m@.
modexp :: Integer -> Integer -> Integer -> Integer
modexp a p m = unsafePerformIO (do
  withBN a (\bnA -> (do
    withBN p (\bnP -> (do
      withBN m (\bnM -> (do
        withBNCtx (\ctx -> (do
          r <- newBN 0
          _mod_exp (unwrapBN r) (unwrapBN bnA) (unwrapBN bnP) (unwrapBN bnM) ctx
          bnToInteger r >>= return)))))))))

{- Random Integer generation ------------------------------------------------ -}

foreign import ccall unsafe "BN_rand_range"
        _BN_rand_range :: Ptr BIGNUM -> Ptr BIGNUM -> IO CInt

foreign import ccall unsafe "BN_pseudo_rand_range"
        _BN_pseudo_rand_range :: Ptr BIGNUM -> Ptr BIGNUM -> IO CInt

-- | Return a strongly random number in the range 0 <= x < n where the given
--   filter function returns true.
randIntegerUptoNMinusOneSuchThat :: (Integer -> Bool)  -- ^ a filter function
                                 -> Integer  -- ^ one plus the upper limit
                                 -> IO Integer
randIntegerUptoNMinusOneSuchThat f range = withBN range (\bnRange -> (do
  r <- newBN 0
  let try = do
        _BN_rand_range (unwrapBN r) (unwrapBN bnRange) >>= failIf (/= 1)
        i <- bnToInteger r
        if f i
           then return i
           else try
  try))

-- | Return a random number in the range 0 <= x < n where the given
--   filter function returns true.
prandIntegerUptoNMinusOneSuchThat :: (Integer -> Bool)  -- ^ a filter function
                                  -> Integer  -- ^ one plus the upper limit
                                  -> IO Integer
prandIntegerUptoNMinusOneSuchThat f range = withBN range (\bnRange -> (do
  r <- newBN 0
  let try = do
        _BN_rand_range (unwrapBN r) (unwrapBN bnRange) >>= failIf (/= 1)
        i <- bnToInteger r
        if f i
           then return i
           else try
  try))

-- | Return a strongly random number in the range 0 <= x < n
randIntegerZeroToNMinusOne :: Integer -> IO Integer
randIntegerZeroToNMinusOne = randIntegerUptoNMinusOneSuchThat (const True)
-- | Return a strongly random number in the range 0 < x < n
randIntegerOneToNMinusOne :: Integer -> IO Integer
randIntegerOneToNMinusOne = randIntegerUptoNMinusOneSuchThat (/= 0)

-- | Return a random number in the range 0 <= x < n
prandIntegerZeroToNMinusOne :: Integer -> IO Integer
prandIntegerZeroToNMinusOne = prandIntegerUptoNMinusOneSuchThat (const True)
-- | Return a random number in the range 0 < x < n
prandIntegerOneToNMinusOne :: Integer -> IO Integer
prandIntegerOneToNMinusOne = prandIntegerUptoNMinusOneSuchThat (/= 0)