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 = ByteArray.convert (Crypto.hashWith Crypto.SHA256 s)
 310         fromNatural (BS.foldl' (\acc b -> acc`shiftL`3 + fromIntegral b) (0::Natural) h)
 311
 312 -- * Type 'E'
 313 -- | An exponent of a (necessarily cyclic) subgroup of a Finite Prime Field.
 314 -- The value is always in @[0..'groupOrder'-1]@.
 315 newtype E c = E { unE :: Natural }
 316  deriving (Eq,Ord,Show)
 317  deriving newtype NFData
 318 instance ToJSON (E c) where
 319         toJSON (E x) = JSON.toJSON x
 320 instance Reifies c FFC => FromJSON (E c) where
 321         parseJSON (JSON.String s)
 322          | Just (c0,_) <- Text.uncons s
 323          , c0 /= '0'
 324          , Text.all Char.isDigit s
 325          , Just x <- readMaybe (Text.unpack s)
 326          , x < groupOrder @c
 327          = return (E x)
 328         parseJSON json = JSON.typeMismatch "E" json
 329
 330 instance Reifies c FFC => FromNatural (E c) where
 331         fromNatural i =
 332                 E $ abs $ i `mod` groupOrder @c
 333                 where
 334                 abs x | x < 0 = x + groupOrder @c
 335                       | otherwise = x
 336 instance ToNatural (E c) where
 337         nat = unE
 338
 339 instance Reifies c FFC => Additive (E c) where
 340         zero = E zero
 341         E x + E y = E $ (x + y) `mod` groupOrder @c
 342 instance Reifies c FFC => Negable (E c) where
 343         neg (E x)
 344          | x == 0 = zero
 345          | otherwise = E $ fromJust $ nat (groupOrder @c)`minusNaturalMaybe`x
 346 instance Reifies c FFC => Multiplicative (E c) where
 347         one = E one
 348         E x * E y = E $ (x * y) `mod` groupOrder @c
 349 instance Reifies c FFC => Random.Random (E c) where
 350         randomR (E lo, E hi) =
 351                 first (E . fromIntegral) .
 352                 Random.randomR
 353                  ( 0`max`toInteger lo
 354                  , toInteger hi`min`(toInteger (groupOrder @c) - 1) )
 355         random =
 356                 first (E . fromIntegral) .
 357                 Random.randomR (0, toInteger (groupOrder @c) - 1)
 358 instance Reifies c FFC => Enum (E c) where
 359         toEnum = fromNatural . fromIntegral
 360         fromEnum = fromIntegral . nat
 361         enumFromTo lo hi = List.unfoldr
 362          (\i -> if i<=hi then Just (i, i+one) else Nothing) lo
 363
 364 infixr 8 ^
 365 -- | @(b '^' e)@ returns the modular exponentiation of base 'b' by exponent 'e'.
 366 (^) :: Reifies c FFC => G c -> E c -> G c
 367 (^) b (E e)
 368  | e == 0 = one
 369  | otherwise = t * (b*b) ^ E (e`shiftR`1)
 370         where
 371         t | testBit e 0 = b
 372           | otherwise   = one
 373
 374 -- | @('randomR' i)@ returns a random integer in @[0..i-1]@.
 375 randomR ::
 376  Monad m =>
 377  Random.RandomGen r =>
 378  Random.Random i =>
 379  Negable i =>
 380  Multiplicative i =>
 381  i -> S.StateT r m i
 382 randomR i = S.StateT $ return . Random.randomR (zero, i-one)
 383
 384 -- | @('random')@ returns a random integer
 385 -- in the range determined by its type.
 386 random ::
 387  Monad m =>
 388  Random.RandomGen r =>
 389  Random.Random i =>
 390  Negable i =>
 391  Multiplicative i =>
 392  S.StateT r m i
 393 random = S.StateT $ return . Random.random
 394
 395 instance Random.Random Natural where
 396         randomR (mini,maxi) =
 397                 first (fromIntegral::Integer -> Natural) .
 398                 Random.randomR (fromIntegral mini, fromIntegral maxi)
 399         random = first (fromIntegral::Integer -> Natural) . Random.random
 400
 401 -- * Conversions
 402
 403 -- ** Class 'FromNatural'
 404 class FromNatural a where
 405         fromNatural :: Natural -> a
 406
 407 -- ** Class 'ToNatural'
 408 class ToNatural a where
 409         nat :: a -> Natural
 410 instance ToNatural Natural where
 411         nat = id
 412
 413 -- | @('bytesNat' x)@ returns the serialization of 'x'.
 414 bytesNat :: ToNatural n => n -> BS.ByteString
 415 bytesNat = fromString . show . nat