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

   1 {-# LANGUAGE DeriveAnyClass #-}
   2 {-# LANGUAGE DeriveGeneric #-}
   3 {-# LANGUAGE DerivingStrategies #-}
   4 {-# LANGUAGE OverloadedStrings #-}
   5 {-# LANGUAGE UndecidableInstances #-} -- for Reifies instances
   6 {-# OPTIONS_GHC -fno-warn-orphans #-}
   7 -- | Finite Field Cryptography (FFC)
   8 -- is a method of implementing discrete logarithm cryptography
   9 -- using finite field mathematics.
  10 module Voting.Protocol.FFC
  11  ( module Voting.Protocol.FFC
  12  , Natural
  13  , Random.RandomGen
  14  , Reifies(..), reify
  15  , Proxy(..)
  16  ) where
  17
  18 import Control.Arrow (first)
  19 import Control.DeepSeq (NFData)
  20 import Control.Monad (Monad(..), unless)
  21 import Data.Aeson (ToJSON(..),FromJSON(..),(.:),(.:?),(.=))
  22 import Data.Bits
  23 import Data.Bool
  24 import Data.Either (Either(..))
  25 import Data.Eq (Eq(..))
  26 import Data.Foldable (Foldable, foldl')
  27 import Data.Function (($), (.), id)
  28 import Data.Functor ((<$>))
  29 import Data.Int (Int)
  30 import Data.Maybe (Maybe(..), fromMaybe, fromJust)
  31 import Data.Ord (Ord(..))
  32 import Data.Proxy (Proxy(..))
  33 import Data.Reflection (Reifies(..), reify)
  34 import Data.Semigroup (Semigroup(..))
  35 import Data.String (IsString(..))
  36 import Data.Text (Text)
  37 import GHC.Generics (Generic)
  38 import GHC.Natural (minusNaturalMaybe)
  39 import Numeric.Natural (Natural)
  40 import Prelude (Integer, Integral(..), fromIntegral, Enum(..))
  41 import Text.Read (readMaybe, readEither)
  42 import Text.Show (Show(..))
  43 import qualified Control.Monad.Trans.State.Strict as S
  44 import qualified Crypto.Hash as Crypto
  45 import qualified Data.Aeson as JSON
  46 import qualified Data.Aeson.Types as JSON
  47 import qualified Data.ByteArray as ByteArray
  48 import qualified Data.ByteString as BS
  49 import qualified Data.Char as Char
  50 import qualified Data.List as List
  51 import qualified Data.Text as Text
  52 import qualified Data.Text.Lazy as TL
  53 import qualified Data.Text.Lazy.Builder as TLB
  54 import qualified Data.Text.Lazy.Builder.Int as TLB
  55 import qualified Prelude as Num
  56 import qualified System.Random as Random
  57
  58 -- * Type 'FFC'
  59 -- | Mutiplicative Sub-Group of a Finite Prime Field.
  60 --
  61 -- NOTE: an 'FFC' term-value is brought into the context of many functions
  62 -- through a type-variable @c@ whose 'Reifies' constraint enables to 'reflect'
  63 -- that 'FFC' at the term-level (a surprising technique but a very useful one).
  64 -- Doing like this is simpler than working in a 'Monad' (like a 'Reader'),
  65 -- and enables that 'FFC' term to be used simply in instances' methods
  66 -- not supporting an inner 'Monad', like 'parseJSON', 'randomR', 'fromEnum' or 'arbitrary'.
  67 -- Aside from that, the sharing of 'FFC' amongst several types
  68 -- is encoded at the type-level by including @c@
  69 -- as a phantom type of 'F', 'G' and 'E'.
  70 data FFC = FFC
  71  {   ffc_name :: Text
  72  ,   ffc_fieldCharac :: !Natural
  73      -- ^ The prime number characteristic of a Finite Prime Field.
  74      --
  75      -- ElGamal's hardness to decrypt requires a large prime number
  76      -- to form the 'Multiplicative' subgroup.
  77  ,   ffc_groupGen :: !Natural
  78      -- ^ A generator of the 'Multiplicative' subgroup of the Finite Prime Field.
  79      --
  80      -- NOTE: since 'ffc_fieldCharac' is prime,
  81      -- the 'Multiplicative' subgroup is cyclic,
  82      -- and there are phi('fieldCharac'-1) many choices for the generator of the group,
  83      -- where phi is the Euler totient function.
  84  ,   ffc_groupOrder :: !Natural
  85      -- ^ The order of the subgroup.
  86      --
  87      -- WARNING: 'ffc_groupOrder' MUST be a prime number dividing @('ffc_fieldCharac'-1)@
  88      -- to ensure that ElGamal is secure in terms of the DDH assumption.
  89  } deriving (Eq,Show,Generic,NFData)
  90 instance ToJSON FFC where
  91         toJSON FFC{..} =
  92                 JSON.object
  93                  [ "name" .= ffc_name
  94                  , "p"    .= show ffc_fieldCharac
  95                  , "g"    .= show ffc_groupGen
  96                  , "q"    .= show ffc_groupOrder
  97                  ]
  98         toEncoding FFC{..} =
  99                 JSON.pairs
 100                  (  "name" .= ffc_name
 101                  <> "p"    .= show ffc_fieldCharac
 102                  <> "g"    .= show ffc_groupGen
 103                  <> "q"    .= show ffc_groupOrder
 104                  )
 105 instance FromJSON FFC where
 106         parseJSON = JSON.withObject "FFC" $ \o -> do
 107                 ffc_name <- fromMaybe "" <$> (o .:? "name")
 108                 p <- o .: "p"
 109                 g <- o .: "g"
 110                 q <- o .: "q"
 111                 -- TODO: check p is probable prime
 112                 -- TODO: check q is probable prime
 113                 ffc_fieldCharac <- case readEither (Text.unpack p) of
 114                  Left err -> JSON.typeMismatch ("FFC: fieldCharac: "<>err) (JSON.String p)
 115                  Right a -> return a
 116                 ffc_groupGen <- case readEither (Text.unpack g) of
 117                  Left err -> JSON.typeMismatch ("FFC: groupGen: "<>err) (JSON.String g)
 118                  Right a -> return a
 119                 ffc_groupOrder <- case readEither (Text.unpack q) of
 120                  Left err -> JSON.typeMismatch ("FFC: groupOrder: "<>err) (JSON.String q)
 121                  Right a -> return a
 122                 unless (nat ffc_groupGen < ffc_fieldCharac) $
 123                         JSON.typeMismatch "FFC: groupGen is not lower than fieldCharac" (JSON.Object o)
 124                 unless (ffc_groupOrder < ffc_fieldCharac) $
 125                         JSON.typeMismatch "FFC: groupOrder is not lower than fieldCharac" (JSON.Object o)
 126                 unless (nat ffc_groupGen > 1) $
 127                         JSON.typeMismatch "FFC: groupGen is not greater than 1" (JSON.Object o)
 128                 unless (fromJust (ffc_fieldCharac`minusNaturalMaybe`one) `rem` ffc_groupOrder == 0) $
 129                         JSON.typeMismatch "FFC: groupOrder does not divide fieldCharac-1" (JSON.Object o)
 130                 return FFC{..}
 131
 132 fieldCharac :: forall c. Reifies c FFC => Natural
 133 fieldCharac = ffc_fieldCharac (reflect (Proxy::Proxy c))
 134
 135 groupGen :: forall c. Reifies c FFC => G c
 136 groupGen = G $ F $ ffc_groupGen (reflect (Proxy::Proxy c))
 137
 138 groupOrder :: forall c. Reifies c FFC => Natural
 139 groupOrder = ffc_groupOrder (reflect (Proxy::Proxy c))
 140
 141 -- ** Examples
 142 -- | Weak parameters for debugging purposes only.
 143 weakFFC :: FFC
 144 weakFFC = FFC
 145  { ffc_name        = "weakFFC"
 146  , ffc_fieldCharac = 263
 147  , ffc_groupGen    = 2
 148  , ffc_groupOrder  = 131
 149  }
 150
 151 -- | Parameters used in Belenios.
 152 -- A 2048-bit 'fieldCharac' of a Finite Prime Field,
 153 -- with a 256-bit 'groupOrder' for a 'Multiplicative' subgroup
 154 -- generated by 'groupGen'.
 155 beleniosFFC :: FFC
 156 beleniosFFC = FFC
 157  { ffc_name        = "beleniosFFC"
 158  , ffc_fieldCharac = 20694785691422546401013643657505008064922989295751104097100884787057374219242717401922237254497684338129066633138078958404960054389636289796393038773905722803605973749427671376777618898589872735865049081167099310535867780980030790491654063777173764198678527273474476341835600035698305193144284561701911000786737307333564123971732897913240474578834468260652327974647951137672658693582180046317922073668860052627186363386088796882120769432366149491002923444346373222145884100586421050242120365433561201320481118852408731077014151666200162313177169372189248078507711827842317498073276598828825169183103125680162072880719
 159  , ffc_groupGen    =  2402352677501852209227687703532399932712287657378364916510075318787663274146353219320285676155269678799694668298749389095083896573425601900601068477164491735474137283104610458681314511781646755400527402889846139864532661215055797097162016168270312886432456663834863635782106154918419982534315189740658186868651151358576410138882215396016043228843603930989333662772848406593138406010231675095763777982665103606822406635076697764025346253773085133173495194248967754052573659049492477631475991575198775177711481490920456600205478127054728238140972518639858334115700568353695553423781475582491896050296680037745308460627
 160  , ffc_groupOrder  = 78571733251071885079927659812671450121821421258408794611510081919805623223441
 161  }
 162
 163 -- * Type 'F'
 164 -- | The type of the elements of a Finite Prime Field.
 165 --
 166 -- A field must satisfy the following properties:
 167 --
 168 -- * @(f, ('+'), 'zero')@ forms an abelian group,
 169 --   called the 'Additive' group of 'f'.
 170 --
 171 -- * @('NonNull' f, ('*'), 'one')@ forms an abelian group,
 172 --   called the 'Multiplicative' group of 'f'.
 173 --
 174 -- * ('*') is associative:
 175 --   @(a'*'b)'*'c == a'*'(b'*'c)@ and
 176 --   @a'*'(b'*'c) == (a'*'b)'*'c@.
 177 --
 178 -- * ('*') and ('+') are both commutative:
 179 --   @a'*'b == b'*'a@ and
 180 --   @a'+'b == b'+'a@
 181 --
 182 -- * ('*') and ('+') are both left and right distributive:
 183 --   @a'*'(b'+'c) == (a'*'b) '+' (a'*'c)@ and
 184 --   @(a'+'b)'*'c == (a'*'c) '+' (b'*'c)@
 185 --
 186 -- The 'Natural' is always within @[0..'fieldCharac'-1]@.
 187 newtype F c = F { unF :: Natural }
 188  deriving (Eq,Ord,Show)
 189  deriving newtype NFData
 190 instance ToJSON (F c) where
 191         toJSON (F x) = JSON.toJSON (show x)
 192 instance Reifies c FFC => FromJSON (F c) where
 193         parseJSON (JSON.String s)
 194          | Just (c0,_) <- Text.uncons s
 195          , c0 /= '0'
 196          , Text.all Char.isDigit s
 197          , Just x <- readMaybe (Text.unpack s)
 198          , x < fieldCharac @c
 199          = return (F x)
 200         parseJSON json = JSON.typeMismatch "F" json
 201 instance Reifies c FFC => FromNatural (F c) where
 202         fromNatural i = F $ abs $ i `mod` fieldCharac @c
 203                 where
 204                 abs x | x < 0 = x + fieldCharac @c
 205                       | otherwise = x
 206 instance ToNatural (F c) where
 207         nat = unF
 208 instance Reifies c FFC => Additive (F c) where
 209         zero = F 0
 210         F x + F y = F $ (x + y) `mod` fieldCharac @c
 211 instance Reifies c FFC => Negable (F c) where
 212         neg (F x)
 213          | x == 0 = zero
 214          | otherwise = F $ fromJust $ nat (fieldCharac @c)`minusNaturalMaybe`x
 215 instance Reifies c FFC => Multiplicative (F c) where
 216         one = F 1
 217         F x * F y = F $ (x * y) `mod` fieldCharac @c
 218 instance Reifies c FFC => Random.Random (F c) where
 219         randomR (F lo, F hi) =
 220                 first (F . fromIntegral) .
 221                 Random.randomR
 222                  ( 0`max`toInteger lo
 223                  , toInteger hi`min`(toInteger (fieldCharac @c) - 1) )
 224         random =
 225                 first (F . fromIntegral) .
 226                 Random.randomR (0, toInteger (fieldCharac @c) - 1)
 227
 228 -- ** Class 'Additive'
 229 class Additive a where
 230         zero :: a
 231         (+) :: a -> a -> a; infixl 6 +
 232         sum :: Foldable f => f a -> a
 233         sum = foldl' (+) zero
 234 instance Additive Natural where
 235         zero = 0
 236         (+)  = (Num.+)
 237 instance Additive Integer where
 238         zero = 0
 239         (+)  = (Num.+)
 240 instance Additive Int where
 241         zero = 0
 242         (+)  = (Num.+)
 243
 244 -- *** Class 'Negable'
 245 class Additive a => Negable a where
 246         neg :: a -> a
 247         (-) :: a -> a -> a; infixl 6 -
 248         x-y = x + neg y
 249 instance Negable Integer where
 250         neg  = Num.negate
 251 instance Negable Int where
 252         neg  = Num.negate
 253
 254 -- ** Class 'Multiplicative'
 255 class Multiplicative a where
 256         one :: a
 257         (*) :: a -> a -> a; infixl 7 *
 258 instance Multiplicative Natural where
 259         one = 1
 260         (*) = (Num.*)
 261 instance Multiplicative Integer where
 262         one = 1
 263         (*) = (Num.*)
 264 instance Multiplicative Int where
 265         one = 1
 266         (*) = (Num.*)
 267
 268 -- ** Class 'Invertible'
 269 class Multiplicative a => Invertible a where
 270         inv :: a -> a
 271         (/) :: a -> a -> a; infixl 7 /
 272         x/y = x * inv y
 273
 274 -- * Type 'G'
 275 -- | The type of the elements of a 'Multiplicative' subgroup of a Finite Prime Field.
 276 newtype G c = G { unG :: F c }
 277  deriving (Eq,Ord,Show)
 278  deriving newtype NFData
 279 instance ToJSON (G c) where
 280         toJSON (G x) = JSON.toJSON x
 281 instance Reifies c FFC => FromJSON (G c) where
 282         parseJSON (JSON.String s)
 283          | Just (c0,_) <- Text.uncons s
 284          , c0 /= '0'
 285          , Text.all Char.isDigit s
 286          , Just x <- readMaybe (Text.unpack s)
 287          , x < fieldCharac @c
 288          , r <- G (F x)
 289          , r ^ E (groupOrder @c) == one
 290          = return r
 291         parseJSON json = JSON.typeMismatch "G" json
 292 instance Reifies c FFC => FromNatural (G c) where
 293         fromNatural = G . fromNatural
 294 instance ToNatural (G c) where
 295         nat = unF . unG
 296 instance Reifies c FFC => Multiplicative (G c) where
 297         one = G $ F one
 298         G x * G y = G (x * y)
 299 instance Reifies c FFC => Invertible (G c) where
 300         -- | NOTE: add 'groupOrder' so the exponent given to (^) is positive.
 301         inv = (^ E (fromJust $ groupOrder @c`minusNaturalMaybe`1))
 302
 303 -- | 'groupGenInverses' returns the infinite list
 304 -- of 'inv'erse powers of 'groupGen':
 305 -- @['groupGen' '^' 'neg' i | i <- [0..]]@,
 306 -- but by computing each value from the previous one.
 307 --
 308 -- Used by 'intervalDisjunctions'.
 309 groupGenInverses :: forall c. Reifies c FFC => [G c]
 310 groupGenInverses = go one
 311         where
 312         invGen = inv $ groupGen @c
 313         go g = g : go (g * invGen)
 314
 315 groupGenPowers :: forall c. Reifies c FFC => [G c]
 316 groupGenPowers = go one
 317         where go g = g : go (g * groupGen @c)
 318
 319 -- | @('hash' bs gs)@ returns as a number in 'E'
 320 -- the 'Crypto.SHA256' hash of the given 'BS.ByteString' 'bs'
 321 -- prefixing the decimal representation of given subgroup elements 'gs',
 322 -- with a comma (",") intercalated between them.
 323 --
 324 -- NOTE: to avoid any collision when the 'hash' function is used in different contexts,
 325 -- a message 'gs' is actually prefixed by a 'bs' indicating the context.
 326 --
 327 -- Used by 'proveEncryption' and 'verifyEncryption',
 328 -- where the 'bs' usually contains the 'statement' to be proven,
 329 -- and the 'gs' contains the 'commitments'.
 330 hash :: Reifies c FFC => BS.ByteString -> [G c] -> E c
 331 hash bs gs = do
 332         let s = bs <> BS.intercalate (fromString ",") (bytesNat <$> gs)
 333         let h = Crypto.hashWith Crypto.SHA256 s
 334         fromNatural $
 335                 decodeBigEndian $ ByteArray.convert h
 336
 337 -- | @('hexHash' bs)@ returns the 'Crypto.SHA256' hash
 338 -- of the given 'BS.ByteString' 'bs', escaped in hexadecimal
 339 -- into a 'Text' of 32 lowercase characters.
 340 --
 341 -- Used (in retro-dependencies of this library) to hash
 342 -- the 'PublicKey' of a voter or a trustee.
 343 hexHash :: BS.ByteString -> Text
 344 hexHash bs =
 345         let h = Crypto.hashWith Crypto.SHA256 bs in
 346         let n = decodeBigEndian $ ByteArray.convert h in
 347         -- NOTE: always set the 256 bit then remove it
 348         -- to always have leading zeros,
 349         -- and thus always 64 characters wide hashes.
 350         TL.toStrict $
 351         TL.tail $ TLB.toLazyText $ TLB.hexadecimal $
 352         setBit n 256
 353
 354 -- | @('decodeBigEndian' bs)@ interpret @bs@ as big-endian number.
 355 decodeBigEndian :: BS.ByteString -> Natural
 356 decodeBigEndian =
 357         BS.foldl'
 358          (\acc b -> acc`shiftL`8 + fromIntegral b)
 359          (0::Natural)
 360
 361 -- * Type 'E'
 362 -- | An exponent of a (necessarily cyclic) subgroup of a Finite Prime Field.
 363 -- The value is always in @[0..'groupOrder'-1]@.
 364 newtype E c = E { unE :: Natural }
 365  deriving (Eq,Ord,Show)
 366  deriving newtype NFData
 367 instance ToJSON (E c) where
 368         toJSON (E x) = JSON.toJSON (show x)
 369 instance Reifies c FFC => FromJSON (E c) where
 370         parseJSON (JSON.String s)
 371          | Just (c0,_) <- Text.uncons s
 372          , c0 /= '0'
 373          , Text.all Char.isDigit s
 374          , Just x <- readMaybe (Text.unpack s)
 375          , x < groupOrder @c
 376          = return (E x)
 377         parseJSON json = JSON.typeMismatch "E" json
 378
 379 instance Reifies c FFC => FromNatural (E c) where
 380         fromNatural i =
 381                 E $ abs $ i `mod` groupOrder @c
 382                 where
 383                 abs x | x < 0 = x + groupOrder @c
 384                       | otherwise = x
 385 instance ToNatural (E c) where
 386         nat = unE
 387
 388 instance Reifies c FFC => Additive (E c) where
 389         zero = E zero
 390         E x + E y = E $ (x + y) `mod` groupOrder @c
 391 instance Reifies c FFC => Negable (E c) where
 392         neg (E x)
 393          | x == 0 = zero
 394          | otherwise = E $ fromJust $ nat (groupOrder @c)`minusNaturalMaybe`x
 395 instance Reifies c FFC => Multiplicative (E c) where
 396         one = E one
 397         E x * E y = E $ (x * y) `mod` groupOrder @c
 398 instance Reifies c FFC => Random.Random (E c) where
 399         randomR (E lo, E hi) =
 400                 first (E . fromIntegral) .
 401                 Random.randomR
 402                  ( 0`max`toInteger lo
 403                  , toInteger hi`min`(toInteger (groupOrder @c) - 1) )
 404         random =
 405                 first (E . fromIntegral) .
 406                 Random.randomR (0, toInteger (groupOrder @c) - 1)
 407 instance Reifies c FFC => Enum (E c) where
 408         toEnum = fromNatural . fromIntegral
 409         fromEnum = fromIntegral . nat
 410         enumFromTo lo hi = List.unfoldr
 411          (\i -> if i<=hi then Just (i, i+one) else Nothing) lo
 412
 413 infixr 8 ^
 414 -- | @(b '^' e)@ returns the modular exponentiation of base 'b' by exponent 'e'.
 415 (^) :: Reifies c FFC => G c -> E c -> G c
 416 (^) b (E e)
 417  | e == 0 = one
 418  | otherwise = t * (b*b) ^ E (e`shiftR`1)
 419         where
 420         t | testBit e 0 = b
 421           | otherwise   = one
 422
 423 -- | @('randomR' i)@ returns a random integer in @[0..i-1]@.
 424 randomR ::
 425  Monad m =>
 426  Random.RandomGen r =>
 427  Random.Random i =>
 428  Negable i =>
 429  Multiplicative i =>
 430  i -> S.StateT r m i
 431 randomR i = S.StateT $ return . Random.randomR (zero, i-one)
 432
 433 -- | @('random')@ returns a random integer
 434 -- in the range determined by its type.
 435 random ::
 436  Monad m =>
 437  Random.RandomGen r =>
 438  Random.Random i =>
 439  Negable i =>
 440  Multiplicative i =>
 441  S.StateT r m i
 442 random = S.StateT $ return . Random.random
 443
 444 instance Random.Random Natural where
 445         randomR (mini,maxi) =
 446                 first (fromIntegral::Integer -> Natural) .
 447                 Random.randomR (fromIntegral mini, fromIntegral maxi)
 448         random = first (fromIntegral::Integer -> Natural) . Random.random
 449
 450 -- * Conversions
 451
 452 -- ** Class 'FromNatural'
 453 class FromNatural a where
 454         fromNatural :: Natural -> a
 455
 456 -- ** Class 'ToNatural'
 457 class ToNatural a where
 458         nat :: a -> Natural
 459 instance ToNatural Natural where
 460         nat = id
 461
 462 -- | @('bytesNat' x)@ returns the serialization of 'x'.
 463 bytesNat :: ToNatural n => n -> BS.ByteString
 464 bytesNat = fromString . show . nat