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