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 'SubGroup'
 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 ElGamal is secure in terms of the DDH assumption.
 169         groupOrder :: F (P q)
 170
 171         -- | 'groupGenInverses' returns the infinite list
 172         -- of 'inv'erse powers of 'groupGen':
 173         -- @['groupGen' '^' 'neg' i | i <- [0..]]@,
 174         -- but by computing each value from the previous one.
 175         --
 176         -- NOTE: 'groupGenInverses' is in the 'SubGroup' class in order to keep
 177         -- computed terms in memory across calls to 'groupGenInverses'.
 178         --
 179         -- Used by 'intervalDisjunctions'.
 180         groupGenInverses :: [G q]
 181         groupGenInverses = go one
 182                 where
 183                 go g = g : go (g * invGen)
 184                 invGen = inv groupGen
 185
 186 -- | @('hash' prefix gs)@ returns as a number in @('F' p)@
 187 -- the SHA256 of the given 'prefix' prefixing the decimal representation
 188 -- of given 'SubGroup' elements 'gs', each one postfixed with a comma (",").
 189 --
 190 -- Used by 'proveEncryption' and 'verifyEncryption',
 191 -- where the 'prefix' contains the 'statement' to be proven,
 192 -- and the 'gs' contains the 'commitments'.
 193 hash ::
 194  SubGroup q =>
 195  BS.ByteString -> [G q] -> E q
 196 hash prefix gs =
 197         let s = prefix <> foldMap (\(G (F i)) -> fromString (show i) <> fromString ",") gs in
 198         let h = ByteArray.convert (Crypto.hashWith Crypto.SHA256 s) in
 199         inE (BS.foldl' (\acc b -> acc`shiftL`3 + fromIntegral b) (0::Natural) h)
 200
 201 -- * Type 'E'
 202 -- | An exponent of a (necessarily cyclic) 'SubGroup' of a 'PrimeField'.
 203 -- The value is always in @[0..'groupOrder'-1]@.
 204 newtype E q = E { unE :: F (P q) }
 205  deriving (Eq,Ord,Show)
 206
 207 inE :: forall q i. SubGroup q => Integral i => i -> E q
 208 inE i = E (F (abs (fromIntegral i `mod` unF (groupOrder @q))))
 209         where abs x | x < 0 = x + unF (groupOrder @q)
 210                     | otherwise = x
 211
 212 natE :: forall q. SubGroup q => E q -> Natural
 213 natE = unF . unE
 214
 215 instance (SubGroup q, Additive (F (P q))) => Additive (E q) where
 216         zero = E zero
 217         E (F x) + E (F y) = E (F ((x + y) `mod` unF (groupOrder @q)))
 218 instance (SubGroup q, Negable (F (P q))) => Negable (E q) where
 219         neg (E (F x)) | x == 0 = zero
 220                       | otherwise = E (F (fromIntegral ( neg (toInteger x)
 221                                                        + toInteger (unF (groupOrder @q)) )))
 222 instance (SubGroup q, Multiplicative (F (P q))) => Multiplicative (E q) where
 223         one = E one
 224         E (F x) * E (F y) = E (F ((x * y) `mod` unF (groupOrder @q)))
 225 instance SubGroup q => Random.Random (E q) where
 226         randomR (E (F lo), E (F hi)) =
 227                 first (E . F . fromIntegral) .
 228                 Random.randomR
 229                  ( 0`max`toInteger lo
 230                  , toInteger hi`min`(toInteger (unF (groupOrder @q)) - 1) )
 231         random =
 232                 first (E . F . fromIntegral) .
 233                 Random.randomR (0, toInteger (unF (groupOrder @q)) - 1)
 234 instance SubGroup q => Enum (E q) where
 235         toEnum = inE
 236         fromEnum = fromIntegral . natE
 237         enumFromTo lo hi = List.unfoldr
 238          (\i -> if i<=hi then Just (i, i+one) else Nothing) lo
 239
 240 infixr 8 ^
 241 -- | @(b '^' e)@ returns the modular exponentiation of base 'b' by exponent 'e'.
 242 (^) :: SubGroup q => G q -> E q -> G q
 243 (^) b (E (F e))
 244  | e == zero = one
 245  | otherwise = t * (b*b) ^ E (F (e`shiftR`1))
 246         where
 247         t | testBit e 0 = b
 248                 | otherwise   = one
 249
 250 -- * Type 'RandomGen'
 251 type RandomGen = Random.RandomGen
 252
 253 -- | @('randomR' i)@ returns a random integer in @[0..i-1]@.
 254 randomR ::
 255  Monad m =>
 256  RandomGen r =>
 257  Random.Random i =>
 258  Negable i =>
 259  Multiplicative i =>
 260  i -> S.StateT r m i
 261 randomR i = S.StateT $ return . Random.randomR (zero, i-one)
 262
 263 -- | @('random')@ returns a random integer
 264 -- in the range determined by its type.
 265 random ::
 266  Monad m =>
 267  RandomGen r =>
 268  Random.Random i =>
 269  Negable i =>
 270  Multiplicative i =>
 271  S.StateT r m i
 272 random = S.StateT $ return . Random.random
 273
 274 instance Random.Random Natural where
 275         randomR (mini,maxi) =
 276                 first (fromIntegral::Integer -> Natural) .
 277                 Random.randomR (fromIntegral mini, fromIntegral maxi)
 278         random = first (fromIntegral::Integer -> Natural) . Random.random
 279
 280 -- * Groups
 281
 282 -- ** Type 'WeakParams'
 283 -- | Weak parameters for debugging purposes only.
 284 data WeakParams
 285 instance PrimeField WeakParams where
 286         fieldCharac = 263
 287 instance SubGroup WeakParams where
 288         type P WeakParams = WeakParams
 289         groupGen = G (F 2)
 290         groupOrder = F 131
 291
 292 -- ** Type 'BeleniosParams'
 293 -- | Parameters used in Belenios.
 294 -- A 2048-bit 'fieldCharac' of a 'PrimeField',
 295 -- with a 256-bit 'groupOrder' for a 'Multiplicative' 'SubGroup'
 296 -- generated by 'groupGen'.
 297 data BeleniosParams
 298 instance PrimeField BeleniosParams where
 299         fieldCharac = 20694785691422546401013643657505008064922989295751104097100884787057374219242717401922237254497684338129066633138078958404960054389636289796393038773905722803605973749427671376777618898589872735865049081167099310535867780980030790491654063777173764198678527273474476341835600035698305193144284561701911000786737307333564123971732897913240474578834468260652327974647951137672658693582180046317922073668860052627186363386088796882120769432366149491002923444346373222145884100586421050242120365433561201320481118852408731077014151666200162313177169372189248078507711827842317498073276598828825169183103125680162072880719
 300 instance SubGroup BeleniosParams where
 301         type P BeleniosParams = BeleniosParams
 302         groupGen = G (F 2402352677501852209227687703532399932712287657378364916510075318787663274146353219320285676155269678799694668298749389095083896573425601900601068477164491735474137283104610458681314511781646755400527402889846139864532661215055797097162016168270312886432456663834863635782106154918419982534315189740658186868651151358576410138882215396016043228843603930989333662772848406593138406010231675095763777982665103606822406635076697764025346253773085133173495194248967754052573659049492477631475991575198775177711481490920456600205478127054728238140972518639858334115700568353695553423781475582491896050296680037745308460627)
 303         groupOrder = F 78571733251071885079927659812671450121821421258408794611510081919805623223441