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 (/= '=') $
 366                 -- TODO: to be removed when Belenios will expect padding.
 367                 Text.decodeUtf8 $ BS64.encode $ ByteArray.convert h
 368
 369 -- ** Type 'HexSHA256'
 370 newtype HexSHA256 = HexSHA256 Text
 371  deriving (Eq,Ord,Show,Generic)
 372  deriving anyclass (ToJSON,FromJSON)
 373  deriving newtype NFData
 374 -- | @('hexSHA256' bs)@ returns the 'Crypto.SHA256' hash
 375 -- of the given 'BS.ByteString' 'bs', escaped in hexadecimal
 376 -- into a 'Text' of 32 lowercase characters.
 377 --
 378 -- Used (in retro-dependencies of this library) to hash
 379 -- the 'PublicKey' of a voter or a trustee.
 380 hexSHA256 :: BS.ByteString -> Text
 381 hexSHA256 bs =
 382         let h = Crypto.hashWith Crypto.SHA256 bs in
 383         let n = decodeBigEndian $ ByteArray.convert h in
 384         -- NOTE: always set the 256 bit then remove it
 385         -- to always have leading zeros,
 386         -- and thus always 64 characters wide hashes.
 387         TL.toStrict $
 388         TL.tail $ TLB.toLazyText $ TLB.hexadecimal $
 389         setBit n 256
 390
 391 -- * Type 'E'
 392 -- | An exponent of a (necessarily cyclic) subgroup of a Finite Prime Field.
 393 -- The value is always in @[0..'groupOrder'-1]@.
 394 newtype E c = E { unE :: Natural }
 395  deriving (Eq,Ord,Show)
 396  deriving newtype NFData
 397 instance ToJSON (E c) where
 398         toJSON (E x) = JSON.toJSON (show x)
 399 instance Reifies c FFC => FromJSON (E c) where
 400         parseJSON (JSON.String s)
 401          | Just (c0,_) <- Text.uncons s
 402          , c0 /= '0'
 403          , Text.all Char.isDigit s
 404          , Just x <- readMaybe (Text.unpack s)
 405          , x < groupOrder @c
 406          = return (E x)
 407         parseJSON json = JSON.typeMismatch "Exponent" json
 408
 409 instance Reifies c FFC => FromNatural (E c) where
 410         fromNatural i =
 411                 E $ abs $ i `mod` groupOrder @c
 412                 where
 413                 abs x | x < 0 = x + groupOrder @c
 414                       | otherwise = x
 415 instance ToNatural (E c) where
 416         nat = unE
 417
 418 instance Reifies c FFC => Additive (E c) where
 419         zero = E zero
 420         E x + E y = E $ (x + y) `mod` groupOrder @c
 421 instance Reifies c FFC => Negable (E c) where
 422         neg (E x)
 423          | x == 0 = zero
 424          | otherwise = E $ fromJust $ nat (groupOrder @c)`minusNaturalMaybe`x
 425 instance Reifies c FFC => Multiplicative (E c) where
 426         one = E one
 427         E x * E y = E $ (x * y) `mod` groupOrder @c
 428 instance Reifies c FFC => Random.Random (E c) where
 429         randomR (E lo, E hi) =
 430                 first (E . fromIntegral) .
 431                 Random.randomR
 432                  ( 0`max`toInteger lo
 433                  , toInteger hi`min`(toInteger (groupOrder @c) - 1) )
 434         random =
 435                 first (E . fromIntegral) .
 436                 Random.randomR (0, toInteger (groupOrder @c) - 1)
 437 instance Reifies c FFC => Enum (E c) where
 438         toEnum = fromNatural . fromIntegral
 439         fromEnum = fromIntegral . nat
 440         enumFromTo lo hi = List.unfoldr
 441          (\i -> if i<=hi then Just (i, i+one) else Nothing) lo
 442
 443 infixr 8 ^
 444 -- | @(b '^' e)@ returns the modular exponentiation of base 'b' by exponent 'e'.
 445 (^) :: Reifies c FFC => G c -> E c -> G c
 446 (^) b (E e)
 447  | e == 0 = one
 448  | otherwise = t * (b*b) ^ E (e`shiftR`1)
 449         where
 450         t | testBit e 0 = b
 451           | otherwise   = one
 452
 453 -- | @('randomR' i)@ returns a random integer in @[0..i-1]@.
 454 randomR ::
 455  Monad m =>
 456  Random.RandomGen r =>
 457  Random.Random i =>
 458  Negable i =>
 459  Multiplicative i =>
 460  i -> S.StateT r m i
 461 randomR i = S.StateT $ return . Random.randomR (zero, i-one)
 462
 463 -- | @('random')@ returns a random integer
 464 -- in the range determined by its type.
 465 random ::
 466  Monad m =>
 467  Random.RandomGen r =>
 468  Random.Random i =>
 469  Negable i =>
 470  Multiplicative i =>
 471  S.StateT r m i
 472 random = S.StateT $ return . Random.random
 473
 474 instance Random.Random Natural where
 475         randomR (mini,maxi) =
 476                 first (fromIntegral::Integer -> Natural) .
 477                 Random.randomR (fromIntegral mini, fromIntegral maxi)
 478         random = first (fromIntegral::Integer -> Natural) . Random.random
 479
 480 -- * Conversions
 481
 482 -- ** Class 'FromNatural'
 483 class FromNatural a where
 484         fromNatural :: Natural -> a
 485
 486 -- ** Class 'ToNatural'
 487 class ToNatural a where
 488         nat :: a -> Natural
 489 instance ToNatural Natural where
 490         nat = id
 491
 492 -- | @('bytesNat' x)@ returns the serialization of 'x'.
 493 bytesNat :: ToNatural n => n -> BS.ByteString
 494 bytesNat = fromString . show . nat