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