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