Restore function powModSecInteger

The function existed in integer-gmp-0.5.1.0 but was removed as
part of integer-gmp2 rewrite in #9281.  This is to bring it back.

Test Plan: Case integerGmpInternals, with GMP 4.3.2 and GMP 6.1.2

Reviewers: austin, hvr, goldfire, bgamari

Reviewed By: bgamari

Subscribers: rwbarton, thomie

Differential Revision: https://phabricator.haskell.org/D3947

4 files changed, 112 insertions, 1 deletions

diff --git a/libraries/integer-gmp/cbits/wrappers.c b/libraries/integer-gmp/cbits/wrappers.c
index 446a681388..8f147ad0c1 100644
--- a/libraries/integer-gmp/cbits/wrappers.c
+++ b/libraries/integer-gmp/cbits/wrappers.c
@@ -11,6 +11,7 @@
 
 #include "HsFFI.h"
 #include "MachDeps.h"
+#include "HsIntegerGmp.h"
 
 #include <assert.h>
 #include <stdbool.h>
@@ -626,7 +627,7 @@ integer_gmp_powm(mp_limb_t rp[], // result
   }
 
   const mpz_t b = CONST_MPZ_INIT(bp, mp_limb_zero_p(bp,bn) ? 0 : bn);
-  const mpz_t e = CONST_MPZ_INIT(ep, mp_limb_zero_p(ep,en) ? 0 : en);
+  const mpz_t e = CONST_MPZ_INIT(ep, en);
   const mpz_t m = CONST_MPZ_INIT(mp, mn);
 
   mpz_t r;
@@ -687,6 +688,64 @@ integer_gmp_powm_word(const mp_limb_t b0, // base
   return integer_gmp_powm1(&b0, !!b0, &e0, !!e0, m0);
 }
 
+/* version of integer_gmp_powm() based on mpz_powm_sec
+ *
+ * With GMP 5.0 or later execution time depends on size of arguments
+ * and size of result.
+ *
+ * 'M' must be odd and 'E' non-negative.
+ */
+mp_size_t
+integer_gmp_powm_sec(mp_limb_t rp[], // result
+                     const mp_limb_t bp[], const mp_size_t bn, // base
+                     const mp_limb_t ep[], const mp_size_t en, // exponent
+                     const mp_limb_t mp[], const mp_size_t mn) // mod
+{
+  assert(!mp_limb_zero_p(mp,mn));
+  assert(mp[0] & 1);
+
+  if ((mn == 1 || mn == -1) && mp[0] == 1) {
+    rp[0] = 0;
+    return 1;
+  }
+
+  if (mp_limb_zero_p(ep,en)) {
+    rp[0] = 1;
+    return 1;
+  }
+
+  assert(en > 0);
+
+  const mpz_t b = CONST_MPZ_INIT(bp, mp_limb_zero_p(bp,bn) ? 0 : bn);
+  const mpz_t e = CONST_MPZ_INIT(ep, en);
+  const mpz_t m = CONST_MPZ_INIT(mp, mn);
+
+  mpz_t r;
+  mpz_init (r);
+
+#if HAVE_SECURE_POWM == 0
+  mpz_powm(r, b, e, m);
+#else
+  mpz_powm_sec(r, b, e, m);
+#endif
+
+  const mp_size_t rn = r[0]._mp_size;
+
+  if (rn) {
+    assert(0 < rn && rn <= mn);
+    memcpy(rp, r[0]._mp_d, rn*sizeof(mp_limb_t));
+  }
+
+  mpz_clear (r);
+
+  if (!rn) {
+    rp[0] = 0;
+    return 1;
+  }
+
+  return rn;
+}
+
 
 /* wrapper around mpz_invert()
  *
diff --git a/libraries/integer-gmp/include/HsIntegerGmp.h.in b/libraries/integer-gmp/include/HsIntegerGmp.h.in
index 4823841881..08ff8dff5f 100644
--- a/libraries/integer-gmp/include/HsIntegerGmp.h.in
+++ b/libraries/integer-gmp/include/HsIntegerGmp.h.in
@@ -9,3 +9,6 @@
 #define GHC_GMP_VERSION_PL @GhcGmpVerPl@
 #define GHC_GMP_VERSION \
     (@GhcGmpVerMj@ * 10000 + @GhcGmpVerMi@ * 100 + @GhcGmpVerPl@)
+
+/* Whether GMP supports mpz_powm_sec */
+#define HAVE_SECURE_POWM @HaveSecurePowm@
diff --git a/libraries/integer-gmp/src/GHC/Integer/GMP/Internals.hs b/libraries/integer-gmp/src/GHC/Integer/GMP/Internals.hs
index 0d8d5720a8..fcf4da541d 100644
--- a/libraries/integer-gmp/src/GHC/Integer/GMP/Internals.hs
+++ b/libraries/integer-gmp/src/GHC/Integer/GMP/Internals.hs
@@ -48,6 +48,7 @@ module GHC.Integer.GMP.Internals
     , lcmInteger
     , sqrInteger
     , powModInteger
