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