hjugement-protocol/src/Voting/Protocol/Arithmetic.hs

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