hjugement-protocol/Protocol/Arithmetic.hs

   1 {-# OPTIONS_GHC -fno-warn-orphans #-}
   2 module Protocol.Arithmetic where
   3
   4 import Control.Arrow (first)
   5 import Control.Monad (Monad(..))
   6 import Data.Bits
   7 import Data.Bool
   8 import Data.Eq (Eq(..))
   9 import Data.Foldable (Foldable, foldl', foldMap)
  10 import Data.Function (($), (.))
  11 import Data.Int (Int)
  12 import Data.Maybe (Maybe(..))
  13 import Data.Ord (Ord(..))
  14 import Data.Semigroup (Semigroup(..))
  15 import Data.String (IsString(..))
  16 import Numeric.Natural (Natural)
  17 import Prelude (Integer, Integral(..), fromIntegral, Enum(..))
  18 import Text.Show (Show(..))
  19 import qualified Control.Monad.Trans.State.Strict as S
  20 import qualified Crypto.Hash as Crypto
  21 import qualified Data.ByteArray as ByteArray
  22 import qualified Data.ByteString as BS
  23 import qualified Data.List as List
  24 import qualified Prelude as N
  25 import qualified System.Random as Random
  26
  27 -- * Type 'F'
  28 -- | The type of the elements of a 'PrimeField'.
  29 --
  30 -- A field must satisfy the following properties:
  31 --
  32 -- * @(f, ('+'), 'zero')@ forms an abelian group,
  33 --   called the 'Additive' group of 'f'.
  34 --
  35 -- * @('NonNull' f, ('*'), 'one')@ forms an abelian group,
  36 --   called the 'Multiplicative' group of 'f'.
  37 --
  38 -- * ('*') is associative:
  39 --   @(a'*'b)'*'c == a'*'(b'*'c)@ and
  40 --   @a'*'(b'*'c) == (a'*'b)'*'c@.
  41 --
  42 -- * ('*') and ('+') are both commutative:
  43 --   @a'*'b == b'*'a@ and
  44 --   @a'+'b == b'+'a@
  45 --
  46 -- * ('*') and ('+') are both left and right distributive:
  47 --   @a'*'(b'+'c) == (a'*'b) '+' (a'*'c)@ and
  48 --   @(a'+'b)'*'c == (a'*'c) '+' (b'*'c)@
  49 --
  50 -- The 'Natural' is always within @[0..'fieldCharac'-1]@.
  51 newtype F p = F { unF :: Natural }
  52  deriving (Eq,Ord,Show)
  53
  54 inF :: forall p i. PrimeField p => Integral i => i -> F p
  55 inF i = F (abs (fromIntegral i `mod` fieldCharac @p))
  56         where abs x | x < 0 = x + fieldCharac @p
  57                     | otherwise = x
  58
  59 instance PrimeField p => Additive (F p) where
  60         zero = F 0
  61         F x + F y = F ((x + y) `mod` fieldCharac @p)
  62 instance PrimeField p => Negable (F p) where
  63         neg (F x) | x == 0 = zero
  64                   | otherwise = F (fromIntegral (N.negate (toInteger x) + toInteger (fieldCharac @p)))
  65 instance PrimeField p => Multiplicative (F p) where
  66         one = F 1
  67         -- | Because 'fieldCharac' is prime,
  68         -- all elements of the field are invertible modulo 'fieldCharac'.
  69         F x * F y = F ((x * y) `mod` fieldCharac @p)
  70 instance PrimeField p => Random.Random (F p) where
  71         randomR (F lo, F hi) =
  72                 first (F . fromIntegral) .
  73                 Random.randomR
  74                  ( 0`max`toInteger lo
  75                  , toInteger hi`min`(toInteger (fieldCharac @p) - 1))
  76         random = first (F . fromIntegral) . Random.randomR (0, toInteger (fieldCharac @p) - 1)
  77
  78 -- ** Class 'PrimeField'
  79 -- | Parameter for a prime field.
  80 class PrimeField p where
  81         -- | The prime number characteristic of a 'PrimeField'.
  82         --
  83         -- ElGamal's hardness to decrypt requires a large prime number
  84         -- to form the 'Multiplicative' 'SubGroup'.
  85         fieldCharac :: Natural
  86
  87 -- ** Class 'Additive'
  88 class Additive a where
  89         zero :: a
  90         (+) :: a -> a -> a; infixl 6 +
  91         sum :: Foldable f => f a -> a
  92         sum = foldl' (+) zero
  93 instance Additive Natural where
  94         zero = 0
  95         (+)  = (N.+)
  96 instance Additive Integer where
  97         zero = 0
  98         (+)  = (N.+)
  99 instance Additive Int where
 100         zero = 0
 101         (+)  = (N.+)
 102
 103 -- *** Class 'Negable'
 104 class Additive a => Negable a where
 105         neg :: a -> a
 106         (-) :: a -> a -> a; infixl 6 -
 107         x-y = x + neg y
 108 instance Negable Integer where
 109         neg  = N.negate
 110 instance Negable Int where
 111         neg  = N.negate
 112
 113 -- ** Class 'Multiplicative'
 114 class Multiplicative a where
 115         one :: a
 116         (*) :: a -> a -> a; infixl 7 *
 117 instance Multiplicative Natural where
 118         one = 1
 119         (*) = (N.*)
 120 instance Multiplicative Integer where
 121         one = 1
 122         (*) = (N.*)
 123 instance Multiplicative Int where
 124         one = 1
 125         (*) = (N.*)
 126
 127 -- ** Class 'Invertible'
 128 class Multiplicative a => Invertible a where
 129         inv :: a -> a
 130         (/) :: a -> a -> a; infixl 7 /
 131         x/y = x * inv y
 132
 133 -- * Type 'G'
 134 -- | The type of the elements of a 'Multiplicative' 'SubGroup' of a 'PrimeField'.
 135 newtype G q = G { unG :: F (P q) }
 136  deriving (Eq,Ord,Show)
 137
 138 -- | @('natG' g)@ returns the element of the 'SubGroup' 'g'
 139 -- as an 'Natural' within @[0..'fieldCharac'-1]@.
 140 natG :: SubGroup q => G q -> Natural
 141 natG = unF . unG
 142
 143 instance (SubGroup q, Multiplicative (F (P q))) => Multiplicative (G q) where
 144         one = G one
 145         G x * G y = G (x * y)
 146 instance (SubGroup q, Multiplicative (F (P q))) => Invertible (G q) where
 147         -- | NOTE: add 'groupOrder' so the exponent given to (^) is positive.
 148         inv = (^ E (neg one + groupOrder @q))
 149
 150 -- ** Class 'SubGroupOfPrimeField'
 151 -- | A 'SubGroup' of a 'PrimeField'.
 152 -- Used for signing (Schnorr) and encrypting (ElGamal).
 153 class
 154  ( PrimeField (P q)
 155  , Multiplicative (F (P q))
 156  ) => SubGroup q where
 157         -- | Setting 'q' determines 'p', equals to @'P' q@.
 158         type P q :: *
 159         -- | A generator of the 'SubGroup'.
 160         -- NOTE: since @F p@ is a 'PrimeField',
 161         -- the 'Multiplicative' 'SubGroup' is cyclic,
 162         -- and there are phi('fieldCharac'-1) many choices for the generator of the group,
 163         -- where phi is the Euler totient function.
 164         groupGen :: G q
 165         -- | The order of the 'SubGroup'.
 166         --
 167         -- WARNING: 'groupOrder' MUST be a prime number dividing @('fieldCharac'-1)@
 168         -- to ensure that ensures that ElGamal is secure in terms
 169         -- of the DDH assumption.
 170         groupOrder :: F (P q)
 171
 172         -- | 'groupGenInverses' returns the infinite list
 173         -- of 'inv'erse powers of 'groupGen':
 174         -- @['groupGen' '^' 'neg' i | i <- [0..]]@,
 175         -- but by computing each value from the previous one.
 176         --
 177         -- NOTE: 'groupGenInverses' is in the 'SubGroup' class in order to keep
 178         -- computed terms in memory accross calls to 'groupGenInverses'.
 179         --
 180         -- Used by 'validableEncryption'.
 181         groupGenInverses :: [G q]
 182         groupGenInverses = go one
 183                 where
 184                 go g = g : go (g * invGen)
 185                 invGen = inv groupGen
 186
 187 -- | @('hash' prefix gs)@ returns as a number in @('F' p)@
 188 -- the SHA256 of the given 'prefix' prefixing the decimal representation
 189 -- of given 'SubGroup' elements 'gs', each one postfixed with a comma (",").
 190 --
 191 -- Used by 'proveEncryption' and 'validateEncryption',
 192 -- where the 'prefix' contains the 'statement' to be proven,
 193 -- and the 'gs' contains the 'commitments'.
 194 hash ::
 195  SubGroup q =>
 196  BS.ByteString -> [G q] -> E q
 197 hash prefix gs =
 198         let s = prefix <> foldMap (\(G (F i)) -> fromString (show i) <> fromString ",") gs in
 199         let h = ByteArray.convert (Crypto.hashWith Crypto.SHA256 s) in
 200         inE (BS.foldl' (\acc b -> acc`shiftL`3 + fromIntegral b) (0::Natural) h)
 201
 202 -- * Type 'E'
 203 -- | An exponent of a (necessarily cyclic) 'SubGroup' of a 'PrimeField'.
 204 -- The value is always in @[0..'groupOrder'-1]@.
 205 newtype E q = E { unE :: F (P q) }
 206  deriving (Eq,Ord,Show)
 207
 208 inE :: forall q i. SubGroup q => Integral i => i -> E q
 209 inE i = E (F (abs (fromIntegral i `mod` unF (groupOrder @q))))
 210         where abs x | x < 0 = x + unF (groupOrder @q)
 211                     | otherwise = x
 212
 213 natE :: forall q. SubGroup q => E q -> Natural
 214 natE = unF . unE
 215
 216 instance (SubGroup q, Additive (F (P q))) => Additive (E q) where
 217         zero = E zero
 218         E (F x) + E (F y) = E (F ((x + y) `mod` unF (groupOrder @q)))
 219 instance (SubGroup q, Negable (F (P q))) => Negable (E q) where
 220         neg (E (F x)) | x == 0 = zero
 221                       | otherwise = E (F (fromIntegral ( neg (toInteger x)
 222                                                        + toInteger (unF (groupOrder @q)) )))
 223 instance (SubGroup q, Multiplicative (F (P q))) => Multiplicative (E q) where
 224         one = E one
 225         E (F x) * E (F y) = E (F ((x * y) `mod` unF (groupOrder @q)))
 226 instance SubGroup q => Random.Random (E q) where
 227         randomR (E (F lo), E (F hi)) =
 228                 first (E . F . fromIntegral) .
 229                 Random.randomR
 230                  ( 0`max`toInteger lo
 231                  , toInteger hi`min`(toInteger (unF (groupOrder @q)) - 1) )
 232         random =
 233                 first (E . F . fromIntegral) .
 234                 Random.randomR (0, toInteger (unF (groupOrder @q)) - 1)
 235 instance SubGroup q => Enum (E q) where
 236         toEnum = inE
 237         fromEnum = fromIntegral . natE
 238         enumFromTo lo hi = List.unfoldr
 239          (\i -> if i<=hi then Just (i, i+one) else Nothing) lo
 240
 241 infixr 8 ^
 242 -- | @(b '^' e)@ returns the modular exponentiation of base 'b' by exponent 'e'.
 243 (^) :: SubGroup q => G q -> E q -> G q
 244 (^) b (E (F e))
 245  | e == zero = one
 246  | otherwise = t * (b*b) ^ E (F (e`shiftR`1))
 247         where
 248         t | testBit e 0 = b
 249                 | otherwise   = one
 250
 251 -- * Type 'RandomGen'
 252 type RandomGen = Random.RandomGen
 253
 254 -- | @('randomR' i)@ returns a random integer in @[0..i-1]@.
 255 randomR ::
 256  Monad m =>
 257  RandomGen r =>
 258  Random.Random i =>
 259  Negable i =>
 260  Multiplicative i =>
 261  i -> S.StateT r m i
 262 randomR i = S.StateT $ return . Random.randomR (zero, i-one)
 263
 264 -- | @('random')@ returns a random integer
 265 -- in the range determined by its type.
 266 random ::
 267  Monad m =>
 268  RandomGen r =>
 269  Random.Random i =>
 270  Negable i =>
 271  Multiplicative i =>
 272  S.StateT r m i
 273 random = S.StateT $ return . Random.random
 274
 275 instance Random.Random Natural where
 276         randomR (mini,maxi) =
 277                 first (fromIntegral::Integer -> Natural) .
 278                 Random.randomR (fromIntegral mini, fromIntegral maxi)
 279         random = first (fromIntegral::Integer -> Natural) . Random.random
 280
 281 -- * Groups
 282
 283 -- ** Type 'WeakParams'
 284 -- | Weak parameters for debugging purposes only.
 285 data WeakParams
 286 instance PrimeField WeakParams where
 287         fieldCharac = 263
 288 instance SubGroup WeakParams where
 289         type P WeakParams = WeakParams
 290         groupGen = G (F 2)
 291         groupOrder = F 131
 292
 293 -- ** Type 'BeleniosParams'
 294 -- | Parameters used in Belenios.
 295 -- A 2048-bit 'fieldCharac' of a 'PrimeField',
 296 -- with a 256-bit 'groupOrder' for a 'Multiplicative' 'SubGroup'
 297 -- generated by 'groupGen',
 298 data BeleniosParams
 299 instance PrimeField BeleniosParams where
 300         fieldCharac = 20694785691422546401013643657505008064922989295751104097100884787057374219242717401922237254497684338129066633138078958404960054389636289796393038773905722803605973749427671376777618898589872735865049081167099310535867780980030790491654063777173764198678527273474476341835600035698305193144284561701911000786737307333564123971732897913240474578834468260652327974647951137672658693582180046317922073668860052627186363386088796882120769432366149491002923444346373222145884100586421050242120365433561201320481118852408731077014151666200162313177169372189248078507711827842317498073276598828825169183103125680162072880719
 301 instance SubGroup BeleniosParams where
 302         type P BeleniosParams = BeleniosParams
 303         groupGen = G (F 2402352677501852209227687703532399932712287657378364916510075318787663274146353219320285676155269678799694668298749389095083896573425601900601068477164491735474137283104610458681314511781646755400527402889846139864532661215055797097162016168270312886432456663834863635782106154918419982534315189740658186868651151358576410138882215396016043228843603930989333662772848406593138406010231675095763777982665103606822406635076697764025346253773085133173495194248967754052573659049492477631475991575198775177711481490920456600205478127054728238140972518639858334115700568353695553423781475582491896050296680037745308460627)
 304         groupOrder = F 78571733251071885079927659812671450121821421258408794611510081919805623223441