diff --git a/Protocol/Arithmetic.hs b/Protocol/Arithmetic.hs --- a/Protocol/Arithmetic.hs +++ b/Protocol/Arithmetic.hs @@ -1,13 +1,17 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -module Protocol.Arithmetic where +module Protocol.Arithmetic + ( module Protocol.Arithmetic + , Natural + ) where import Control.Arrow (first) import Control.Monad (Monad(..)) import Data.Bits import Data.Bool import Data.Eq (Eq(..)) -import Data.Foldable (Foldable, foldl', foldMap) +import Data.Foldable (Foldable, foldl') import Data.Function (($), (.)) +import Data.Functor ((<$>)) import Data.Int (Int) import Data.Maybe (Maybe(..)) import Data.Ord (Ord(..)) @@ -21,7 +25,7 @@ import qualified Data.ByteArray as ByteArray import qualified Data.ByteString as BS import qualified Data.List as List -import qualified Prelude as N +import qualified Prelude as Num import qualified System.Random as Random -- * Type 'F' @@ -51,17 +55,19 @@ newtype F p = F { unF :: Natural } deriving (Eq,Ord,Show) -inF :: forall p i. PrimeField p => Integral i => i -> F p -inF i = F (abs (fromIntegral i `mod` fieldCharac @p)) - where abs x | x < 0 = x + fieldCharac @p - | otherwise = x +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 (N.negate (toInteger x) + toInteger (fieldCharac @p))) + | otherwise = F (fromIntegral (Num.negate (toInteger x) + toInteger (fieldCharac @p))) instance PrimeField p => Multiplicative (F p) where one = F 1 -- | Because 'fieldCharac' is prime, @@ -92,13 +98,13 @@ sum = foldl' (+) zero instance Additive Natural where zero = 0 - (+) = (N.+) + (+) = (Num.+) instance Additive Integer where zero = 0 - (+) = (N.+) + (+) = (Num.+) instance Additive Int where zero = 0 - (+) = (N.+) + (+) = (Num.+) -- *** Class 'Negable' class Additive a => Negable a where @@ -106,9 +112,9 @@ (-) :: a -> a -> a; infixl 6 - x-y = x + neg y instance Negable Integer where - neg = N.negate + neg = Num.negate instance Negable Int where - neg = N.negate + neg = Num.negate -- ** Class 'Multiplicative' class Multiplicative a where @@ -116,13 +122,13 @@ (*) :: a -> a -> a; infixl 7 * instance Multiplicative Natural where one = 1 - (*) = (N.*) + (*) = (Num.*) instance Multiplicative Integer where one = 1 - (*) = (N.*) + (*) = (Num.*) instance Multiplicative Int where one = 1 - (*) = (N.*) + (*) = (Num.*) -- ** Class 'Invertible' class Multiplicative a => Invertible a where @@ -135,10 +141,10 @@ newtype G q = G { unG :: F (P q) } deriving (Eq,Ord,Show) --- | @('natG' g)@ returns the element of the 'SubGroup' 'g' --- as an 'Natural' within @[0..'fieldCharac'-1]@. -natG :: SubGroup q => G q -> Natural -natG = unF . unG +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 @@ -148,7 +154,7 @@ inv = (^ E (neg one + groupOrder @q)) -- ** Class 'SubGroup' --- | A 'SubGroup' of a 'PrimeField'. +-- | A 'SubGroup' of a 'Multiplicative' group of a 'PrimeField'. -- Used for signing (Schnorr) and encrypting (ElGamal). class ( PrimeField (P q) @@ -165,8 +171,7 @@ -- | The order of the 'SubGroup'. -- -- WARNING: 'groupOrder' MUST be a prime number dividing @('fieldCharac'-1)@ - -- to ensure that ensures that ElGamal is secure in terms - -- of the DDH assumption. + -- to ensure that ElGamal is secure in terms of the DDH assumption. groupOrder :: F (P q) -- | 'groupGenInverses' returns the infinite list @@ -175,29 +180,33 @@ -- but by computing each value from the previous one. -- -- NOTE: 'groupGenInverses' is in the 'SubGroup' class in order to keep - -- computed terms in memory accross calls to 'groupGenInverses'. + -- computed terms in memory across calls to 'groupGenInverses'. -- - -- Used by 'validableEncryption'. + -- Used by 'intervalDisjunctions'. groupGenInverses :: [G q] groupGenInverses = go one where go g = g : go (g * invGen) invGen = inv groupGen --- | @('hash' prefix gs)@ returns as a number in @('F' p)@ --- the SHA256 of the given 'prefix' prefixing the decimal representation --- of given 'SubGroup' elements 'gs', each one postfixed with a comma (","). +-- | @('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. -- --- Used by 'proveEncryption' and 'validateEncryption', --- where the 'prefix' contains the 'statement' to be proven, +-- 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 prefix gs = - let s = prefix <> foldMap (\(G (F i)) -> fromString (show i) <> fromString ",") gs in +hash bs gs = + let s = bs <> BS.intercalate (fromString ",") (bytesNat <$> gs) in let h = ByteArray.convert (Crypto.hashWith Crypto.SHA256 s) in - inE (BS.foldl' (\acc b -> acc`shiftL`3 + fromIntegral b) (0::Natural) h) + fromNatural (BS.foldl' (\acc b -> acc`shiftL`3 + fromIntegral b) (0::Natural) h) -- * Type 'E' -- | An exponent of a (necessarily cyclic) 'SubGroup' of a 'PrimeField'. @@ -205,13 +214,12 @@ newtype E q = E { unE :: F (P q) } deriving (Eq,Ord,Show) -inE :: forall q i. SubGroup q => Integral i => i -> E q -inE i = E (F (abs (fromIntegral i `mod` unF (groupOrder @q)))) - where abs x | x < 0 = x + unF (groupOrder @q) - | otherwise = x - -natE :: forall q. SubGroup q => E q -> Natural -natE = unF . unE +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 zero = E zero @@ -233,8 +241,8 @@ first (E . F . fromIntegral) . Random.randomR (0, toInteger (unF (groupOrder @q)) - 1) instance SubGroup q => Enum (E q) where - toEnum = inE - fromEnum = fromIntegral . natE + toEnum = fromNatural . fromIntegral + fromEnum = fromIntegral . nat enumFromTo lo hi = List.unfoldr (\i -> if i<=hi then Just (i, i+one) else Nothing) lo @@ -302,3 +310,17 @@ type P BeleniosParams = BeleniosParams groupGen = G (F 2402352677501852209227687703532399932712287657378364916510075318787663274146353219320285676155269678799694668298749389095083896573425601900601068477164491735474137283104610458681314511781646755400527402889846139864532661215055797097162016168270312886432456663834863635782106154918419982534315189740658186868651151358576410138882215396016043228843603930989333662772848406593138406010231675095763777982665103606822406635076697764025346253773085133173495194248967754052573659049492477631475991575198775177711481490920456600205478127054728238140972518639858334115700568353695553423781475582491896050296680037745308460627) groupOrder = F 78571733251071885079927659812671450121821421258408794611510081919805623223441 + +-- * Conversions + +-- ** Class 'FromNatural' +class FromNatural a where + fromNatural :: Natural -> a + +-- ** Class 'ToNatural' +class ToNatural a where + nat :: a -> Natural + +-- | @('bytesNat' x)@ returns the serialization of 'x'. +bytesNat :: ToNatural n => n -> BS.ByteString +bytesNat = fromString . show . nat diff --git a/Protocol/Credential.hs b/Protocol/Credential.hs --- a/Protocol/Credential.hs +++ b/Protocol/Credential.hs @@ -97,8 +97,7 @@ S.StateT r m UUID randomUUID = do rs <- replicateM tokenLength (randomR (fromIntegral tokenBase)) - let cs = List.foldl' (\ds d -> charOfDigit d : ds) [] rs - return $ UUID $ Text.reverse $ Text.pack cs + return $ UUID $ Text.pack $ charOfDigit <$> rs where charOfDigit = (credentialAlphabet List.!!) @@ -110,7 +109,7 @@ -- using 'Crypto.fastPBKDF2_SHA256'. secretKey :: SubGroup q => UUID -> Credential -> SecretKey q secretKey (UUID uuid) (Credential cred) = - inE $ BS.foldl' + fromNatural $ BS.foldl' (\acc b -> acc`shiftL`3 + fromIntegral b) (0::Natural) (ByteArray.convert deriv) diff --git a/Protocol/Election.hs b/Protocol/Election.hs --- a/Protocol/Election.hs +++ b/Protocol/Election.hs @@ -3,7 +3,7 @@ {-# LANGUAGE OverloadedStrings #-} module Protocol.Election where -import Control.Monad (Monad(..), mapM, zipWithM) +import Control.Monad (Monad(..), join, mapM, zipWithM) import Control.Monad.Morph (MFunctor(..)) import Control.Monad.Trans.Class (MonadTrans(..)) import Data.Bool @@ -16,13 +16,12 @@ import Data.Maybe (Maybe(..), fromMaybe) import Data.Ord (Ord(..)) import Data.Semigroup (Semigroup(..)) -import Data.String (IsString(..)) import Data.Text (Text) import Data.Traversable (Traversable(..)) -import Data.Tuple (fst, snd) +import Data.Tuple (fst, snd, uncurry) import GHC.Natural (minusNaturalMaybe) import Numeric.Natural (Natural) -import Prelude (error, fromIntegral) +import Prelude (fromIntegral) import Text.Show (Show(..)) import qualified Control.Monad.Trans.Except as Exn import qualified Control.Monad.Trans.State.Strict as S @@ -38,13 +37,18 @@ -- -- Because ('groupGen' '^'encNonce '^'secKey '==' 'groupGen' '^'secKey '^'encNonce), -- knowing @secKey@, one can divide 'encryption_vault' by @('encryption_nonce' '^'secKey)@ --- to decipher @('groupGen' '^'clear)@, then @clear@ must be small to be decryptable, --- because it is encrypted as a power of 'groupGen' to enable the additive homomorphism. +-- to decipher @('groupGen' '^'clear)@, then the @clear@ text must be small to be decryptable, +-- because it is encrypted as a power of 'groupGen' (hence the "-like" in "ElGamal-like") +-- to enable the additive homomorphism. +-- +-- NOTE: Since @('encryption_vault' '*' 'encryption_nonce' '==' 'encryption_nonce' '^' (secKey '+' clear))@, +-- then: @(logBase 'encryption_nonce' ('encryption_vault' '*' 'encryption_nonce') '==' secKey '+' clear)@. data Encryption q = Encryption { encryption_nonce :: G q - -- ^ Public part of the random 'encNonce': @('groupGen' '^'encNonce)@ + -- ^ Public part of the randomness 'encNonce' used to 'encrypt' the 'clear' text, + -- equal to @('groupGen' '^'encNonce)@ , encryption_vault :: G q - -- ^ Encrypted clear: @('pubKey' '^'r '*' 'groupGen' '^'clear)@ + -- ^ Encrypted 'clear' text, equal to @('pubKey' '^'r '*' 'groupGen' '^'clear)@ } deriving (Eq,Show) -- | Additive homomorphism. @@ -62,7 +66,7 @@ -- -- WARNING: the secret encryption nonce (@encNonce@) -- is returned alongside the 'Encryption' --- in order to prove the validity of the encrypted clear in 'prove', +-- in order to 'prove' the validity of the encrypted 'clear' text in 'proveEncryption', -- but this secret @encNonce@ MUST be forgotten after that, -- as it may be used to decipher the 'Encryption' -- without the secret key associated with 'pubKey'. @@ -72,46 +76,65 @@ S.StateT r m (EncryptionNonce q, Encryption q) encrypt pubKey clear = do encNonce <- random - -- NOTE: preserve the 'encNonce' for 'prove'. + -- NOTE: preserve the 'encNonce' for 'prove' in 'proveEncryption'. return $ (encNonce,) Encryption { encryption_nonce = groupGen^encNonce , encryption_vault = pubKey ^encNonce * groupGen^clear - -- NOTE: 'clear' is put as exponent in order - -- to make an additive homomorphism - -- instead of a multiplicative homomorphism. - -- log (a*b) = log a + log b } -- * Type 'Proof' -- | 'Proof' of knowledge of a discrete logarithm: --- @secret == logBase base (base^secret)@. --- --- NOTE: Since @(pubKey == 'groupGen' '^'secKey)@, then: --- @(logBase 'encryption_nonce' ('encryption_vault' '*' 'encryption_nonce') '==' secKey '+' clear)@. +-- @(secret == logBase base (base^secret))@. data Proof q = Proof { proof_challenge :: Challenge q -- ^ 'Challenge' sent by the verifier to the prover -- to ensure that the prover really has knowledge -- of the secret and is not replaying. - -- Actually, 'proof_challenge' is not sent in a 'prove', + -- Actually, 'proof_challenge' is not sent to the prover, -- but derived from the prover's 'Commitment's and statements - -- with a collision resistant hash. + -- with a collision resistant 'hash'. + -- Hence the prover cannot chose the 'proof_challenge' to his/her liking. , proof_response :: E q - -- ^ Response sent by the prover to the verifier. - -- Usually: @nonce '+' sec '*' 'proof_challenge'@. + -- ^ A discrete logarithm sent by the prover to the verifier, + -- as a response to 'proof_challenge'. -- - -- To be computed efficiently, it requires @sec@: - -- either the @secKey@ (in 'signature_proof') - -- or the @encNonce@ (in 'prove'). + -- If the verifier observes that @('proof_challenge' '==' 'hash' statement [commitment])@ + -- where: + -- + -- * @statement@ is a serialization of a tag, 'base' and 'basePowSec', + -- * @(commitment '==' 'commit' proof base basePowSec '==' + -- base '^' 'proof_response' '*' basePowSec '^' 'proof_challenge')@, + -- * and @(basePowSec '==' base'^'sec)@, + -- + -- then, with overwhelming probability due to the 'hash' function: + -- @(commitment '==' base'^'nonce)@. + -- Therefore by expanding 'commitment': + -- @('proof_response' '==' logBase base (base'^'nonce) '-' logBase basePowSec (basePowSec '^' 'proof_challenge'))@, + -- which means that the prover must have known 'nonce' and 'sec' + -- to compute 'proof_response' efficiently with: + -- @('proof_response' '==' nonce '-' sec '*' 'proof_challenge')@, + -- + -- The 'nonce' is introduced to ensure each 'prove' does not reveal + -- any information regarding the prover's secret 'sec', + -- by being randomly chosen by the prover. } deriving (Eq,Show) +-- ** Type 'ZKP' +-- | Zero-knowledge proof +-- +-- DOC: Mihir Bellare and Phillip Rogaway. Random oracles are practical: +-- A paradigm for designing efficient protocols. In ACM-CCS’93, 1993. +-- +-- DOC: Pierrick Gaudry. , 2017. +newtype ZKP = ZKP BS.ByteString + -- ** Type 'Challenge' type Challenge = E -- ** Type 'Oracle' -- An 'Oracle' returns the 'Challenge' of the 'Commitment's --- by hashing them (eventually with other 'Commitment's). +-- by 'hash'ing them (eventually with other 'Commitment's). -- -- Used in 'prove' it enables a Fiat-Shamir transformation -- of an /interactive zero-knowledge/ (IZK) proof @@ -119,35 +142,32 @@ -- That is to say that the verifier does not have -- to send a 'Challenge' to the prover. -- Indeed, the prover now handles the 'Challenge' --- which becomes a (collision resistant) hash +-- which becomes a (collision resistant) 'hash' -- of the prover's commitments (and statements to be a stronger proof). type Oracle list q = list (Commitment q) -> Challenge q --- | @('prove' sec commitments oracle)@ +-- | @('prove' sec commitBases oracle)@ -- returns a 'Proof' that @sec@ is known. -- --- The 'Oracle' is given the 'commitments' +-- The 'Oracle' is given the 'commitBases' -- raised to the power of the secret nonce of the 'Proof', --- as those are the 'commitments' that the verifier will obtain +-- as those are the 'commitBases' that the verifier will obtain -- when composing the 'proof_challenge' and 'proof_response' together --- (in 'encryptionCommitments'). +-- (in 'commit'). -- -- NOTE: 'sec' is @secKey@ in 'signature_proof' or @encNonce@ in 'proveEncryption'. -- --- NOTE: The 'commitments' are @['groupGen']@ in 'signature_proof' --- or @['groupGen', 'pubKey']@ in 'proveEncryption'. --- -- WARNING: for 'prove' to be a so-called /strong Fiat-Shamir transformation/ (not a weak): --- the statement must be included in the hash (not only the commitments). +-- the statement must be included in the 'hash' (not only the commitments). -- -- NOTE: a 'random' @nonce@ is used to ensure each 'prove' -- does not reveal any information regarding the secret 'sec'. prove :: Monad m => RandomGen r => SubGroup q => Functor list => E q -> list (Commitment q) -> Oracle list q -> S.StateT r m (Proof q) -prove sec commitments oracle = do +prove sec commitBases oracle = do nonce <- random - let proof_challenge = oracle $ (^ nonce) <$> commitments + let proof_challenge = oracle $ (^ nonce) <$> commitBases return Proof { proof_challenge , proof_response = nonce - sec*proof_challenge @@ -156,24 +176,19 @@ -- ** Type 'Commitment' type Commitment = G --- | @('commit' proof x y)@ returns a 'Commitment' +-- | @('commit' proof base basePowSec)@ returns a 'Commitment' -- from the given 'Proof' with the knowledge of the verifier. --- --- NOTE: Contrary to Helios-C specifications, --- @('*')@ is used instead of @('/')@ --- to avoid the performance cost of a modular exponentiation --- @('^' ('groupOrder' '-' 'one'))@, --- this is compensated by using @('-')@ instead of @('+')@ in 'prove'. commit :: SubGroup q => Proof q -> G q -> G q -> Commitment q -commit Proof{..} x y = x^proof_response * y^proof_challenge +commit Proof{..} base basePowSec = + base^proof_response * + basePowSec^proof_challenge + -- NOTE: Contrary to some textbook presentations, + -- @('*')@ is used instead of @('/')@ to avoid the performance cost + -- of a modular exponentiation @('^' ('groupOrder' '-' 'one'))@, + -- this is compensated by using @('-')@ instead of @('+')@ in 'prove'. {-# INLINE commit #-} --- ** Type 'Opinion' --- | Index of a 'Disjunction' within a list of them. --- It is encrypted as an 'E'xponent by 'encrypt'. -type Opinion = E - --- ** Type 'Disjunction' +-- * Type 'Disjunction' -- | A 'Disjunction' is an 'inv'ersed @('groupGen' '^'opinion)@ -- it's used in 'proveEncryption' to generate a 'Proof' -- that an 'encryption_vault' contains a given @('groupGen' '^'opinion)@, @@ -184,33 +199,35 @@ intervalDisjunctions :: SubGroup q => Opinion q -> Opinion q -> [Disjunction q] intervalDisjunctions mini maxi = - List.genericTake (fromMaybe 0 $ (natE maxi + 1)`minusNaturalMaybe`natE mini) $ - List.genericDrop (natE mini) $ + List.genericTake (fromMaybe 0 $ (nat maxi + 1)`minusNaturalMaybe`nat mini) $ + List.genericDrop (nat mini) $ groupGenInverses +-- ** Type 'Opinion' +-- | Index of a 'Disjunction' within a list of them. +-- It is encrypted as an 'E'xponent by 'encrypt'. +type Opinion = E + -- ** Type 'DisjProof' -- | A list of 'Proof's to prove that the 'Opinion' within an 'Encryption' -- is indexing a 'Disjunction' within a list of them, --- without knowing which 'Opinion' it is. +-- without revealing which 'Opinion' it is. newtype DisjProof q = DisjProof [Proof q] deriving (Eq,Show) --- | @('proveEncryption' pubKey zkp disjs opin (encNonce, enc))@ +-- | @('proveEncryption' elecPubKey voterZKP (prevDisjs,nextDisjs) (encNonce,enc))@ -- returns a 'DisjProof' that 'enc' 'encrypt's --- one of the 'Disjunction's within 'disjs', --- without revealing which one it is. +-- the 'Disjunction's between 'prevDisjs' and 'nextDisjs'. -- -- A /NIZK Disjunctive Chaum Pedersen Logarithm Equality/ is used. proveEncryption :: forall m r q. Monad m => RandomGen r => SubGroup q => PublicKey q -> ZKP -> - [Disjunction q] -> Opinion q -> + ([Disjunction q],[Disjunction q]) -> (EncryptionNonce q, Encryption q) -> - S.StateT r (Exn.ExceptT ErrorProove m) (DisjProof q) -proveEncryption pubKey zkp disjs opinion (encNonce, enc) - | (prevDisjs, _indexedDisj:nextDisjs) <- - List.genericSplitAt (natE opinion) disjs = do + S.StateT r m (DisjProof q) +proveEncryption elecPubKey voterZKP (prevDisjs,nextDisjs) (encNonce,enc) = do -- Fake proofs for all values except the correct one. prevFakes <- fakeProof `mapM` prevDisjs nextFakes <- fakeProof `mapM` nextDisjs @@ -219,21 +236,18 @@ let challengeSum = sum (proof_challenge <$> prevProofs) + sum (proof_challenge <$> nextProofs) - correctProof <- prove encNonce [groupGen, pubKey] $ + let statement = encryptionStatement voterZKP enc + correctProof <- prove encNonce [groupGen, elecPubKey] $ -- 'Oracle' \correctCommitments -> let commitments = foldMap snd prevFakes <> correctCommitments <> foldMap snd nextFakes in - hash (encryptionStatement zkp enc) commitments - challengeSum + hash statement commitments - challengeSum return $ DisjProof $ prevProofs <> (correctProof : nextProofs) - | otherwise = lift $ Exn.throwE $ - ErrorProove_InvalidOpinion - (fromIntegral $ List.length disjs) - (natE opinion) where - fakeProof :: Disjunction q -> S.StateT r (Exn.ExceptT ErrorProove m) (Proof q, [Commitment q]) + fakeProof :: Disjunction q -> S.StateT r m (Proof q, [Commitment q]) fakeProof disj = do -- Returns 'Commitment's verifiables by the verifier, -- but computed from random 'proof_challenge' and 'proof_response' @@ -241,7 +255,7 @@ proof_challenge <- random proof_response <- random let proof = Proof{..} - return (proof, encryptionCommitments pubKey enc (disj, proof)) + return (proof, encryptionCommitments elecPubKey enc (disj, proof)) verifyEncryption :: Monad m => @@ -250,23 +264,30 @@ [Disjunction q] -> (Encryption q, DisjProof q) -> Exn.ExceptT ErrorValidateEncryption m Bool -verifyEncryption pubKey zkp disjs (enc, DisjProof proofs) +verifyEncryption elecPubKey voterZKP disjs (enc, DisjProof proofs) | List.length proofs /= List.length disjs = Exn.throwE $ ErrorValidateEncryption_InvalidProofLength (fromIntegral $ List.length proofs) (fromIntegral $ List.length disjs) - | otherwise = return $ challengeSum == hash (encryptionStatement zkp enc) commitments + | otherwise = return $ challengeSum == hash (encryptionStatement voterZKP enc) commitments where challengeSum = sum (proof_challenge <$> proofs) - commitments = foldMap (encryptionCommitments pubKey enc) (List.zip disjs proofs) + commitments = foldMap + (encryptionCommitments elecPubKey enc) + (List.zip disjs proofs) +-- ** Hashing encryptionStatement :: SubGroup q => ZKP -> Encryption q -> BS.ByteString -encryptionStatement (ZKP zkp) Encryption{..} = - "prove|"<>zkp<>"|"<> - fromString (show (natG encryption_nonce))<>","<> - fromString (show (natG encryption_vault))<>"|" +encryptionStatement (ZKP voterZKP) Encryption{..} = + "prove|"<>voterZKP<>"|" + <> bytesNat encryption_nonce<>"," + <> bytesNat encryption_vault<>"|" + -- NOTE: the commitment base 'elecPubKey' is notably absent here + -- despite it being used in 'encryptionCommitments', + -- maybe this is not necessary because it is already known + -- by every participant. --- | @('encryptionCommitments' pubKey enc (disj,proof))@ +-- | @('encryptionCommitments' elecPubKey enc (disj,proof))@ -- returns the 'Commitment's with only the knowledge of the verifier. -- -- The 'Proof' comes from 'prove' of @fakeProof@ in 'proveEncryption'. @@ -274,25 +295,14 @@ SubGroup q => PublicKey q -> Encryption q -> (Disjunction q, Proof q) -> [G q] -encryptionCommitments pubKey Encryption{..} (disj, proof) = +encryptionCommitments elecPubKey Encryption{..} (disj, proof) = [ commit proof groupGen encryption_nonce -- == groupGen ^ nonce if 'Proof' comes from 'prove' - , commit proof pubKey (encryption_vault*disj) - -- == pubKey ^ nonce if 'Proof' comes from 'prove' + , commit proof elecPubKey (encryption_vault*disj) + -- == elecPubKey ^ nonce if 'Proof' comes from 'prove' -- and 'encryption_vault' encrypts (- logBase groupGen disj). ] --- ** Type 'ZKP' --- | Zero-knowledge proof -newtype ZKP = ZKP BS.ByteString - --- ** Type 'ErrorProove' --- | Error raised by 'proveEncryption'. -data ErrorProove - = ErrorProove_InvalidOpinion Natural Natural - -- ^ When the opinion is not within the number of 'Disjunction's. - deriving (Eq,Show) - -- ** Type 'ErrorValidateEncryption' -- | Error raised by 'verifyEncryption'. data ErrorValidateEncryption @@ -321,18 +331,7 @@ -- , answer_blankProof :: } deriving (Eq,Show) --- ** Type 'ErrorAnswer' --- | Error raised by 'encryptAnswer'. -data ErrorAnswer - = ErrorAnswer_WrongNumberOfOpinions Natural Natural - -- ^ When the number of opinions is different than - -- the number of choices ('question_choices'). - | ErrorAnswer_WrongSumOfOpinions Natural Natural Natural - -- ^ When the sum of opinions is not within the bounds - -- of 'question_mini' and 'question_maxi'. - deriving (Eq,Show) - --- | @('encryptAnswer' pubKey zkp quest opinions)@ +-- | @('encryptAnswer' elecPubKey zkp quest opinions)@ -- returns an 'Answer' validable by 'verifyAnswer', -- unless an 'ErrorAnswer' is returned. encryptAnswer :: @@ -340,38 +339,38 @@ PublicKey q -> ZKP -> Question q -> [Bool] -> S.StateT r (Exn.ExceptT ErrorAnswer m) (Answer q) -encryptAnswer pubKey zkp Question{..} opinionsBools +encryptAnswer elecPubKey zkp Question{..} opinionsBools | not (question_mini <= opinionsSum && opinionsSum <= question_maxi) = lift $ Exn.throwE $ ErrorAnswer_WrongSumOfOpinions - (natE opinionsSum) - (natE question_mini) - (natE question_maxi) + (nat opinionsSum) + (nat question_mini) + (nat question_maxi) | List.length opinions /= List.length question_choices = lift $ Exn.throwE $ ErrorAnswer_WrongNumberOfOpinions (fromIntegral $ List.length opinions) (fromIntegral $ List.length question_choices) | otherwise = do - encryptions <- encrypt pubKey `mapM` opinions - hoist (Exn.withExceptT (\case - ErrorProove_InvalidOpinion{} -> error "encryptAnswer: impossible happened" - )) $ do - individualProofs <- zipWithM - (proveEncryption pubKey zkp booleanDisjunctions) - opinions encryptions - sumProof <- proveEncryption pubKey zkp - (intervalDisjunctions question_mini question_maxi) - (opinionsSum - question_mini) - ( sum (fst <$> encryptions) -- NOTE: sum the 'encNonce's - , sum (snd <$> encryptions) -- NOTE: sum the 'Encryption's - ) - return $ Answer - { answer_opinions = List.zip - (snd <$> encryptions) -- NOTE: drop encNonce - individualProofs - , answer_sumProof = sumProof - } + encryptions <- encrypt elecPubKey `mapM` opinions + individualProofs <- zipWithM + (\opinion -> proveEncryption elecPubKey zkp $ + if opinion + then ([booleanDisjunctions List.!!0],[]) + else ([],[booleanDisjunctions List.!!1])) + opinionsBools encryptions + sumProof <- proveEncryption elecPubKey zkp + ((List.tail <$>) $ List.genericSplitAt (nat (opinionsSum - question_mini)) $ + intervalDisjunctions question_mini question_maxi) + ( sum (fst <$> encryptions) -- NOTE: sum the 'encNonce's + , sum (snd <$> encryptions) -- NOTE: sum the 'Encryption's + ) + return $ Answer + { answer_opinions = List.zip + (snd <$> encryptions) -- NOTE: drop encNonce + individualProofs + , answer_sumProof = sumProof + } where opinionsSum = sum opinions opinions = (\o -> if o then one else zero) <$> opinionsBools @@ -380,18 +379,29 @@ SubGroup q => PublicKey q -> ZKP -> Question q -> Answer q -> Bool -verifyAnswer pubKey zkp Question{..} Answer{..} +verifyAnswer elecPubKey zkp Question{..} Answer{..} | List.length question_choices /= List.length answer_opinions = False | otherwise = either (const False) id $ Exn.runExcept $ do validOpinions <- - verifyEncryption pubKey zkp booleanDisjunctions + verifyEncryption elecPubKey zkp booleanDisjunctions `traverse` answer_opinions - validSum <- verifyEncryption pubKey zkp + validSum <- verifyEncryption elecPubKey zkp (intervalDisjunctions question_mini question_maxi) ( sum (fst <$> answer_opinions) , answer_sumProof ) return (and validOpinions && validSum) +-- ** Type 'ErrorAnswer' +-- | Error raised by 'encryptAnswer'. +data ErrorAnswer + = ErrorAnswer_WrongNumberOfOpinions Natural Natural + -- ^ When the number of opinions is different than + -- the number of choices ('question_choices'). + | ErrorAnswer_WrongSumOfOpinions Natural Natural Natural + -- ^ When the sum of opinions is not within the bounds + -- of 'question_mini' and 'question_maxi'. + deriving (Eq,Show) + -- * Type 'Election' data Election q = Election { election_name :: Text @@ -429,25 +439,28 @@ (fromIntegral $ List.length opinionsByQuest) (fromIntegral $ List.length election_questions) | otherwise = do - let (keysMay, zkp) = + let (voterKeys, voterZKP) = case secKeyMay of Nothing -> (Nothing, ZKP "") Just secKey -> ( Just (secKey, pubKey) - , ZKP (fromString (show (natG pubKey))) ) - where pubKey = groupGen ^ secKey + , ZKP (bytesNat pubKey) ) + where pubKey = publicKey secKey ballot_answers <- hoist (Exn.withExceptT ErrorBallot_Answer) $ - zipWithM (encryptAnswer election_publicKey zkp) + zipWithM (encryptAnswer election_publicKey voterZKP) election_questions opinionsByQuest - ballot_signature <- case keysMay of + ballot_signature <- case voterKeys of Nothing -> return Nothing Just (secKey, signature_publicKey) -> do signature_proof <- prove secKey (Identity groupGen) $ \(Identity commitment) -> hash - (signatureCommitments zkp commitment) + -- NOTE: the order is unusual, the commitments are first + -- then comes the statement. Best guess is that + -- this is easier to code due to their respective types. + (signatureCommitments voterZKP commitment) (signatureStatement ballot_answers) return $ Just Signature{..} return Ballot @@ -466,7 +479,7 @@ case ballot_signature of Nothing -> (True, ZKP "") Just Signature{..} -> - let zkp = ZKP (fromString (show (natG signature_publicKey))) in + let zkp = ZKP (bytesNat signature_publicKey) in (, zkp) $ proof_challenge signature_proof == hash (signatureCommitments zkp (commit signature_proof groupGen signature_publicKey)) @@ -479,26 +492,30 @@ -- ** Type 'Signature' -- | Schnorr-like signature. -- --- Used to avoid 'Ballot' stuffing. +-- Used by each voter to sign his/her encrypted 'Ballot' +-- using his/her 'Credential', +-- in order to avoid ballot stuffing. data Signature q = Signature { signature_publicKey :: PublicKey q + -- ^ Verification key. , signature_proof :: Proof q } +-- *** Hashing + -- | @('signatureStatement' answers)@ --- returns all the 'encryption_nonce's and 'encryption_vault's --- of the given @answers@. +-- returns the encrypted material to be signed: +-- all the 'encryption_nonce's and 'encryption_vault's of the given @answers@. signatureStatement :: Foldable f => SubGroup q => f (Answer q) -> [G q] signatureStatement = foldMap $ \Answer{..} -> (`foldMap` answer_opinions) $ \(Encryption{..}, _proof) -> [encryption_nonce, encryption_vault] --- | @('signatureCommitments' zkp commitment)@ --- returns the hashable content from the knowledge of the verifier. +-- | @('signatureCommitments' voterZKP commitment)@ signatureCommitments :: SubGroup q => ZKP -> Commitment q -> BS.ByteString -signatureCommitments (ZKP zkp) commitment = - "sig|"<>zkp<>"|"<>fromString (show (natG commitment))<>"|" +signatureCommitments (ZKP voterZKP) commitment = + "sig|"<>voterZKP<>"|"<>bytesNat commitment<>"|" -- ** Type 'ErrorBallot' -- | Error raised by 'encryptBallot'. @@ -509,3 +526,72 @@ | ErrorBallot_Answer ErrorAnswer -- ^ When 'encryptAnswer' raised an 'ErrorAnswer'. deriving (Eq,Show) + +-- * Type 'DecryptionShare' +-- | A decryption share. It is computed by a trustee from his/her +-- private key share and the encrypted tally, +-- and contains a cryptographic 'Proof' that he/she didn't cheat. +data DecryptionShare q = DecryptionShare + { decryptionShare_factors :: [[DecryptionFactor q]] + , decryptionShare_proofs :: [[Proof q]] + -- ^ 'Proof's that 'decryptionShare_factors' were correctly computed. + } deriving (Eq,Show) + +computeDecryptionShare :: + Monad m => SubGroup q => RandomGen r => + SecretKey q -> [[Encryption q]] -> S.StateT r m (DecryptionShare q) +computeDecryptionShare secKey encs = do + res <- mapM (mapM (decryptionFactor secKey)) encs + return $ uncurry DecryptionShare $ List.unzip (List.unzip <$> res) + +decryptionFactor :: + Monad m => SubGroup q => RandomGen r => + SecretKey q -> Encryption q -> S.StateT r m (DecryptionFactor q, Proof q) +decryptionFactor secKey Encryption{..} = do + proof <- prove secKey [groupGen, encryption_nonce] (hash zkp) + return (encryption_nonce^secKey, proof) + where zkp = decryptionStatement (publicKey secKey) + +decryptionStatement :: SubGroup q => PublicKey q -> BS.ByteString +decryptionStatement pubKey = + "decrypt|"<>bytesNat pubKey<>"|" + +-- ** Type 'DecryptionFactor' +type DecryptionFactor = G + +-- ** Type 'ErrorDecryptionShare' +data ErrorDecryptionShare + = ErrorDecryptionShare_Invalid + deriving (Eq,Show) + +-- | @('checkDecryptionShare' encTally pubKey decShare)@ +-- checks that 'decShare' +-- (supposedly submitted by a trustee whose public key is 'pubKey') +-- is valid with respect to the encrypted tally 'encTally'. +checkDecryptionShare :: + Monad m => SubGroup q => RandomGen r => + [[Encryption q]] -> PublicKey q -> DecryptionShare q -> + Exn.ExceptT ErrorDecryptionShare m Bool +checkDecryptionShare encTally pubKey DecryptionShare{..} + | len <- List.length encTally + , len == List.length decryptionShare_factors + , len == List.length decryptionShare_proofs = + Exn.throwE ErrorDecryptionShare_Invalid + | otherwise = + return $ and $ join $ List.zipWith3 (List.zipWith3 + (\encFactor proof Encryption{..} -> + hash zkp + [ commit proof groupGen pubKey + , commit proof encryption_nonce encFactor + ] == proof_challenge proof + )) decryptionShare_factors decryptionShare_proofs encTally + where zkp = decryptionStatement pubKey + +{- +computeElectionResult :: + Natural -> + [Encryption q] -> + [DecryptionShare q] -> + ElectionResult q +computeElectionResult numBallots encTally decShares +-} diff --git a/hjugement-protocol.cabal b/hjugement-protocol.cabal --- a/hjugement-protocol.cabal +++ b/hjugement-protocol.cabal @@ -2,7 +2,7 @@ -- PVP: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.0.0.20190428 +version: 0.0.0.20190501 category: Politic synopsis: A cryptographic protocol for the Majority Judgment. description: @@ -20,8 +20,11 @@ (TODO) Actually, this protocol is adapted a little bit here to better support a better method of voting known as the . . - A large-public introduction (in french) to Helios-C is available here: - . + * A large-public introduction (in french) to Helios-C is available here: + . + * A more scientific (yet understandable) introduction (in english) to Belenios + (an implementation of Helios-C) is available here: + . . The main properties of this protocol are: . diff --git a/test/HUnit/Arithmetic.hs b/test/HUnit/Arithmetic.hs --- a/test/HUnit/Arithmetic.hs +++ b/test/HUnit/Arithmetic.hs @@ -22,17 +22,19 @@ , testGroup "hash" [ testGroup "WeakParams" [ testCase "[groupGen]" $ - hash "start" [groupGen @WeakParams] @?= inE 80 + hash "start" [groupGen @WeakParams] @?= + fromNatural 100 , testCase "[groupGen, groupGen]" $ - hash "start" [groupGen @WeakParams, groupGen] @?= inE 117 + hash "start" [groupGen @WeakParams, groupGen] @?= + fromNatural 16 ] , testGroup "BeleniosParams" [ testCase "[groupGen]" $ hash "start" [groupGen @BeleniosParams] @?= - inE 1115773133278002110129249165266 + fromNatural 1832875488615060263192702367259 , testCase "[groupGen, groupGen]" $ hash "start" [groupGen @BeleniosParams, groupGen] @?= - inE 1237765159213600087872608890753 + fromNatural 2495277906542783643199702546512 ] ] ] diff --git a/test/HUnit/Election.hs b/test/HUnit/Election.hs --- a/test/HUnit/Election.hs +++ b/test/HUnit/Election.hs @@ -28,10 +28,10 @@ [ testGroup "groupGenInverses" [ testCase "WeakParams" $ List.take 10 (groupGenInverses @WeakParams) @?= - [groupGen^neg (inE i) | i <- [0..9::Int]] + [groupGen^neg (fromNatural n) | n <- [0..9]] , testCase "BeleniosParams" $ List.take 10 (groupGenInverses @BeleniosParams) @?= - [groupGen^neg (inE i) | i <- [0..9::Int]] + [groupGen^neg (fromNatural n) | n <- [0..9]] ] , testGroup "encryptBallot" $ [ testsEncryptBallot @WeakParams