-{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Voting.Protocol.Arithmetic
- ( module Voting.Protocol.Arithmetic
- , Natural
- , Random.RandomGen
- ) where
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE Rank2Types #-} -- for ReifyCrypto
+module Voting.Protocol.Arithmetic where
import Control.Arrow (first)
import Control.DeepSeq (NFData)
import Control.Monad (Monad(..))
+import Data.Aeson (ToJSON(..),FromJSON(..))
import Data.Bits
import Data.Bool
import Data.Eq (Eq(..))
import Data.Foldable (Foldable, foldl')
-import Data.Function (($), (.))
-import Data.Functor ((<$>))
+import Data.Function (($), (.), id)
import Data.Int (Int)
-import Data.Maybe (Maybe(..))
+import Data.Maybe (Maybe(..), fromJust)
import Data.Ord (Ord(..))
-import Data.Semigroup (Semigroup(..))
-import Data.String (String, IsString(..))
+import Data.Proxy (Proxy(..))
+import Data.Reflection (Reifies(..))
+import Data.String (IsString(..))
+import GHC.Natural (minusNaturalMaybe)
import Numeric.Natural (Natural)
-import Prelude (Integer, Integral(..), fromIntegral, Enum(..))
+import Prelude (Integer, Bounded(..), Integral(..), fromIntegral)
+import Text.Read (readMaybe)
import Text.Show (Show(..))
-import qualified Control.Monad.Trans.State.Strict as S
-import qualified Crypto.Hash as Crypto
-import qualified Data.ByteArray as ByteArray
+import qualified Data.Aeson as JSON
+import qualified Data.Aeson.Types as JSON
import qualified Data.ByteString as BS
-import qualified Data.List as List
+import qualified Data.Char as Char
+import qualified Data.Text as Text
import qualified Prelude as Num
import qualified System.Random as Random
--- * Type 'F'
--- | The type of the elements of a 'PrimeField'.
---
--- A field must satisfy the following properties:
---
--- * @(f, ('+'), 'zero')@ forms an abelian group,
--- called the 'Additive' group of 'f'.
---
--- * @('NonNull' f, ('*'), 'one')@ forms an abelian group,
--- called the 'Multiplicative' group of 'f'.
---
--- * ('*') is associative:
--- @(a'*'b)'*'c == a'*'(b'*'c)@ and
--- @a'*'(b'*'c) == (a'*'b)'*'c@.
---
--- * ('*') and ('+') are both commutative:
--- @a'*'b == b'*'a@ and
--- @a'+'b == b'+'a@
---
--- * ('*') and ('+') are both left and right distributive:
--- @a'*'(b'+'c) == (a'*'b) '+' (a'*'c)@ and
--- @(a'+'b)'*'c == (a'*'c) '+' (b'*'c)@
---
--- The 'Natural' is always within @[0..'fieldCharac'-1]@.
-newtype F p = F { unF :: Natural }
- deriving (Eq,Ord,Show,NFData)
-
-instance PrimeField p => FromNatural (F p) where
- fromNatural i = F (abs (i `mod` fieldCharac @p))
- where abs x | x < 0 = x + fieldCharac @p
- | otherwise = x
-instance ToNatural (F p) where
- nat = unF
-
-instance PrimeField p => Additive (F p) where
- zero = F 0
- F x + F y = F ((x + y) `mod` fieldCharac @p)
-instance PrimeField p => Negable (F p) where
- neg (F x) | x == 0 = zero
- | otherwise = F (fromIntegral (Num.negate (toInteger x) + toInteger (fieldCharac @p)))
-instance PrimeField p => Multiplicative (F p) where
- one = F 1
- -- | Because 'fieldCharac' is prime,
- -- all elements of the field are invertible modulo 'fieldCharac'.
- F x * F y = F ((x * y) `mod` fieldCharac @p)
-instance PrimeField p => Random.Random (F p) where
- randomR (F lo, F hi) =
- first (F . fromIntegral) .
- Random.randomR
- ( 0`max`toInteger lo
- , toInteger hi`min`(toInteger (fieldCharac @p) - 1))
- random = first (F . fromIntegral) . Random.randomR (0, toInteger (fieldCharac @p) - 1)
-
--- ** Class 'PrimeField'
--- | Parameter for a prime field.
-class PrimeField p where
- -- | The prime number characteristic of a 'PrimeField'.
+-- * Class 'CryptoParams' where
+class
+ ( EuclideanRing (G crypto c)
+ , FromNatural (G crypto c)
+ , ToNatural (G crypto c)
+ , Eq (G crypto c)
+ , Ord (G crypto c)
+ , Show (G crypto c)
+ , NFData (G crypto c)
+ , FromJSON (G crypto c)
+ , ToJSON (G crypto c)
+ , Reifies c crypto
+ ) => CryptoParams crypto c where
+ -- | A generator of the subgroup.
+ groupGen :: G crypto c
+ -- | The order of the subgroup.
+ groupOrder :: Proxy c -> Natural
+
+ -- | 'groupGenPowers' returns the infinite list
+ -- of powers of 'groupGen'.
--
- -- ElGamal's hardness to decrypt requires a large prime number
- -- to form the 'Multiplicative' 'SubGroup'.
- fieldCharac :: Natural
+ -- NOTE: In the 'CryptoParams' class to keep
+ -- computed values in memory across calls to 'groupGenPowers'.
+ groupGenPowers :: [G crypto c]
+ groupGenPowers = go one
+ where go g = g : go (g * groupGen)
+
+ -- | 'groupGenInverses' returns the infinite list
+ -- of 'inverse' powers of 'groupGen':
+ -- @['groupGen' '^' 'negate' i | i <- [0..]]@,
+ -- but by computing each value from the previous one.
+ --
+ -- NOTE: In the 'CryptoParams' class to keep
+ -- computed values in memory across calls to 'groupGenInverses'.
+ --
+ -- Used by 'intervalDisjunctions'.
+ groupGenInverses :: [G crypto c]
+ groupGenInverses = go one
+ where
+ invGen = inverse groupGen
+ go g = g : go (g * invGen)
+
+-- ** Class 'ReifyCrypto'
+class ReifyCrypto crypto where
+ -- | Like 'reify' but augmented with the 'CryptoParams' constraint.
+ reifyCrypto :: crypto -> (forall c. Reifies c crypto => CryptoParams crypto c => Proxy c -> r) -> r
--- ** Class 'Additive'
+-- * Class 'Additive'
+-- | An additive semigroup.
class Additive a where
zero :: a
(+) :: a -> a -> a; infixl 6 +
zero = 0
(+) = (Num.+)
--- *** Class 'Negable'
-class Additive a => Negable a where
- neg :: a -> a
- (-) :: a -> a -> a; infixl 6 -
- x-y = x + neg y
-instance Negable Integer where
- neg = Num.negate
-instance Negable Int where
- neg = Num.negate
-
--- ** Class 'Multiplicative'
-class Multiplicative a where
+-- * Class 'Semiring'
+-- | A multiplicative semigroup, with an additive semigroup (aka. a semiring).
+class Additive a => Semiring a where
one :: a
(*) :: a -> a -> a; infixl 7 *
-instance Multiplicative Natural where
+instance Semiring Natural where
one = 1
(*) = (Num.*)
-instance Multiplicative Integer where
+instance Semiring Integer where
one = 1
(*) = (Num.*)
-instance Multiplicative Int where
+instance Semiring Int where
one = 1
(*) = (Num.*)
--- ** Class 'Invertible'
-class Multiplicative a => Invertible a where
- inv :: a -> a
- (/) :: a -> a -> a; infixl 7 /
- x/y = x * inv y
-
--- * Type 'G'
--- | The type of the elements of a 'Multiplicative' 'SubGroup' of a 'PrimeField'.
-newtype G q = G { unG :: F (P q) }
- deriving (Eq,Ord,Show,NFData)
-
-instance PrimeField (P q) => FromNatural (G q) where
- fromNatural = G . fromNatural
-instance ToNatural (G q) where
- nat = unF . unG
-
-instance (SubGroup q, Multiplicative (F (P q))) => Multiplicative (G q) where
- one = G one
- G x * G y = G (x * y)
-instance (SubGroup q, Multiplicative (F (P q))) => Invertible (G q) where
- -- | NOTE: add 'groupOrder' so the exponent given to (^) is positive.
- inv = (^ E (neg one + groupOrder @q))
+-- | @(b '^' e)@ returns the modular exponentiation of base 'b' by exponent 'e'.
+(^) ::
+ forall crypto c.
+ Reifies c crypto =>
+ Semiring (G crypto c) =>
+ G crypto c -> E crypto c -> G crypto c
+(^) b (E e)
+ | e == 0 = one
+ | otherwise = t * (b*b) ^ E (e`shiftR`1)
+ where t | testBit e 0 = b
+ | otherwise = one
+infixr 8 ^
--- ** Class 'SubGroup'
--- | A 'SubGroup' of a 'Multiplicative' group of a 'PrimeField'.
--- Used for signing (Schnorr) and encrypting (ElGamal).
-class
- ( PrimeField (P q)
- , Multiplicative (F (P q))
- ) => SubGroup q where
- -- | Setting 'q' determines 'p', equals to @'P' q@.
- type P q :: *
- -- | A generator of the 'SubGroup'.
- -- NOTE: since @F p@ is a 'PrimeField',
- -- the 'Multiplicative' 'SubGroup' is cyclic,
- -- and there are phi('fieldCharac'-1) many choices for the generator of the group,
- -- where phi is the Euler totient function.
- groupGen :: G q
- -- | The order of the 'SubGroup'.
- --
- -- WARNING: 'groupOrder' MUST be a prime number dividing @('fieldCharac'-1)@
- -- to ensure that ElGamal is secure in terms of the DDH assumption.
- groupOrder :: F (P q)
-
- -- | 'groupGenInverses' returns the infinite list
- -- of 'inv'erse powers of 'groupGen':
- -- @['groupGen' '^' 'neg' i | i <- [0..]]@,
- -- but by computing each value from the previous one.
- --
- -- NOTE: 'groupGenInverses' is in the 'SubGroup' class in order to keep
- -- computed terms in memory across calls to 'groupGenInverses'.
- --
- -- Used by 'intervalDisjunctions'.
- groupGenInverses :: [G q]
- groupGenInverses = go one
- where
- go g = g : go (g * invGen)
- invGen = inv groupGen
+-- ** Class 'Ring'
+-- | A semiring that support substraction (aka. a ring).
+class Semiring a => Ring a where
+ negate :: a -> a
+ (-) :: a -> a -> a; infixl 6 -
+ x-y = x + negate y
+instance Ring Integer where
+ negate = Num.negate
+instance Ring Int where
+ negate = Num.negate
+
+-- ** Class 'EuclideanRing'
+-- | A commutative ring that support division (aka. an euclidean ring).
+class Ring a => EuclideanRing a where
+ inverse :: a -> a
+ (/) :: a -> a -> a; infixl 7 /
+ x/y = x * inverse y
-groupGenPowers :: SubGroup q => [G q]
-groupGenPowers = go one
- where go g = g : go (g * groupGen)
+-- ** Type 'G'
+-- | The type of the elements of a subgroup of a field.
+newtype G crypto c = G { unG :: FieldElement crypto }
--- | @('hash' bs gs)@ returns as a number in 'E'
--- the SHA256 of the given 'BS.ByteString' 'bs'
--- prefixing the decimal representation of given 'SubGroup' elements 'gs',
--- with a comma (",") intercalated between them.
---
--- NOTE: to avoid any collision when the 'hash' function is used in different contexts,
--- a message 'gs' is actually prefixed by a 'bs' indicating the context.
---
--- Used by 'proveEncryption' and 'verifyEncryption',
--- where the 'bs' usually contains the 'statement' to be proven,
--- and the 'gs' contains the 'commitments'.
-hash ::
- SubGroup q =>
- BS.ByteString -> [G q] -> E q
-hash bs gs =
- let s = bs <> BS.intercalate (fromString ",") (bytesNat <$> gs) in
- let h = ByteArray.convert (Crypto.hashWith Crypto.SHA256 s) in
- fromNatural (BS.foldl' (\acc b -> acc`shiftL`3 + fromIntegral b) (0::Natural) h)
+-- *** Type family 'FieldElement'
+type family FieldElement crypto :: *
--- * Type 'E'
--- | An exponent of a (necessarily cyclic) 'SubGroup' of a 'PrimeField'.
+-- ** Type 'E'
+-- | An exponent of a (cyclic) subgroup of a field.
-- The value is always in @[0..'groupOrder'-1]@.
-newtype E q = E { unE :: F (P q) }
- deriving (Eq,Ord,Show,NFData)
-
-instance SubGroup q => FromNatural (E q) where
- fromNatural i = E (F (abs (i `mod` unF (groupOrder @q))))
- where abs x | x < 0 = x + unF (groupOrder @q)
- | otherwise = x
-instance ToNatural (E q) where
- nat = unF . unE
-
-instance (SubGroup q, Additive (F (P q))) => Additive (E q) where
+newtype E crypto c = E { unE :: Natural }
+ deriving (Eq,Ord,Show)
+ deriving newtype NFData
+instance ToJSON (E crypto c) where
+ toJSON = JSON.toJSON . show . unE
+instance CryptoParams crypto c => FromJSON (E crypto c) where
+ parseJSON (JSON.String s)
+ | Just (c0,_) <- Text.uncons s
+ , c0 /= '0'
+ , Text.all Char.isDigit s
+ , Just x <- readMaybe (Text.unpack s)
+ , x < groupOrder (Proxy @c)
+ = return (E x)
+ parseJSON json = JSON.typeMismatch "Exponent" json
+instance CryptoParams crypto c => FromNatural (E crypto c) where
+ fromNatural n = E $ n `mod` groupOrder (Proxy @c)
+instance ToNatural (E crypto c) where
+ nat = unE
+instance CryptoParams crypto c => Additive (E crypto c) where
zero = E zero
- E (F x) + E (F y) = E (F ((x + y) `mod` unF (groupOrder @q)))
-instance (SubGroup q, Negable (F (P q))) => Negable (E q) where
- neg (E (F x)) | x == 0 = zero
- | otherwise = E (F (fromIntegral ( neg (toInteger x)
- + toInteger (unF (groupOrder @q)) )))
-instance (SubGroup q, Multiplicative (F (P q))) => Multiplicative (E q) where
+ E x + E y = E $ (x + y) `mod` groupOrder (Proxy @c)
+instance CryptoParams crypto c => Semiring (E crypto c) where
one = E one
- E (F x) * E (F y) = E (F ((x * y) `mod` unF (groupOrder @q)))
-instance SubGroup q => Random.Random (E q) where
- randomR (E (F lo), E (F hi)) =
- first (E . F . fromIntegral) .
+ E x * E y = E $ (x * y) `mod` groupOrder (Proxy @c)
+instance CryptoParams crypto c => Ring (E crypto c) where
+ negate (E x) = E $ fromJust $ groupOrder (Proxy @c)`minusNaturalMaybe`x
+instance CryptoParams crypto c => Random.Random (E crypto c) where
+ randomR (E lo, E hi) =
+ first (E . fromIntegral) .
Random.randomR
( 0`max`toInteger lo
- , toInteger hi`min`(toInteger (unF (groupOrder @q)) - 1) )
+ , toInteger hi`min`(toInteger (groupOrder (Proxy @c)) - 1) )
random =
- first (E . F . fromIntegral) .
- Random.randomR (0, toInteger (unF (groupOrder @q)) - 1)
-instance SubGroup q => Enum (E q) where
+ first (E . fromIntegral) .
+ Random.randomR (0, toInteger (groupOrder (Proxy @c)) - 1)
+instance CryptoParams crypto c => Bounded (E crypto c) where
+ minBound = zero
+ maxBound = E $ fromJust $ groupOrder (Proxy @c)`minusNaturalMaybe`1
+{-
+instance CryptoParams crypto c => Enum (E crypto c) where
toEnum = fromNatural . fromIntegral
fromEnum = fromIntegral . nat
enumFromTo lo hi = List.unfoldr
(\i -> if i<=hi then Just (i, i+one) else Nothing) lo
+-}
-infixr 8 ^
--- | @(b '^' e)@ returns the modular exponentiation of base 'b' by exponent 'e'.
-(^) :: SubGroup q => G q -> E q -> G q
-(^) b (E (F e))
- | e == zero = one
- | otherwise = t * (b*b) ^ E (F (e`shiftR`1))
- where
- t | testBit e 0 = b
- | otherwise = one
-
--- | @('randomR' i)@ returns a random integer in @[0..i-1]@.
-randomR ::
- Monad m =>
- Random.RandomGen r =>
- Random.Random i =>
- Negable i =>
- Multiplicative i =>
- i -> S.StateT r m i
-randomR i = S.StateT $ return . Random.randomR (zero, i-one)
-
--- | @('random')@ returns a random integer
--- in the range determined by its type.
-random ::
- Monad m =>
- Random.RandomGen r =>
- Random.Random i =>
- Negable i =>
- Multiplicative i =>
- S.StateT r m i
-random = S.StateT $ return . Random.random
-
-instance Random.Random Natural where
- randomR (mini,maxi) =
- first (fromIntegral::Integer -> Natural) .
- Random.randomR (fromIntegral mini, fromIntegral maxi)
- random = first (fromIntegral::Integer -> Natural) . Random.random
-
--- * Groups
-
--- * Type 'Params'
-class SubGroup q => Params q where
- paramsName :: String
-instance Params WeakParams where
- paramsName = "WeakParams"
-instance Params BeleniosParams where
- paramsName = "BeleniosParams"
-
--- ** Type 'WeakParams'
--- | Weak parameters for debugging purposes only.
-data WeakParams
-instance PrimeField WeakParams where
- fieldCharac = 263
-instance SubGroup WeakParams where
- type P WeakParams = WeakParams
- groupGen = G (F 2)
- groupOrder = F 131
-
--- ** Type 'BeleniosParams'
--- | Parameters used in Belenios.
--- A 2048-bit 'fieldCharac' of a 'PrimeField',
--- with a 256-bit 'groupOrder' for a 'Multiplicative' 'SubGroup'
--- generated by 'groupGen'.
-data BeleniosParams
-instance PrimeField BeleniosParams where
- fieldCharac = 20694785691422546401013643657505008064922989295751104097100884787057374219242717401922237254497684338129066633138078958404960054389636289796393038773905722803605973749427671376777618898589872735865049081167099310535867780980030790491654063777173764198678527273474476341835600035698305193144284561701911000786737307333564123971732897913240474578834468260652327974647951137672658693582180046317922073668860052627186363386088796882120769432366149491002923444346373222145884100586421050242120365433561201320481118852408731077014151666200162313177169372189248078507711827842317498073276598828825169183103125680162072880719
-instance SubGroup BeleniosParams where
- type P BeleniosParams = BeleniosParams
- groupGen = G (F 2402352677501852209227687703532399932712287657378364916510075318787663274146353219320285676155269678799694668298749389095083896573425601900601068477164491735474137283104610458681314511781646755400527402889846139864532661215055797097162016168270312886432456663834863635782106154918419982534315189740658186868651151358576410138882215396016043228843603930989333662772848406593138406010231675095763777982665103606822406635076697764025346253773085133173495194248967754052573659049492477631475991575198775177711481490920456600205478127054728238140972518639858334115700568353695553423781475582491896050296680037745308460627)
- groupOrder = F 78571733251071885079927659812671450121821421258408794611510081919805623223441
-
--- * Conversions
-
--- ** Class 'FromNatural'
+-- * Class 'FromNatural'
class FromNatural a where
fromNatural :: Natural -> a
+instance FromNatural Natural where
+ fromNatural = id
--- ** Class 'ToNatural'
+-- * Class 'ToNatural'
class ToNatural a where
nat :: a -> Natural
+instance ToNatural Natural where
+ nat = id
-- | @('bytesNat' x)@ returns the serialization of 'x'.
bytesNat :: ToNatural n => n -> BS.ByteString
sourcephile / git / majurity.git / blobdiff