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