hjugement-protocol/Protocol/Arithmetic.hs

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