hjugement-protocol/Protocol/Arithmetic.hs

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