+    , powModSecInteger
     , recipModInteger
 
       -- ** Additional conversion operations to 'Integer'
diff --git a/libraries/integer-gmp/src/GHC/Integer/Type.hs b/libraries/integer-gmp/src/GHC/Integer/Type.hs
index 952ff6d3e9..cb1ceec271 100644
--- a/libraries/integer-gmp/src/GHC/Integer/Type.hs
+++ b/libraries/integer-gmp/src/GHC/Integer/Type.hs
@@ -25,6 +25,7 @@
 module GHC.Integer.Type where
 
 #include "MachDeps.h"
+#include "HsIntegerGmp.h"
 
 -- Sanity check as CPP defines are implicitly 0-valued when undefined
 #if !(defined(SIZEOF_LONG) && defined(SIZEOF_HSWORD) \
@@ -1376,6 +1377,32 @@ powModInteger b e m = case m of
     b' = integerToSBigNat b
     e' = integerToSBigNat e
 
+-- | \"@'powModSecInteger' /b/ /e/ /m/@\" computes base @/b/@ raised to
+-- exponent @/e/@ modulo @/m/@. It is required that @/e/ >= 0@ and
+-- @/m/@ is odd.
+--
+-- This is a \"secure\" variant of 'powModInteger' using the
+-- @mpz_powm_sec()@ function which is designed to be resilient to side
+-- channel attacks and is therefore intended for cryptographic
+-- applications.
+--
+-- This primitive is only available when the underlying GMP library
+-- supports it (GMP >= 5). Otherwise, it internally falls back to
+-- @'powModInteger'@, and a warning will be emitted when used.
+--
+-- @since TODO
+{-# NOINLINE powModSecInteger #-}
+powModSecInteger :: Integer -> Integer -> Integer -> Integer
+powModSecInteger b e m = bigNatToInteger (powModSecSBigNat b' e' m')
+  where
+    b' = integerToSBigNat b
+    e' = integerToSBigNat e
+    m' = absSBigNat (integerToSBigNat m)
+
+#if HAVE_SECURE_POWM == 0
+{-# WARNING powModSecInteger "The underlying GMP library does not support a secure version of powModInteger which is side-channel resistant - you need at least GMP version 5 to support this" #-}
+#endif
+
 -- | Version of 'powModInteger' operating on 'BigNat's
 --
 -- @since 1.0.0.0
@@ -1428,6 +1455,27 @@ foreign import ccall unsafe "integer_gmp_powm1"
   integer_gmp_powm1# :: ByteArray# -> GmpSize# -> ByteArray# -> GmpSize#
                         -> GmpLimb# -> GmpLimb#
 
+-- internal non-exported helper
+powModSecSBigNat :: SBigNat -> SBigNat -> BigNat -> BigNat
+powModSecSBigNat b e m@(BN# m#) = runS $ do
+    r@(MBN# r#) <- newBigNat# mn#
+    I# rn_# <- liftIO (integer_gmp_powm_sec# r# b# bn# e# en# m# mn#)
+    let rn# = narrowGmpSize# rn_#
+    case isTrue# (rn# ==# mn#) of
+        False -> unsafeShrinkFreezeBigNat# r rn#
+        True  -> unsafeFreezeBigNat# r
+  where
+    !(BN# b#) = absSBigNat b
+    !(BN# e#) = absSBigNat e
+    bn# = ssizeofSBigNat# b
+    en# = ssizeofSBigNat# e
+    mn# = sizeofBigNat# m
+
+foreign import ccall unsafe "integer_gmp_powm_sec"
+  integer_gmp_powm_sec# :: MutableByteArray# RealWorld
+                           -> ByteArray# -> GmpSize# -> ByteArray# -> GmpSize#
+                           -> ByteArray# -> GmpSize# -> IO GmpSize
+
 
 -- | \"@'recipModInteger' /x/ /m/@\" computes the inverse of @/x/@ modulo @/m/@. If
 -- the inverse exists, the return value @/y/@ will satisfy @0 < /y/ <