hjugement-protocol/src/Voting/Protocol/Arithmetic.hs

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