diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,5 +1,8 @@ # Changelog +- 0.1.1 (2025-12-27) + * Contains miscellaneous hardening and API refinements to v0.1.1. + - 0.1.0 (2025-12-21) * Initial release, supporting wide, wider, and secp256k1-related Montgomery-form words with supporting constant-time operations. diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -98,9 +98,9 @@ sqrt = let !c2 = 2 :: C.Montgomery !c_big = (2 ^ 255 - 19) :: C.Montgomery - in bgroup "sqrt" [ - bench "curve: sqrt M(2)" $ nf C.sqrt c2 - , bench "curve: sqrt M(2 ^ 255 - 19)" $ nf C.sqrt c_big + in bgroup "sqrt_vartime" [ + bench "curve: sqrt_vartime M(2)" $ nf C.sqrt_vartime c2 + , bench "curve: sqrt_vartime M(2 ^ 255 - 19)" $ nf C.sqrt_vartime c_big ] exp :: Benchmark diff --git a/bench/Weight.hs b/bench/Weight.hs --- a/bench/Weight.hs +++ b/bench/Weight.hs @@ -38,11 +38,11 @@ let !a = 1 !b = 2 !c = 2 ^ 255 - 19 - in wgroup "cmp" $ do - func "cmp: 1 < 2" (W.cmp a) b - func "cmp: 2 < 1" (W.cmp b) a - func "cmp: 2 < 2 ^ 255 - 19" (W.cmp b) c - func "cmp: 2 ^ 255 - 19 < 2" (W.cmp c) b + in wgroup "cmp_vartime" $ do + func "cmp_vartime: 1 < 2" (W.cmp_vartime a) b + func "cmp_vartime: 2 < 1" (W.cmp_vartime b) a + func "cmp_vartime: 2 < 2 ^ 255 - 19" (W.cmp_vartime b) c + func "cmp_vartime: 2 ^ 255 - 19 < 2" (W.cmp_vartime c) b add :: Weigh () add = @@ -124,9 +124,9 @@ sqrt = let !c2 = 2 :: C.Montgomery !c_big = (2 ^ 255 - 19) :: C.Montgomery - in wgroup "sqrt" $ do - func "curve: sqrt M(2)" C.sqrt c2 - func "curve: sqrt M(2 ^ 255 - 19)" C.sqrt c_big + in wgroup "sqrt_vartime" $ do + func "curve: sqrt_vartime M(2)" C.sqrt_vartime c2 + func "curve: sqrt_vartime M(2 ^ 255 - 19)" C.sqrt_vartime c_big redc :: Weigh () redc = diff --git a/lib/Data/Word/Limb.hs b/lib/Data/Word/Limb.hs --- a/lib/Data/Word/Limb.hs +++ b/lib/Data/Word/Limb.hs @@ -285,10 +285,9 @@ :: Limb -> Limb -> Limb -add_s# (Limb a) (Limb b) = case Exts.addWordC# a b of - (# s, 0# #) -> Limb s - _ -> case maxBound :: Word of - Exts.W# m -> Limb m +add_s# (Limb a) (Limb b) = + let !(# c, s #) = Exts.plusWord2# a b + in Limb (C.select_word# s (Exts.not# 0##) (C.from_word_nonzero# c)) {-# INLINE add_s# #-} -- subtraction ---------------------------------------------------------------- @@ -315,9 +314,10 @@ :: Limb -- ^ minuend -> Limb -- ^ subtrahend -> Limb -- ^ difference -sub_s# (Limb m) (Limb n) = case Exts.subWordC# m n of - (# d, 0# #) -> Limb d - _ -> Limb 0## +sub_s# (Limb m) (Limb n) = + let !(# d, b #) = Exts.subWordC# m n + !borrow = C.from_word# (Exts.int2Word# b) + in Limb (C.select_word# d 0## borrow) {-# INLINE sub_s# #-} -- | Wrapping subtraction, computing minuend - subtrahend, returning the @@ -355,9 +355,9 @@ :: Limb -- ^ multiplicand -> Limb -- ^ multiplier -> Limb -- ^ clamped low word of product -mul_s# (Limb a) (Limb b) = case Exts.timesWord2# a b of - (# 0##, l #) -> Limb l - _ -> Limb (Exts.not# 0##) +mul_s# (Limb a) (Limb b) = + let !(# h, l #) = Exts.timesWord2# a b + in Limb (C.select_word# l (Exts.not# 0##) (C.from_word_nonzero# h)) {-# INLINE mul_s# #-} -- | Multiply-add-carry, computing a * b + m + c, returning the diff --git a/lib/Data/Word/Wide.hs b/lib/Data/Word/Wide.hs --- a/lib/Data/Word/Wide.hs +++ b/lib/Data/Word/Wide.hs @@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE UnboxedSums #-} {-# LANGUAGE UnboxedTuples #-} @@ -20,8 +21,8 @@ -- * Construction, Conversion , wide - , to - , from + , to_vartime + , from_vartime -- * Bit Manipulation , or @@ -55,6 +56,7 @@ import Control.DeepSeq import Data.Bits ((.|.), (.&.), (.<<.), (.>>.)) import qualified Data.Bits as B +import qualified Data.Choice as C import Data.Word.Limb (Limb(..)) import qualified Data.Word.Limb as L import GHC.Exts @@ -68,22 +70,33 @@ -- wide words ----------------------------------------------------------------- +pattern Limb2 + :: Word# -> Word# + -> (# Limb, Limb #) +pattern Limb2 w0 w1 = (# Limb w0, Limb w1 #) +{-# COMPLETE Limb2 #-} + -- | Little-endian wide words. data Wide = Wide !(# Limb, Limb #) instance Show Wide where - show = show . from + show = show . from_vartime +-- | Note that 'fromInteger' necessarily runs in variable time due +-- to conversion from the variable-size, potentially heap-allocated +-- 'Integer' type. instance Num Wide where (+) = add (-) = sub (*) = mul abs = id - fromInteger = to + fromInteger = to_vartime negate = neg - signum a = case a of - Wide (# Limb 0##, Limb 0## #) -> 0 - _ -> 1 + signum (Wide (# l0, l1 #)) = + let !(Limb l) = l0 `L.or#` l1 + !n = C.from_word_nonzero# l + !b = C.to_word# n + in Wide (Limb2 b 0##) instance NFData Wide where rnf (Wide a) = case a of (# _, _ #) -> () @@ -95,8 +108,11 @@ wide (W# l) (W# h) = Wide (# Limb l, Limb h #) -- | Convert an 'Integer' to a 'Wide' word. -to :: Integer -> Wide -to n = +-- +-- >>> to_vartime 1 +-- 1 +to_vartime :: Integer -> Wide +to_vartime n = let !size = B.finiteBitSize (0 :: Word) !mask = fi (maxBound :: Word) :: Integer !(W# w0) = fi (n .&. mask) @@ -104,8 +120,11 @@ in Wide (# Limb w0, Limb w1 #) -- | Convert a 'Wide' word to an 'Integer'. -from :: Wide -> Integer -from (Wide (# Limb a, Limb b #)) = +-- +-- >>> from_vartime 1 +-- 1 +from_vartime :: Wide -> Integer +from_vartime (Wide (# Limb a, Limb b #)) = fi (W# b) .<<. (B.finiteBitSize (0 :: Word)) .|. fi (W# a) diff --git a/lib/Data/Word/Wider.hs b/lib/Data/Word/Wider.hs --- a/lib/Data/Word/Wider.hs +++ b/lib/Data/Word/Wider.hs @@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE UnboxedSums #-} {-# LANGUAGE UnboxedTuples #-} @@ -18,12 +19,12 @@ -- * Four-limb words Wider(..) , wider - , to - , from + , to_vartime + , from_vartime -- * Comparison , eq_vartime - , cmp + , cmp_vartime , cmp# , eq# , lt @@ -83,7 +84,7 @@ import qualified Data.Choice as C import Data.Word.Limb (Limb(..)) import qualified Data.Word.Limb as L -import GHC.Exts (Word(..), Int(..), Int#) +import GHC.Exts (Word(..), Int(..), Word#, Int#) import qualified GHC.Exts as Exts import Prelude hiding (div, mod, or, and, not, quot, rem, recip, odd) @@ -95,6 +96,12 @@ -- wider words ---------------------------------------------------------------- +pattern Limb4 + :: Word# -> Word# -> Word# -> Word# + -> (# Limb, Limb, Limb, Limb #) +pattern Limb4 w0 w1 w2 w3 = (# Limb w0, Limb w1, Limb w2, Limb w3 #) +{-# COMPLETE Limb4 #-} + -- | Little-endian wider words, consisting of four 'Limbs'. -- -- >>> 1 :: Wider @@ -102,24 +109,23 @@ data Wider = Wider !(# Limb, Limb, Limb, Limb #) instance Show Wider where - show = show . from - -instance Eq Wider where - Wider a == Wider b = C.decide (eq# a b) - -instance Ord Wider where - compare = cmp + show = show . from_vartime +-- | Note that 'fromInteger' necessarily runs in variable time due +-- to conversion from the variable-size, potentially heap-allocated +-- 'Integer' type. instance Num Wider where (+) = add (-) = sub (*) = mul abs = id - fromInteger = to - negate w = add (not w) (Wider (# Limb 1##, Limb 0##, Limb 0##, Limb 0## #)) - signum a = case a of - Wider (# Limb 0##, Limb 0##, Limb 0##, Limb 0## #) -> 0 - _ -> 1 + fromInteger = to_vartime + negate w = add (not w) (Wider (Limb4 1## 0## 0## 0##)) + signum (Wider (# l0, l1, l2, l3 #)) = + let !(Limb l) = l0 `L.or#` l1 `L.or#` l2 `L.or#` l3 + !n = C.from_word_nonzero# l + !b = C.to_word# n + in Wider (Limb4 b 0## 0## 0##) instance NFData Wider where rnf (Wider a) = case a of @@ -132,8 +138,8 @@ -> (# Limb, Limb, Limb, Limb #) -> C.Choice eq# a b = - let !(# Limb a0, Limb a1, Limb a2, Limb a3 #) = a - !(# Limb b0, Limb b1, Limb b2, Limb b3 #) = b + let !(Limb4 a0 a1 a2 a3) = a + !(Limb4 b0 b1 b2 b3) = b in C.eq_wider# (# a0, a1, a2, a3 #) (# b0, b1, b2, b3 #) {-# INLINE eq# #-} @@ -161,6 +167,13 @@ in C.from_word_mask# bor {-# INLINE lt# #-} +-- | Constant-time less-than comparison between 'Wider' values. +-- +-- >>> import qualified Data.Choice as CT +-- >>> CT.decide (lt 1 2) +-- True +-- >>> CT.decide (lt 1 1) +-- False lt :: Wider -> Wider -> C.Choice lt (Wider a) (Wider b) = lt# a b @@ -173,6 +186,13 @@ in C.from_word_mask# bor {-# INLINE gt# #-} +-- | Constant-time greater-than comparison between 'Wider' values. +-- +-- >>> import qualified Data.Choice as CT +-- >>> CT.decide (gt 1 2) +-- False +-- >>> CT.decide (gt 2 1) +-- True gt :: Wider -> Wider -> C.Choice gt (Wider a) (Wider b) = gt# a b @@ -194,20 +214,23 @@ in (Exts.word2Int# (C.to_word# (L.nonzero# d3))) Exts.*# s {-# INLINE cmp# #-} --- | Constant-time comparison between 'Wider' words. +-- | Variable-time comparison between 'Wider' words. -- --- >>> cmp 1 2 +-- The actual comparison here is performed in constant time, but we must +-- branch to return an 'Ordering'. +-- +-- >>> cmp_vartime 1 2 -- LT --- >>> cmp 2 1 +-- >>> cmp_vartime 2 1 -- GT --- >>> cmp 2 2 +-- >>> cmp_vartime 2 2 -- EQ -cmp :: Wider -> Wider -> Ordering -cmp (Wider a) (Wider b) = case cmp# a b of +cmp_vartime :: Wider -> Wider -> Ordering +cmp_vartime (Wider a) (Wider b) = case cmp# a b of 1# -> GT 0# -> EQ _ -> LT -{-# INLINABLE cmp #-} +{-# INLINABLE cmp_vartime #-} -- construction / conversion -------------------------------------------------- @@ -222,10 +245,10 @@ -- | Convert an 'Integer' to a 'Wider' word. -- --- >>> to 1 +-- >>> to_vartime 1 -- 1 -to :: Integer -> Wider -to n = +to_vartime :: Integer -> Wider +to_vartime n = let !size = B.finiteBitSize (0 :: Word) !mask = fi (maxBound :: Word) :: Integer !(W# w0) = fi (n .&. mask) @@ -236,10 +259,10 @@ -- | Convert a 'Wider' word to an 'Integer'. -- --- >>> from 1 +-- >>> from_vartime 1 -- 1 -from :: Wider -> Integer -from (Wider (# Limb w0, Limb w1, Limb w2, Limb w3 #)) = +from_vartime :: Wider -> Integer +from_vartime (Wider (# Limb w0, Limb w1, Limb w2, Limb w3 #)) = fi (W# w3) .<<. (3 * size) .|. fi (W# w2) .<<. (2 * size) .|. fi (W# w1) .<<. size @@ -483,9 +506,9 @@ -- >>> add_o 1 (2 ^ (256 :: Word) - 1) -- (0,1) add_o - :: Wider - -> Wider - -> (Wider, Word) + :: Wider -- ^ augend + -> Wider -- ^ addend + -> (Wider, Word) -- ^ (sum, carry bit) add_o (Wider a) (Wider b) = let !(# s, Limb c #) = add_o# a b in (Wider s, W# c) diff --git a/lib/Numeric/Montgomery/Secp256k1/Curve.hs b/lib/Numeric/Montgomery/Secp256k1/Curve.hs --- a/lib/Numeric/Montgomery/Secp256k1/Curve.hs +++ b/lib/Numeric/Montgomery/Secp256k1/Curve.hs @@ -19,8 +19,8 @@ -- * Montgomery form, secp256k1 field prime modulus Montgomery(..) , render - , to - , from + , to_vartime + , from_vartime , zero , one @@ -51,11 +51,12 @@ , neg# , inv , inv# - , sqrt + , sqrt_vartime , sqrt# , exp + , exp# , odd# - , odd + , odd_vartime ) where import Control.DeepSeq @@ -66,13 +67,13 @@ import Data.Word.Wider (Wider(..)) import qualified Data.Word.Wider as WW import GHC.Exts (Word(..)) -import Prelude hiding (or, and, not, sqrt, exp, odd) +import Prelude hiding (or, and, not, sqrt, exp) -- montgomery arithmetic, specialized to the secp256k1 field prime modulus -- 0xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEFFFFFC2F -- | Montgomery-form 'Wider' words, on the Montgomery domain defined by --- the secp256k1 scalar group order. +-- the secp256k1 field prime. -- -- >>> let one = 1 :: Montgomery -- >>> one @@ -92,21 +93,23 @@ <> show (W# c) <> ", " <> show (W# d) <> ")" instance Show Montgomery where - show = show . from + show = show . from_vartime +-- | Note that 'fromInteger' necessarily runs in variable time due +-- to conversion from the variable-size, potentially heap-allocated +-- 'Integer' type. instance Num Montgomery where a + b = add a b a - b = sub a b a * b = mul a b negate a = neg a abs = id - fromInteger = to . WW.to - signum a = case a of - Montgomery (# Limb 0##, Limb 0##, Limb 0##, Limb 0## #) -> 0 - _ -> 1 - -instance Eq Montgomery where - a == b = C.decide (eq a b) + fromInteger = to_vartime . WW.to_vartime + signum (Montgomery (# l0, l1, l2, l3 #)) = + let !(Limb l) = l0 `L.or#` l1 `L.or#` l2 `L.or#` l3 + !n = C.from_word_nonzero# l + !b = C.to_word# n + in Montgomery (# Limb b, Limb 0##, Limb 0##, Limb 0## #) instance NFData Montgomery where rnf (Montgomery a) = case a of (# _, _, _, _ #) -> () @@ -144,8 +147,8 @@ -- innards -------------------------------------------------------------------- redc_inner# - :: (# Limb, Limb, Limb, Limb #) -- ^ upper limbs - -> (# Limb, Limb, Limb, Limb #) -- ^ lower limbs + :: (# Limb, Limb, Limb, Limb #) -- ^ upper limbs + -> (# Limb, Limb, Limb, Limb #) -- ^ lower limbs -> (# (# Limb, Limb, Limb, Limb #), Limb #) -- ^ upper limbs, meta-carry redc_inner# (# u0, u1, u2, u3 #) (# l0, l1, l2, l3 #) = let !(# m0, m1, m2, m3 #) = @@ -202,7 +205,7 @@ -> Montgomery -- ^ reduced value redc (Montgomery l) (Montgomery u) = let !res = redc# l u - in (Montgomery res) + in Montgomery res retr_inner# :: (# Limb, Limb, Limb, Limb #) -- ^ value in montgomery form @@ -366,14 +369,14 @@ {-# INLINE to# #-} -- | Convert a 'Wider' word to the Montgomery domain. -to :: Wider -> Montgomery -to (Wider x) = Montgomery (to# x) +to_vartime :: Wider -> Montgomery +to_vartime (Wider x) = Montgomery (to# x) -- | Retrieve a 'Montgomery' word from the Montgomery domain. -- -- This function is a synonym for 'retr'. -from :: Montgomery -> Wider -from = retr +from_vartime :: Montgomery -> Wider +from_vartime = retr add# :: (# Limb, Limb, Limb, Limb #) -- ^ augend @@ -987,24 +990,27 @@ -- | Square root (Tonelli-Shanks) in the Montgomery domain. -- --- For a, return x such that a = x x mod p. Returns nothing if no such --- square root exists. +-- Returns 'Nothing' if the square root doesn't exist. -- --- >>> sqrt 4 +-- Note that the square root calculation itself is performed in +-- constant time; we branch only when casting to 'Maybe' at the end. +-- +-- >>> sqrt_vartime 4 -- Just 2 --- >>> sqrt 15 +-- >>> sqrt_vartime 15 -- Just 69211104694897500952317515077652022726490027694212560352756646854116994689233 --- >>> (*) <$> sqrt 15 <*> sqrt 15 +-- >>> (*) <$> sqrt_vartime 15 <*> sqrt_vartime 15 -- Just 15 -sqrt :: Montgomery -> Maybe Montgomery -sqrt (Montgomery n) = case sqrt# n of - (# a | #) -> Just $! Montgomery a - _ -> Nothing +sqrt_vartime :: Montgomery -> Maybe Montgomery +sqrt_vartime (Montgomery n) = case sqrt# n of + (# a, c #) + | C.decide c -> Just $! Montgomery a + | otherwise -> Nothing -- generated by etc/generate_sqrt.sh sqrt# :: (# Limb, Limb, Limb, Limb #) - -> (# (# Limb, Limb, Limb, Limb #) | () #) + -> (# (# Limb, Limb, Limb, Limb #), C.Choice #) sqrt# a = let !t0 = (# Limb 0x1000003D1##, Limb 0##, Limb 0##, Limb 0## #) !t1 = sqr# t0 @@ -1511,9 +1517,7 @@ !t502 = sqr# t501 !t503 = sqr# t502 !r = t503 - in if C.decide (WW.eq# (sqr# r) a) - then (# r | #) - else (# | () #) + in (# r, WW.eq# (sqr# r) a #) {-# INLINE sqrt# #-} -- | Exponentiation in the Montgomery domain. @@ -1523,31 +1527,42 @@ -- >>> exp 2 10 -- 1024 exp :: Montgomery -> Wider -> Montgomery -exp (Montgomery b) (Wider e) = - let !one# = (# Limb 0x1000003D1##, Limb 0##, Limb 0##, Limb 0## #) - loop !r !_ !_ 0 = r - loop !r !m !ex !n = - let !(# ne, bit #) = WW.shr1_c# ex - !candidate = mul# r m - !nr = select# r candidate bit - !nm = sqr# m - in loop nr nm ne (n - 1) - in Montgomery (loop one# b e (256 :: Word)) +exp (Montgomery b) (Wider e) = Montgomery (exp# b e) +exp# + :: (# Limb, Limb, Limb, Limb #) + -> (# Limb, Limb, Limb, Limb #) + -> (# Limb, Limb, Limb, Limb #) +exp# b e = + let !o = (# Limb 0x1000003D1##, Limb 0##, Limb 0##, Limb 0## #) + loop !r !m !ex n = case n of + 0 -> r + _ -> + let !(# ne, bit #) = WW.shr1_c# ex + !candidate = mul# r m + !nr = select# r candidate bit + !nm = sqr# m + in loop nr nm ne (n - 1) + in loop o b e (256 :: Word) +{-# INLINE exp# #-} + odd# :: (# Limb, Limb, Limb, Limb #) -> C.Choice odd# = WW.odd# -{-# INLINE odd #-} +{-# INLINE odd# #-} -- | Check if a 'Montgomery' value is odd. -- +-- Note that the comparison is performed in constant time, but we +-- branch when converting to 'Bool'. +-- -- >>> odd 1 -- True -- >>> odd 2 -- False -- >>> Data.Word.Wider.odd (retr 3) -- parity is preserved -- True -odd :: Montgomery -> Bool -odd (Montgomery m) = C.decide (odd# m) +odd_vartime :: Montgomery -> Bool +odd_vartime (Montgomery m) = C.decide (odd# m) -- constant-time selection ---------------------------------------------------- diff --git a/lib/Numeric/Montgomery/Secp256k1/Scalar.hs b/lib/Numeric/Montgomery/Secp256k1/Scalar.hs --- a/lib/Numeric/Montgomery/Secp256k1/Scalar.hs +++ b/lib/Numeric/Montgomery/Secp256k1/Scalar.hs @@ -19,8 +19,8 @@ -- * Montgomery form, secp256k1 scalar group order modulus Montgomery(..) , render - , to - , from + , to_vartime + , from_vartime , zero , one @@ -52,8 +52,9 @@ , inv , inv# , exp + , exp# , odd# - , odd + , odd_vartime ) where import Control.DeepSeq @@ -64,7 +65,7 @@ import Data.Word.Wider (Wider(..)) import qualified Data.Word.Wider as WW import GHC.Exts (Word(..)) -import Prelude hiding (or, and, not, exp, odd) +import Prelude hiding (or, and, not, exp) -- montgomery arithmetic, specialized to the secp256k1 scalar group order -- 0xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEBAAEDCE6AF48A03BBFD25E8CD0364141 @@ -80,7 +81,7 @@ data Montgomery = Montgomery !(# Limb, Limb, Limb, Limb #) instance Show Montgomery where - show = show . from + show = show . from_vartime -- | Render a 'Montgomery' value as a 'String', showing its individual -- 'Limb's. @@ -92,19 +93,21 @@ "(" <> show (W# a) <> ", " <> show (W# b) <> ", " <> show (W# c) <> ", " <> show (W# d) <> ")" +-- | Note that 'fromInteger' necessarily runs in variable time due +-- to conversion from the variable-size, potentially heap-allocated +-- 'Integer' type. instance Num Montgomery where a + b = add a b a - b = sub a b a * b = mul a b negate a = neg a abs = id - fromInteger = to . WW.to - signum a = case a of - Montgomery (# Limb 0##, Limb 0##, Limb 0##, Limb 0## #) -> 0 - _ -> 1 - -instance Eq Montgomery where - a == b = C.decide (eq a b) + fromInteger = to_vartime . WW.to_vartime + signum (Montgomery (# l0, l1, l2, l3 #)) = + let !(Limb l) = l0 `L.or#` l1 `L.or#` l2 `L.or#` l3 + !n = C.from_word_nonzero# l + !b = C.to_word# n + in Montgomery (# Limb b, Limb 0##, Limb 0##, Limb 0## #) instance NFData Montgomery where rnf (Montgomery a) = case a of (# _, _, _, _ #) -> () @@ -364,14 +367,14 @@ {-# INLINE to# #-} -- | Convert a 'Wider' word to the Montgomery domain. -to :: Wider -> Montgomery -to (Wider x) = Montgomery (to# x) +to_vartime :: Wider -> Montgomery +to_vartime (Wider x) = Montgomery (to# x) -- | Retrieve a 'Montgomery' word from the Montgomery domain. -- -- This function is a synonym for 'retr'. -from :: Montgomery -> Wider -from = retr +from_vartime :: Montgomery -> Wider +from_vartime = retr add# :: (# Limb, Limb, Limb, Limb #) -- ^ augend @@ -948,32 +951,43 @@ -- >>> exp 2 10 -- 1024 exp :: Montgomery -> Wider -> Montgomery -exp (Montgomery b) (Wider e) = - let !one# = (# Limb 0x402DA1732FC9BEBF##, Limb 0x4551231950B75FC4## - , Limb 0x0000000000000001##, Limb 0x0000000000000000## #) - loop !r !_ !_ 0 = r - loop !r !m !ex !n = - let !(# ne, bit #) = WW.shr1_c# ex - !candidate = mul# r m - !nr = select# r candidate bit - !nm = sqr# m - in loop nr nm ne (n - 1) - in Montgomery (loop one# b e (256 :: Word)) +exp (Montgomery b) (Wider e) = Montgomery (exp# b e) +exp# + :: (# Limb, Limb, Limb, Limb #) + -> (# Limb, Limb, Limb, Limb #) + -> (# Limb, Limb, Limb, Limb #) +exp# b e = + let !o = (# Limb 0x402DA1732FC9BEBF##, Limb 0x4551231950B75FC4## + , Limb 0x0000000000000001##, Limb 0x0000000000000000## #) + loop !r !m !ex n = case n of + 0 -> r + _ -> + let !(# ne, bit #) = WW.shr1_c# ex + !candidate = mul# r m + !nr = select# r candidate bit + !nm = sqr# m + in loop nr nm ne (n - 1) + in loop o b e (256 :: Word) +{-# INLINE exp# #-} + odd# :: (# Limb, Limb, Limb, Limb #) -> C.Choice odd# = WW.odd# -{-# INLINE odd #-} +{-# INLINE odd# #-} -- | Check if a 'Montgomery' value is odd. -- +-- Note that the comparison is performed in constant time, but we +-- branch when converting to 'Bool'. +-- -- >>> odd 1 -- True -- >>> odd 2 -- False -- >>> Data.Word.Wider.odd (retr 3) -- parity is preserved -- True -odd :: Montgomery -> Bool -odd (Montgomery m) = C.decide (odd# m) +odd_vartime :: Montgomery -> Bool +odd_vartime (Montgomery m) = C.decide (odd# m) -- constant-time selection ---------------------------------------------------- diff --git a/ppad-fixed.cabal b/ppad-fixed.cabal --- a/ppad-fixed.cabal +++ b/ppad-fixed.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: ppad-fixed -version: 0.1.0 +version: 0.1.1 synopsis: Large fixed-width words and constant-time arithmetic. license: MIT license-file: LICENSE @@ -56,6 +56,8 @@ ghc-options: -rtsopts -Wall -O2 + if flag(llvm) + ghc-options: -fllvm build-depends: base @@ -72,6 +74,8 @@ ghc-options: -rtsopts -O2 -Wall -fno-warn-orphans + if flag(llvm) + ghc-options: -fllvm build-depends: base @@ -86,6 +90,8 @@ ghc-options: -rtsopts -O2 -Wall -fno-warn-orphans + if flag(llvm) + ghc-options: -fllvm build-depends: base diff --git a/test/Montgomery/Curve.hs b/test/Montgomery/Curve.hs --- a/test/Montgomery/Curve.hs +++ b/test/Montgomery/Curve.hs @@ -11,6 +11,7 @@ tests ) where +import qualified Data.Choice as CT import qualified Data.Word.Wider as W import qualified GHC.Num.Integer as I import GHC.Natural @@ -19,6 +20,10 @@ import qualified Test.Tasty.HUnit as H import qualified Test.Tasty.QuickCheck as Q +-- orphan Eq instance for testing +instance Eq C.Montgomery where + a == b = CT.decide (C.eq a b) + -- generic modular exponentiation -- b ^ e mod m modexp :: Integer -> Natural -> Natural -> Integer @@ -36,12 +41,15 @@ mm = 0xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEFFFFFC2F repr :: H.Assertion -repr = H.assertBool mempty (W.eq_vartime 0 (C.from mm)) +repr = H.assertBool mempty (W.eq_vartime 0 (C.from_vartime mm)) add_case :: String -> W.Wider -> W.Wider -> W.Wider -> H.Assertion add_case t a b s = do - H.assertEqual "sanity" ((W.from a + W.from b) `mod` W.from m) (W.from s) - H.assertBool t (W.eq_vartime s (C.from (C.to a + C.to b))) + H.assertEqual "sanity" + ((W.from_vartime a + W.from_vartime b) `mod` W.from_vartime m) + (W.from_vartime s) + H.assertBool t + (W.eq_vartime s (C.from_vartime (C.to_vartime a + C.to_vartime b))) add :: H.Assertion add = do @@ -61,8 +69,11 @@ sub_case :: String -> W.Wider -> W.Wider -> W.Wider -> H.Assertion sub_case t b a d = do - H.assertEqual "sanity" ((W.from b - W.from a) `mod` W.from m) (W.from d) - H.assertBool t (W.eq_vartime d (C.from (C.to b - C.to a))) + H.assertEqual "sanity" + ((W.from_vartime b - W.from_vartime a) `mod` W.from_vartime m) + (W.from_vartime d) + H.assertBool t + (W.eq_vartime d (C.from_vartime (C.to_vartime b - C.to_vartime a))) sub :: H.Assertion sub = do @@ -81,8 +92,11 @@ mul_case :: String -> W.Wider -> W.Wider -> W.Wider -> H.Assertion mul_case t a b p = do - H.assertEqual "sanity" ((W.from a * W.from b) `mod` W.from m) (W.from p) - H.assertBool t (W.eq_vartime p (C.from (C.to a * C.to b))) + H.assertEqual "sanity" + ((W.from_vartime a * W.from_vartime b) `mod` W.from_vartime m) + (W.from_vartime p) + H.assertBool t + (W.eq_vartime p (C.from_vartime (C.to_vartime a * C.to_vartime b))) mul :: H.Assertion mul = do @@ -105,48 +119,57 @@ 0x000000000000000000000000000000000000000000000001000007A2000E90A1 instance Q.Arbitrary W.Wider where - arbitrary = fmap W.to Q.arbitrary + arbitrary = fmap W.to_vartime Q.arbitrary instance Q.Arbitrary C.Montgomery where - arbitrary = fmap C.to Q.arbitrary + arbitrary = fmap C.to_vartime Q.arbitrary add_matches :: W.Wider -> W.Wider -> Bool add_matches a b = - let ma = C.to a - mb = C.to b - ia = W.from a - ib = W.from b - im = W.from m - in W.eq_vartime (W.to ((ia + ib) `mod` im)) (C.from (ma + mb)) + let ma = C.to_vartime a + mb = C.to_vartime b + ia = W.from_vartime a + ib = W.from_vartime b + im = W.from_vartime m + in W.eq_vartime + (W.to_vartime ((ia + ib) `mod` im)) + (C.from_vartime (ma + mb)) mul_matches :: W.Wider -> W.Wider -> Bool mul_matches a b = - let ma = C.to a - mb = C.to b - ia = W.from a - ib = W.from b - im = W.from m - in W.eq_vartime (W.to ((ia * ib) `mod` im)) (C.from (ma * mb)) + let ma = C.to_vartime a + mb = C.to_vartime b + ia = W.from_vartime a + ib = W.from_vartime b + im = W.from_vartime m + in W.eq_vartime + (W.to_vartime ((ia * ib) `mod` im)) + (C.from_vartime (ma * mb)) sqr_matches :: W.Wider -> Bool sqr_matches a = - let ma = C.to a - ia = W.from a - im = W.from m - in W.eq_vartime (W.to ((ia * ia) `mod` im)) (C.from (C.sqr ma)) + let ma = C.to_vartime a + ia = W.from_vartime a + im = W.from_vartime m + in W.eq_vartime + (W.to_vartime ((ia * ia) `mod` im)) + (C.from_vartime (C.sqr ma)) exp_matches :: C.Montgomery -> W.Wider -> Bool exp_matches a b = - let ia = W.from (C.from a) - nb = fromIntegral (W.from b) - nm = fromIntegral (W.from m) - in W.eq_vartime (W.to (modexp ia nb nm)) (C.from (C.exp a b)) + let ia = W.from_vartime (C.from_vartime a) + nb = fromIntegral (W.from_vartime b) + nm = fromIntegral (W.from_vartime m) + in W.eq_vartime + (W.to_vartime (modexp ia nb nm)) + (C.from_vartime (C.exp a b)) inv_valid :: Q.NonZero C.Montgomery -> Bool inv_valid (Q.NonZero s) = C.eq_vartime (C.inv s * s) 1 odd_correct :: C.Montgomery -> Bool -odd_correct w = C.odd w == I.integerTestBit (W.from (C.from w)) 0 +odd_correct w = + C.odd_vartime w == I.integerTestBit (W.from_vartime (C.from_vartime w)) 0 tests :: TestTree tests = testGroup "montgomery tests (curve)" [ diff --git a/test/Montgomery/Scalar.hs b/test/Montgomery/Scalar.hs --- a/test/Montgomery/Scalar.hs +++ b/test/Montgomery/Scalar.hs @@ -11,6 +11,7 @@ tests ) where +import qualified Data.Choice as CT import qualified Data.Word.Wider as W import qualified GHC.Num.Integer as I import GHC.Natural @@ -19,6 +20,10 @@ import qualified Test.Tasty.HUnit as H import qualified Test.Tasty.QuickCheck as Q +-- orphan Eq instance for testing +instance Eq S.Montgomery where + a == b = CT.decide (S.eq a b) + -- generic modular exponentiation -- b ^ e mod m modexp :: Integer -> Natural -> Natural -> Integer @@ -36,12 +41,15 @@ mm = 0xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEBAAEDCE6AF48A03BBFD25E8CD0364141 repr :: H.Assertion -repr = H.assertBool mempty (W.eq_vartime 0 (S.from mm)) +repr = H.assertBool mempty (W.eq_vartime 0 (S.from_vartime mm)) add_case :: String -> W.Wider -> W.Wider -> W.Wider -> H.Assertion add_case t a b s = do - H.assertEqual "sanity" ((W.from a + W.from b) `mod` W.from m) (W.from s) - H.assertBool t (W.eq_vartime s (S.from (S.to a + S.to b))) + H.assertEqual "sanity" + ((W.from_vartime a + W.from_vartime b) `mod` W.from_vartime m) + (W.from_vartime s) + H.assertBool t + (W.eq_vartime s (S.from_vartime (S.to_vartime a + S.to_vartime b))) add :: H.Assertion add = do @@ -61,8 +69,11 @@ sub_case :: String -> W.Wider -> W.Wider -> W.Wider -> H.Assertion sub_case t b a d = do - H.assertEqual "sanity" ((W.from b - W.from a) `mod` W.from m) (W.from d) - H.assertBool t (W.eq_vartime d (S.from (S.to b - S.to a))) + H.assertEqual "sanity" + ((W.from_vartime b - W.from_vartime a) `mod` W.from_vartime m) + (W.from_vartime d) + H.assertBool t + (W.eq_vartime d (S.from_vartime (S.to_vartime b - S.to_vartime a))) sub :: H.Assertion sub = do @@ -81,8 +92,11 @@ mul_case :: String -> W.Wider -> W.Wider -> W.Wider -> H.Assertion mul_case t a b p = do - H.assertEqual "sanity" ((W.from a * W.from b) `mod` W.from m) (W.from p) - H.assertBool t (W.eq_vartime p (S.from (S.to a * S.to b))) + H.assertEqual "sanity" + ((W.from_vartime a * W.from_vartime b) `mod` W.from_vartime m) + (W.from_vartime p) + H.assertBool t + (W.eq_vartime p (S.from_vartime (S.to_vartime a * S.to_vartime b))) mul :: H.Assertion mul = do @@ -105,42 +119,50 @@ 0x9D671CD581C69BC5E697F5E45BCD07C6741496C20E7CF878896CF21467D7D140 instance Q.Arbitrary W.Wider where - arbitrary = fmap W.to Q.arbitrary + arbitrary = fmap W.to_vartime Q.arbitrary instance Q.Arbitrary S.Montgomery where - arbitrary = fmap S.to Q.arbitrary + arbitrary = fmap S.to_vartime Q.arbitrary add_matches :: W.Wider -> W.Wider -> Bool add_matches a b = - let ma = S.to a - mb = S.to b - ia = W.from a - ib = W.from b - im = W.from m - in W.eq_vartime (W.to ((ia + ib) `mod` im)) (S.from (ma + mb)) + let ma = S.to_vartime a + mb = S.to_vartime b + ia = W.from_vartime a + ib = W.from_vartime b + im = W.from_vartime m + in W.eq_vartime + (W.to_vartime ((ia + ib) `mod` im)) + (S.from_vartime (ma + mb)) mul_matches :: W.Wider -> W.Wider -> Bool mul_matches a b = - let ma = S.to a - mb = S.to b - ia = W.from a - ib = W.from b - im = W.from m - in W.eq_vartime (W.to ((ia * ib) `mod` im)) (S.from (ma * mb)) + let ma = S.to_vartime a + mb = S.to_vartime b + ia = W.from_vartime a + ib = W.from_vartime b + im = W.from_vartime m + in W.eq_vartime + (W.to_vartime ((ia * ib) `mod` im)) + (S.from_vartime (ma * mb)) sqr_matches :: W.Wider -> Bool sqr_matches a = - let ma = S.to a - ia = W.from a - im = W.from m - in W.eq_vartime (W.to ((ia * ia) `mod` im)) (S.from (S.sqr ma)) + let ma = S.to_vartime a + ia = W.from_vartime a + im = W.from_vartime m + in W.eq_vartime + (W.to_vartime ((ia * ia) `mod` im)) + (S.from_vartime (S.sqr ma)) exp_matches :: S.Montgomery -> W.Wider -> Bool exp_matches a b = - let ia = W.from (S.from a) - nb = fromIntegral (W.from b) - nm = fromIntegral (W.from m) - in W.eq_vartime (W.to (modexp ia nb nm)) (S.from (S.exp a b)) + let ia = W.from_vartime (S.from_vartime a) + nb = fromIntegral (W.from_vartime b) + nm = fromIntegral (W.from_vartime m) + in W.eq_vartime + (W.to_vartime (modexp ia nb nm)) + (S.from_vartime (S.exp a b)) inv_valid :: Q.NonZero S.Montgomery -> Bool inv_valid (Q.NonZero s) = S.eq_vartime (S.inv s * s) 1 diff --git a/test/Wider.hs b/test/Wider.hs --- a/test/Wider.hs +++ b/test/Wider.hs @@ -107,17 +107,17 @@ let !a = 0 !b = 1 !c = 2 ^ (256 :: Word) - 1 - H.assertEqual mempty (W.cmp a b) LT - H.assertEqual mempty (W.cmp a c) LT - H.assertEqual mempty (W.cmp b c) LT + H.assertEqual mempty (W.cmp_vartime a b) LT + H.assertEqual mempty (W.cmp_vartime a c) LT + H.assertEqual mempty (W.cmp_vartime b c) LT - H.assertEqual mempty (W.cmp a a) EQ - H.assertEqual mempty (W.cmp b b) EQ - H.assertEqual mempty (W.cmp c c) EQ + H.assertEqual mempty (W.cmp_vartime a a) EQ + H.assertEqual mempty (W.cmp_vartime b b) EQ + H.assertEqual mempty (W.cmp_vartime c c) EQ - H.assertEqual mempty (W.cmp b a) GT - H.assertEqual mempty (W.cmp c a) GT - H.assertEqual mempty (W.cmp c b) GT + H.assertEqual mempty (W.cmp_vartime b a) GT + H.assertEqual mempty (W.cmp_vartime c a) GT + H.assertEqual mempty (W.cmp_vartime c b) GT sqr :: H.Assertion sqr = do @@ -144,10 +144,10 @@ H.assertBool mempty (W.eq_vartime o e) instance Q.Arbitrary W.Wider where - arbitrary = fmap W.to Q.arbitrary + arbitrary = fmap W.to_vartime Q.arbitrary odd_correct :: W.Wider -> Bool -odd_correct w = C.decide (W.odd w) == I.integerTestBit (W.from w) 0 +odd_correct w = C.decide (W.odd w) == I.integerTestBit (W.from_vartime w) 0 tests :: TestTree tests = testGroup "wider tests" [