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

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