hjugement-protocol 0.0.0.20190501 → 0.0.0.20190511

raw patch · 30 files changed

+2139/−1378 lines, 30 filesdep +criteriondep +deepseqdep −hashabledep −mmorphdep ~QuickCheckPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: criterion, deepseq

Dependencies removed: hashable, mmorph

Dependency ranges changed: QuickCheck

API changes (from Hackage documentation)

Files

• Protocol/Arithmetic.hs +0/−326
• Protocol/Credential.hs +0/−133
• Protocol/Election.hs +0/−597
• README.md +57/−0
• benchmarks/Election.hs +102/−0
• benchmarks/Main.hs +11/−0
• benchmarks/Utils.hs +60/−0
• hjugement-protocol.cabal +63/−53
• src/Voting/Protocol.hs +11/−0
• src/Voting/Protocol/Arithmetic.hs +337/−0
• src/Voting/Protocol/Credential.hs +137/−0
• src/Voting/Protocol/Election.hs +670/−0
• src/Voting/Protocol/Trustees.hs +5/−0
• src/Voting/Protocol/Trustees/All.hs +92/−0
• src/Voting/Protocol/Utils.hs +63/−0
• test/HUnit.hs +0/−13
• test/HUnit/Arithmetic.hs +0/−40
• test/HUnit/Credential.hs +0/−53
• test/HUnit/Election.hs +0/−111
• test/HUnit/Utils.hs +0/−37
• test/Main.hs +0/−15
• tests/HUnit.hs +13/−0
• tests/HUnit/Arithmetic.hs +41/−0
• tests/HUnit/Credential.hs +54/−0
• tests/HUnit/Election.hs +126/−0
• tests/Main.hs +15/−0
• tests/QuickCheck.hs +11/−0
• tests/QuickCheck/Election.hs +151/−0
• tests/QuickCheck/Trustee.hs +37/−0
• tests/Utils.hs +83/−0

@@ -1,326 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-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')-import Data.Function (($), (.))-import Data.Functor ((<$>))-import Data.Int (Int)-import Data.Maybe (Maybe(..))-import Data.Ord (Ord(..))-import Data.Semigroup (Semigroup(..))-import Data.String (IsString(..))-import Numeric.Natural (Natural)-import Prelude (Integer, Integral(..), fromIntegral, Enum(..))-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.ByteString as BS-import qualified Data.List as List-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)--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'.-	---	-- ElGamal's hardness to decrypt requires a large prime number-	-- to form the 'Multiplicative' 'SubGroup'.-	fieldCharac :: Natural---- ** Class 'Additive'-class Additive a where-	zero :: a-	(+) :: a -> a -> a; infixl 6 +-	sum :: Foldable f => f a -> a-	sum = foldl' (+) zero-instance Additive Natural where-	zero = 0-	(+)  = (Num.+)-instance Additive Integer where-	zero = 0-	(+)  = (Num.+)-instance Additive Int where-	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-	one :: a-	(*) :: a -> a -> a; infixl 7 *-instance Multiplicative Natural where-	one = 1-	(*) = (Num.*)-instance Multiplicative Integer where-	one = 1-	(*) = (Num.*)-instance Multiplicative 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)--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))---- ** 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---- | @('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 'E'--- | An exponent of a (necessarily cyclic) 'SubGroup' of a 'PrimeField'.--- The value is always in @[0..'groupOrder'-1]@.-newtype E q = E { unE :: F (P q) }- deriving (Eq,Ord,Show)--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-	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-	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) .-		Random.randomR-		 ( 0`max`toInteger lo-		 , toInteger hi`min`(toInteger (unF (groupOrder @q)) - 1) )-	random =-		first (E . F . fromIntegral) .-		Random.randomR (0, toInteger (unF (groupOrder @q)) - 1)-instance SubGroup q => Enum (E q) 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---- * Type 'RandomGen'-type RandomGen = Random.RandomGen---- | @('randomR' i)@ returns a random integer in @[0..i-1]@.-randomR ::- Monad m =>- 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 =>- 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 '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 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

@@ -1,133 +0,0 @@-module Protocol.Credential where--import Control.Monad (Monad(..), replicateM)-import Data.Bits-import Data.Bool-import Data.Char (Char)-import Data.Either (Either(..))-import Data.Eq (Eq(..))-import Data.Function (($))-import Data.Functor ((<$>))-import Data.Int (Int)-import Data.Maybe (maybe)-import Data.Ord (Ord(..))-import Data.Text (Text)-import Numeric.Natural (Natural)-import Prelude (Integral(..), fromIntegral, div)-import Text.Show (Show)-import qualified Control.Monad.Trans.State.Strict as S-import qualified Crypto.KDF.PBKDF2 as Crypto-import qualified Data.ByteArray as ByteArray-import qualified Data.ByteString as BS-import qualified Data.Char as Char-import qualified Data.List as List-import qualified Data.Text as Text-import qualified Data.Text.Encoding as Text-import qualified System.Random as Random--import Protocol.Arithmetic---- * Type 'Credential'--- | A 'Credential' is a word of @('tokenLength'+1 '==' 15)@-characters--- from a base alphabet of (@'tokenBase' '==' 58)@ characters:--- "123456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz"--- (beware the absence of "0", \"O", \"I", and "l").--- The last character is a checksum.--- The entropy is: @('tokenLength' * log 'tokenBase' / log 2) '==' 82.01… bits@.-newtype Credential = Credential Text- deriving (Eq, Show)--credentialAlphabet :: [Char] -- TODO: make this an array-credentialAlphabet = "123456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz"-tokenBase :: Int-tokenBase = List.length credentialAlphabet-tokenLength ::Int-tokenLength = 14---- | @'randomCredential'@ generates a random 'Credential'.-randomCredential ::- Monad m =>- Random.RandomGen r =>- S.StateT r m Credential-randomCredential = do-	rs <- replicateM tokenLength (randomR (fromIntegral tokenBase))-	let (tot, cs) = List.foldl' (\(acc,ds) d ->-			( acc * tokenBase + d-			, charOfDigit d : ds )-		 ) (zero::Int, []) rs-	let checksum = (neg tot + 53) `mod` 53 -- NOTE: why 53 and not 'tokenBase' ?-	return $ Credential $ Text.reverse $ Text.pack (charOfDigit checksum:cs)-	where-	charOfDigit = (credentialAlphabet List.!!)---- | @'readCredential'@ reads and check the well-formedness of a 'Credential'--- from raw 'Text'.-readCredential :: Text -> Either CredentialError Credential-readCredential s- | Text.length s /= tokenLength + 1 = Left CredentialError_Length- | otherwise = do-	tot <- Text.foldl'-	 (\acc c -> acc >>= \a -> ((a * tokenBase) +) <$> digitOfChar c)-	 (Right (zero::Int))-	 (Text.init s)-	checksum <- digitOfChar (Text.last s)-	if (tot + checksum) `mod` 53 == 0-	then Right (Credential s)-	else Left CredentialError_Checksum-	where-	digitOfChar c =-		maybe (Left $ CredentialError_BadChar c) Right $-		List.elemIndex c credentialAlphabet---- ** Type 'CredentialError'-data CredentialError- =   CredentialError_BadChar Char.Char- |   CredentialError_Checksum- |   CredentialError_Length- deriving (Eq, Show)---- ** Type 'UUID'-newtype UUID = UUID Text- deriving (Eq,Ord,Show)---- | @'randomUUID'@ generates a random 'UUID'.-randomUUID ::- Monad m =>- Random.RandomGen r =>- S.StateT r m UUID-randomUUID = do-	rs <- replicateM tokenLength (randomR (fromIntegral tokenBase))-	return $ UUID $ Text.pack $ charOfDigit <$> rs-	where-	charOfDigit = (credentialAlphabet List.!!)---- ** Type 'SecretKey'-type SecretKey = E---- | @('secretKey' uuid cred)@ returns the 'SecretKey'--- derived from given 'uuid' and 'cred'--- using 'Crypto.fastPBKDF2_SHA256'.-secretKey :: SubGroup q => UUID -> Credential -> SecretKey q-secretKey (UUID uuid) (Credential cred) =-	fromNatural $ BS.foldl'-	 (\acc b -> acc`shiftL`3 + fromIntegral b)-	 (0::Natural)-	 (ByteArray.convert deriv)-	where-	deriv :: BS.ByteString-	deriv =-		Crypto.fastPBKDF2_SHA256-		 Crypto.Parameters-		 { Crypto.iterCounts   = 1000-		 , Crypto.outputLength = 256 `div` 8-		 }-		 (Text.encodeUtf8 cred)-		 (Text.encodeUtf8 uuid)---- ** Type 'PublicKey'-type PublicKey = G---- | @('publicKey' secKey)@ returns the 'PublicKey'--- derived from given 'SecretKey'.-publicKey :: SubGroup q => SecretKey q -> PublicKey q-publicKey = (groupGen ^)

@@ -1,597 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE OverloadedStrings #-}-module Protocol.Election where--import Control.Monad (Monad(..), join, mapM, zipWithM)-import Control.Monad.Morph (MFunctor(..))-import Control.Monad.Trans.Class (MonadTrans(..))-import Data.Bool-import Data.Either (either)-import Data.Eq (Eq(..))-import Data.Foldable (Foldable, foldMap, and)-import Data.Function (($), id, const)-import Data.Functor (Functor, (<$>))-import Data.Functor.Identity (Identity(..))-import Data.Maybe (Maybe(..), fromMaybe)-import Data.Ord (Ord(..))-import Data.Semigroup (Semigroup(..))-import Data.Text (Text)-import Data.Traversable (Traversable(..))-import Data.Tuple (fst, snd, uncurry)-import GHC.Natural (minusNaturalMaybe)-import Numeric.Natural (Natural)-import Prelude (fromIntegral)-import Text.Show (Show(..))-import qualified Control.Monad.Trans.Except as Exn-import qualified Control.Monad.Trans.State.Strict as S-import qualified Data.ByteString as BS-import qualified Data.List as List--import Protocol.Arithmetic-import Protocol.Credential---- * Type 'Encryption'--- | ElGamal-like encryption.--- Its security relies on the /Discrete Logarithm problem/.------ Because ('groupGen' '^'encNonce '^'secKey '==' 'groupGen' '^'secKey '^'encNonce),--- knowing @secKey@, one can divide 'encryption_vault' by @('encryption_nonce' '^'secKey)@--- 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 randomness 'encNonce' used to 'encrypt' the 'clear' text,-   -- equal to @('groupGen' '^'encNonce)@- , encryption_vault :: G q-   -- ^ Encrypted 'clear' text, equal to @('pubKey' '^'r '*' 'groupGen' '^'clear)@- } deriving (Eq,Show)---- | Additive homomorphism.--- Using the fact that: @'groupGen' '^'x '*' 'groupGen' '^'y '==' 'groupGen' '^'(x'+'y)@.-instance SubGroup q => Additive (Encryption q) where-	zero = Encryption one one-	x+y = Encryption-	 (encryption_nonce x * encryption_nonce y)-	 (encryption_vault x * encryption_vault y)---- *** Type 'EncryptionNonce'-type EncryptionNonce = E---- | @('encrypt' pubKey clear)@ returns an ElGamal-like 'Encryption'.------ WARNING: the secret encryption nonce (@encNonce@)--- is returned alongside the 'Encryption'--- 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'.-encrypt ::- Monad m => RandomGen r => SubGroup q =>- PublicKey q -> E q ->- S.StateT r m (EncryptionNonce q, Encryption q)-encrypt pubKey clear = do-	encNonce <- random-	-- NOTE: preserve the 'encNonce' for 'prove' in 'proveEncryption'.-	return $ (encNonce,)-		Encryption-		 { encryption_nonce = groupGen^encNonce-		 , encryption_vault = pubKey  ^encNonce * groupGen^clear-		 }---- * Type 'Proof'--- | 'Proof' of knowledge of a discrete logarithm:--- @(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 to the prover,-   -- but derived from the prover's 'Commitment's and statements-   -- with a collision resistant 'hash'.-   -- Hence the prover cannot chose the 'proof_challenge' to his/her liking.- , proof_response :: E q-   -- ^ A discrete logarithm sent by the prover to the verifier,-   -- as a response to 'proof_challenge'.-   ---   -- 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. <https://hal.inria.fr/hal-01576379 Some ZK security proofs for Belenios>, 2017.-newtype ZKP = ZKP BS.ByteString---- ** Type 'Challenge'-type Challenge = E---- ** Type 'Oracle'--- An 'Oracle' returns the 'Challenge' of the '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--- into a /non-interactive zero-knowledge/ (NIZK) proof.--- 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'--- of the prover's commitments (and statements to be a stronger proof).-type Oracle list q = list (Commitment q) -> Challenge q---- | @('prove' sec commitBases oracle)@--- returns a 'Proof' that @sec@ is known.------ The 'Oracle' is given the 'commitBases'--- raised to the power of the secret nonce of the 'Proof',--- as those are the 'commitBases' that the verifier will obtain--- when composing the 'proof_challenge' and 'proof_response' together--- (in 'commit').------ NOTE: 'sec' is @secKey@ in 'signature_proof' or @encNonce@ 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).------ 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 commitBases oracle = do-	nonce <- random-	let proof_challenge = oracle $ (^ nonce) <$> commitBases-	return Proof-	 { proof_challenge-	 , proof_response = nonce - sec*proof_challenge-	 }---- ** Type 'Commitment'-type Commitment = G---- | @('commit' proof base basePowSec)@ returns a 'Commitment'--- from the given 'Proof' with the knowledge of the verifier.-commit :: SubGroup q => Proof q -> G q -> G q -> Commitment q-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 '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)@,-type Disjunction = G--booleanDisjunctions :: SubGroup q => [Disjunction q]-booleanDisjunctions = List.take 2 groupGenInverses--intervalDisjunctions :: SubGroup q => Opinion q -> Opinion q -> [Disjunction q]-intervalDisjunctions mini maxi =-	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 revealing which 'Opinion' it is.-newtype DisjProof q = DisjProof [Proof q]- deriving (Eq,Show)---- | @('proveEncryption' elecPubKey voterZKP (prevDisjs,nextDisjs) (encNonce,enc))@--- returns a 'DisjProof' that 'enc' 'encrypt's--- 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],[Disjunction q]) ->- (EncryptionNonce q, Encryption q) ->- 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-	let prevProofs = fst <$> prevFakes-	let nextProofs = fst <$> nextFakes-	let challengeSum =-		sum (proof_challenge <$> prevProofs) +-		sum (proof_challenge <$> nextProofs)-	let statement = encryptionStatement voterZKP enc-	correctProof <- prove encNonce [groupGen, elecPubKey] $-	 -- 'Oracle'-	 \correctCommitments ->-		let commitments =-			foldMap snd prevFakes <>-			correctCommitments <>-			foldMap snd nextFakes in-		hash statement commitments - challengeSum-	return $ DisjProof $ prevProofs <> (correctProof : nextProofs)-	where-	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'-		-- instead of correct ones.-		proof_challenge <- random-		proof_response  <- random-		let proof = Proof{..}-		return (proof, encryptionCommitments elecPubKey enc (disj, proof))--verifyEncryption ::- Monad m =>- SubGroup q =>- PublicKey q -> ZKP ->- [Disjunction q] ->- (Encryption q, DisjProof q) ->- Exn.ExceptT ErrorValidateEncryption m Bool-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 voterZKP enc) commitments-	where-	challengeSum = sum (proof_challenge <$> proofs)-	commitments = foldMap-	 (encryptionCommitments elecPubKey enc)-	 (List.zip disjs proofs)---- ** Hashing-encryptionStatement :: SubGroup q => ZKP -> Encryption q -> BS.ByteString-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' elecPubKey enc (disj,proof))@--- returns the 'Commitment's with only the knowledge of the verifier.------ The 'Proof' comes from 'prove' of @fakeProof@ in 'proveEncryption'.-encryptionCommitments ::- SubGroup q =>- PublicKey q -> Encryption q ->- (Disjunction q, Proof q) -> [G q]-encryptionCommitments elecPubKey Encryption{..} (disj, proof) =-	[ commit proof groupGen encryption_nonce-	  -- == groupGen ^ 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 'ErrorValidateEncryption'--- | Error raised by 'verifyEncryption'.-data ErrorValidateEncryption- =   ErrorValidateEncryption_InvalidProofLength Natural Natural-     -- ^ When the number of proofs is different than-     -- the number of 'Disjunction's.- deriving (Eq,Show)---- * Type 'Question'-data Question q = Question- { question_text    :: Text- , question_choices :: [Text]- , question_mini    :: Opinion q- , question_maxi    :: Opinion q- -- , question_blank :: Maybe Bool- } deriving (Eq, Show)---- * Type 'Answer'-data Answer q = Answer- { answer_opinions :: [(Encryption q, DisjProof q)]-   -- ^ Encrypted 'Opinion' for each 'question_choices'-   -- with a 'DisjProof' that they belong to [0,1].- , answer_sumProof :: DisjProof q-   -- ^ Proofs that the sum of the 'Opinon's encrypted in 'answer_opinions'-   -- is an element of @[mini..maxi]@.- -- , answer_blankProof ::- } deriving (Eq,Show)---- | @('encryptAnswer' elecPubKey zkp quest opinions)@--- returns an 'Answer' validable by 'verifyAnswer',--- unless an 'ErrorAnswer' is returned.-encryptAnswer ::- Monad m => RandomGen r => SubGroup q =>- PublicKey q -> ZKP ->- Question q -> [Bool] ->- S.StateT r (Exn.ExceptT ErrorAnswer m) (Answer q)-encryptAnswer elecPubKey zkp Question{..} opinionsBools- | not (question_mini <= opinionsSum && opinionsSum <= question_maxi) =-	lift $ Exn.throwE $-		ErrorAnswer_WrongSumOfOpinions-		 (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 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--verifyAnswer ::- SubGroup q =>- PublicKey q -> ZKP ->- Question q -> Answer q -> Bool-verifyAnswer elecPubKey zkp Question{..} Answer{..}- | List.length question_choices /= List.length answer_opinions = False- | otherwise = either (const False) id $ Exn.runExcept $ do-	validOpinions <--		verifyEncryption elecPubKey zkp booleanDisjunctions-		 `traverse` answer_opinions-	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- , election_description :: Text- , election_publicKey   :: PublicKey q- , election_questions   :: [Question q]- , election_uuid        :: UUID- , election_hash        :: Hash -- TODO: serialize to JSON to calculate this- } deriving (Eq,Show)---- ** Type 'Hash'-newtype Hash = Hash Text- deriving (Eq,Ord,Show)---- * Type 'Ballot'-data Ballot q = Ballot- { ballot_answers       :: [Answer q]- , ballot_signature     :: Maybe (Signature q)- , ballot_election_uuid :: UUID- , ballot_election_hash :: Hash- }---- | @('encryptBallot' elec ('Just' secKey) opinionsByQuest)@--- returns a 'Ballot' signed by 'secKey' (the voter's secret key)--- where 'opinionsByQuest' is a list of 'Opinion's--- on each 'question_choices' of each 'election_questions'.-encryptBallot ::- Monad m => RandomGen r => SubGroup q =>- Election q -> Maybe (SecretKey q) -> [[Bool]] ->- S.StateT r (Exn.ExceptT ErrorBallot m) (Ballot q)-encryptBallot Election{..} secKeyMay opinionsByQuest- | List.length election_questions /= List.length opinionsByQuest =-	lift $ Exn.throwE $-		ErrorBallot_WrongNumberOfAnswers-		 (fromIntegral $ List.length opinionsByQuest)-		 (fromIntegral $ List.length election_questions)- | otherwise = do-	let (voterKeys, voterZKP) =-		case secKeyMay of-		 Nothing -> (Nothing, ZKP "")-		 Just secKey ->-			( Just (secKey, pubKey)-			, ZKP (bytesNat pubKey) )-			where pubKey = publicKey secKey-	ballot_answers <--		hoist (Exn.withExceptT ErrorBallot_Answer) $-			zipWithM (encryptAnswer election_publicKey voterZKP)-			 election_questions opinionsByQuest-	ballot_signature <- case voterKeys of-	 Nothing -> return Nothing-	 Just (secKey, signature_publicKey) -> do-		signature_proof <--			prove secKey (Identity groupGen) $-			 \(Identity commitment) ->-				hash-				 -- 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-	 { ballot_answers-	 , ballot_election_hash = election_hash-	 , ballot_election_uuid = election_uuid-	 , ballot_signature-	 }--verifyBallot :: SubGroup q => Election q -> Ballot q -> Bool-verifyBallot Election{..} Ballot{..} =-	ballot_election_uuid == election_uuid &&-	ballot_election_hash == election_hash &&-	List.length election_questions == List.length ballot_answers &&-	let (isValidSign, zkpSign) =-		case ballot_signature of-		 Nothing -> (True, ZKP "")-		 Just Signature{..} ->-			let zkp = ZKP (bytesNat signature_publicKey) in-			(, zkp) $-				proof_challenge signature_proof == hash-				 (signatureCommitments zkp (commit signature_proof groupGen signature_publicKey))-				 (signatureStatement ballot_answers)-	in-	and $ isValidSign :-		List.zipWith (verifyAnswer election_publicKey zkpSign)-		 election_questions ballot_answers---- ** Type 'Signature'--- | Schnorr-like signature.------ 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 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' voterZKP commitment)@-signatureCommitments :: SubGroup q => ZKP -> Commitment q -> BS.ByteString-signatureCommitments (ZKP voterZKP) commitment =-	"sig|"<>voterZKP<>"|"<>bytesNat commitment<>"|"---- ** Type 'ErrorBallot'--- | Error raised by 'encryptBallot'.-data ErrorBallot- =   ErrorBallot_WrongNumberOfAnswers Natural Natural-     -- ^ When the number of answers-     -- is different than the number of questions.- |   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--}

@@ -0,0 +1,57 @@+# Voting protocol++## Ballot+Ballots are encrypted using public-key cryptography+secured by the <i>Discrete Logarithm problem</i>:+finding `x` in <code>(g^x `mod` p)</code>, where `p` is a large prime+and `g` a generator of `Gq`, the multiplicative subgroup of order `q`,+in `Fp` (the finite prime field whose characteristic is `p`).++Here, `p` is 2048-bit and `q` is 256-bit.++The signing (Schnorr-like), the encrypting (ElGamal-like)+and the <i>Decisional Diffe Hellman</i> (DDH) assumption,+all rely on the hardness of that problem.++### Ballot signing+The <i>Schnorr protocol</i> is used to prove that a voter has knowledge+of the secret key used to sign their votes.++### Voter's credential+A voter's credential is a secret key (the signing key)+from which a public part can be derived (the verification key).++The association between the public part and the corresponding voter's identity+does not need to be known, and actually should not be disclosed to satisfy+e.g. the French requirements regarding voting systems.+Using credentials prevent the submission of duplicated ballots+(because they are added as an additional input to the random oracle+in the <i>non-interactive zero-knowledge</i> (NIZK) proofs for ciphertext well-formedness).+This allows a testing of duplicates which depends only on the size of the number of voters,+and thus enables Helios-C to scale for larger elections while attaining correctness.++## Tallying+Ballots are added without being decrypted+because adding (multiplying actually) ciphertexts then decrypting,+is like decrypting then adding plaintexts (<i>additive homomorphism</i>).+Which requires to solve the <i>Discrete Logarithm Problem</i>+for numbers in the order of the number of voters,+which is not hard for small numbers (with a lookup table as here,+or with Pollard’s rho algorithm for logarithms).++## Verifying+The <i>Chaum-Pedersen protocol</i> (proving an equality of discrete logarithms)+is used to prove that ciphertexts are well-formed+(encrypting a 0 or a 1… or any expected natural) without decrypting them.+Which is known as a <i>Disjunctive Chaum-Pedersen</i> proof of partial knowledge.  +See: [Some ZK security proofs for Belenios](https://hal.inria.fr/hal-01576379).++A <i>strong Fiat-Shamir transformation</i> is used+to transform the <i>interactive zero-knowledge</i> (IZK) <i>Chaum-Pedersen protocol</i>+into a <i>non-interactive zero-knowledge</i> (NIZK) proof, using a SHA256 hash.  +See: [How not to Prove Yourself: Pitfalls of the Fiat-Shamir Heuristic and Applications to Helios](https://eprint.iacr.org/2016/771.pdf).++## Public Key Infrastructure+(TODO) A Pedersen's <i>distributed key generation</i> (DKG) protocol+coupled with ElGamal keys (under the DDH assumption),+is used to have a fully distributed semantically secure encryption.

@@ -0,0 +1,102 @@+{-# LANGUAGE OverloadedStrings #-}+module Election where++import qualified Data.List as List+import qualified Data.Text as Text+import qualified Text.Printf as Printf++import Voting.Protocol+import Utils++makeElection :: SubGroup q => Int -> Int -> Election q+makeElection nQuests nChoices = Election+ { election_name = Text.pack $ "elec"<>show nQuests<>show nChoices+ , election_description = "benchmarkable election"+ , election_uuid+ , election_publicKey =+	let secKey = credentialSecretKey election_uuid (Credential "xLcs7ev6Jy6FHHE") in+	publicKey secKey+ , election_hash = Hash "" -- FIXME: when implemented+ , election_questions =+	(<$> [1..nQuests]) $ \quest -> Question+	 { question_text = Text.pack $ "quest"<>show quest+	 , question_choices = (<$> [1..nChoices]) $ \choice -> Text.pack $ "choice"<>show choice+	 , question_mini = one+	 , question_maxi = one -- sum $ List.replicate nChoices one+	 }+ } where election_uuid = UUID "xLcs7ev6Jy6FHH"++makeVotes :: Election q -> [[Bool]]+makeVotes Election{..} =+	[ True : List.tail [ False | _choice <- question_choices quest ]+	| quest <- election_questions+	]++makeBallot :: forall q. SubGroup q => Election q -> Ballot q+makeBallot elec =+	case runExcept $ (`evalStateT` mkStdGen seed) $ do+		ballotSecKey :: SecretKey q <- randomSecretKey+		encryptBallot elec (Just ballotSecKey) $+			makeVotes elec of+	 Right ballot -> ballot+	 Left err -> error ("encryptBallot: "<>show err)+	where+	seed = 0++titleElection :: Election q -> String+titleElection Election{..} =+	Printf.printf "(questions=%i)×(choices=%i)==%i"+	 nQuests nChoices (nQuests * nChoices)+	where+	nQuests  = List.length election_questions+	nChoices = List.foldr max 0 $ List.length . question_choices <$> election_questions++benchEncryptBallot :: forall q. Params q => Int -> Int -> Benchmark+benchEncryptBallot nQuests nChoices =+	env setupEnv $ \ ~elec ->+		bench (titleElection elec) $+			nf makeBallot elec+	where+	setupEnv = do+		let elec :: Election q = makeElection nQuests nChoices+		return elec++benchVerifyBallot :: forall q. Params q => Int -> Int -> Benchmark+benchVerifyBallot nQuests nChoices =+	env setupEnv $ \ ~(elec,ballot) ->+		bench (titleElection elec) $+			nf (verifyBallot elec) ballot+	where+	setupEnv = do+		let elec :: Election q = makeElection nQuests nChoices+		let ballot = makeBallot elec+		return (elec,ballot)++benchmarks :: [Benchmark]+benchmarks =+ let inputs =+	 [ (nQ,nC)+	 | nQ <- [1,5,10,15,20,25]+	 , nC <- [5,7]+	 ] in+ [ bgroup "WeakParams"+	 [ bgroup "encryptBallot"+		 [ benchEncryptBallot @WeakParams nQuests nChoices+		 | (nQuests,nChoices) <- inputs+		 ]+	 , bgroup "verifyBallot"+		 [ benchVerifyBallot @BeleniosParams nQuests nChoices+		 | (nQuests,nChoices) <- inputs+		 ]+	 ]+ , bgroup "BeleniosParams"+	 [ bgroup "encryptBallot"+		 [ benchEncryptBallot @BeleniosParams nQuests nChoices+		 | (nQuests,nChoices) <- inputs+		 ]+	 , bgroup "verifyBallot"+		 [ benchVerifyBallot @BeleniosParams nQuests nChoices+		 | (nQuests,nChoices) <- inputs+		 ]+	 ]+ ]

@@ -0,0 +1,11 @@+module Main where++import Criterion.Main+import qualified Election+import Utils++main :: IO ()+main =+	defaultMain $ join+	 [ Election.benchmarks+	 ]

@@ -0,0 +1,60 @@+module Utils+ ( module Criterion.Main+ , module Data.Bool+ , Applicative(..)+ , Monad(..), forM, join, replicateM, unless, when+ , Eq(..)+ , Either(..), either, isLeft, isRight+ , ($), (.), id, const, flip+ , (<$>)+ , Int+ , IO+ , Maybe(..)+ , Monoid(..), Semigroup(..)+ , Ord(..)+ , String+ , Text+ , Word8+ , Num, Fractional(..), Integral(..), Integer, fromIntegral+ , min+ , max+ , Show(..)+ , MonadTrans(..)+ , ExceptT+ , runExcept+ , throwE+ , StateT+ , evalStateT+ , mkStdGen+ , error+ , debug+ ) where++import Control.Applicative (Applicative(..))+import Control.Monad+import Control.Monad.Trans.Class+import Control.Monad.Trans.Except+import Control.Monad.Trans.State.Strict+import Criterion.Main+import Data.Bool+import Data.Either (Either(..), either, isLeft, isRight)+import Data.Eq (Eq(..))+import Data.Function+import Data.Functor ((<$>))+import Data.Int (Int)+import Data.Maybe (Maybe(..))+import Data.Monoid (Monoid(..))+import Data.Ord (Ord(..))+import Data.Semigroup (Semigroup(..))+import Data.String (String)+import Data.Text (Text)+import Data.Word (Word8)+import Debug.Trace+import Prelude (Num(..), Fractional(..), Integral(..), Integer, undefined, fromIntegral, error)+import System.IO (IO)+import System.Random (mkStdGen)+import Text.Show (Show(..))++debug :: Show a => String -> a -> a+debug msg x = trace (msg<>": "<>show x) x+

@@ -2,7 +2,7 @@ -- PVP:  +-+------- breaking API changes --       | | +----- non-breaking API additions --       | | | +--- code changes with no API change-version: 0.0.0.20190501+version: 0.0.0.20190511 category: Politic synopsis: A cryptographic protocol for the Majority Judgment. description:@@ -40,48 +40,7 @@     and that the tallying authorities did their job properly (/universal verifiability/).   .   * /private/: the identities of the voters who cast a vote are not publicly revealed.-  .-  More specifically, in this protocol :-  .-  * Ballots are encrypted using public-key cryptography-    secured by the /Discrete Logarithm problem/:-    finding @x@ in @g^x `mod` p@, where @p@ is a large prime-    and @g@ a generator of @Gq@, the multiplicative subgroup of order @q@,-    in @Fp@ (the finite prime field whose characteristic is @p@).-    Here, @p@ is 2048-bit and @q@ is 256-bit.-    The signing (Schnorr-like), the encrypting (ElGamal-like)-    and the /Decisional Diffe Hellman/ (DDH) assumption,-    all rely on the hardness of that problem.-  * Ballots are added without being decrypted-    because adding (multiplying actually) ciphertexts then decrypting,-    is like decrypting then adding plaintexts (/additive homomorphism/).-    Which requires to solve the /Discrete Logarithm Problem/-    for numbers in the order of the number of voters,-    which is not hard for small numbers (with a lookup table as here,-    or with Pollard’s rho algorithm for logarithms).-  * The /Schnorr protocol/ is used to prove that a voter has knowledge-    of the secret key used to sign their votes.-    A voter's credentials is a secret key (the signing key)-    that has a public part (the verification key).-    The association between the public part and the corresponding voter’s identity-    does not need to be known, and actually should not be disclosed to satisfy-    e.g. the French requirements regarding voting systems.-    Using credentials prevent the submission of duplicated ballots-    (because they are added as an additional input to the random oracle-    in the /non-interactive zero-knowledge/ (NIZK) proofs for ciphertext well-formedness).-    This allows a testing of duplicates which depends only on the size of the number of voters,-    and thus enables Helios-C to scale for larger elections while attaining correctness.-  * The /Chaum-Pedersen protocol/ (proving that equality of discrete logarithms)-    is used to prove that ciphertexts are well-formed-    (encrypting a 0 or a 1… or any expected natural) without decrypting them.-    Which is known as a /Disjunctive Chaum-Pedersen/ proof of partial knowledge.-  * A /strong Fiat-Shamir transformation/ is used-    to transform the /interactive zero-knowledge/ (IZK) /Chaum-Pedersen protocol/-    into a /non-interactive zero-knowledge/ (NIZK) proof, using a SHA256 hash.-  * (TODO) A Pedersen's /distributed key generation/ (DKG) protocol-    coupled with ElGamal keys (under the DDH assumption),-    is used to have a fully distributed semantically secure encryption.-extra-doc-files: +extra-doc-files: README.md license: GPL-3 license-file: COPYING stability: experimental@@ -102,10 +61,15 @@  type:     git  Library+  hs-source-dirs: src   exposed-modules:-    Protocol.Arithmetic-    Protocol.Credential-    Protocol.Election+    Voting.Protocol+    Voting.Protocol.Arithmetic+    Voting.Protocol.Credential+    Voting.Protocol.Election+    Voting.Protocol.Trustees+    Voting.Protocol.Trustees.All+    Voting.Protocol.Utils   default-language: Haskell2010   default-extensions:     AllowAmbiguousTypes@@ -141,8 +105,9 @@     -- , fixed-vector >= 1.1     -- , hashable >= 1.2.6     , memory >= 0.14-    , mmorph >= 1.1+    -- , mmorph >= 1.1     -- , monad-classes >= 0.3+    , deepseq >= 1.4     , random >= 1.1     -- , reflection >= 2.1     , text >= 1.2@@ -151,15 +116,17 @@  Test-Suite hjugement-protocol-test   type: exitcode-stdio-1.0-  hs-source-dirs: test+  hs-source-dirs: tests   main-is: Main.hs   other-modules:     HUnit     HUnit.Arithmetic     HUnit.Credential     HUnit.Election-    HUnit.Utils-    -- QuickCheck+    QuickCheck+    QuickCheck.Election+    QuickCheck.Trustee+    Utils   default-language: Haskell2010   default-extensions:     AllowAmbiguousTypes@@ -191,8 +158,8 @@       hjugement-protocol     , base >= 4.6 && < 5     , containers >= 0.5-    , hashable >= 1.2.6-    , QuickCheck >= 2.0+    -- , hashable >= 1.2.6+    , QuickCheck >= 2.11     -- , monad-classes >= 0.3     , random >= 1.1     -- , reflection >= 2.1@@ -201,4 +168,47 @@     , tasty-quickcheck     , text >= 1.2     , transformers >= 0.5-    , unordered-containers >= 0.2.8+    -- , unordered-containers >= 0.2.8++Benchmark hjugement-protocol-benchmark+  type: exitcode-stdio-1.0+  hs-source-dirs: benchmarks+  main-is: Main.hs+  default-language: Haskell2010+  other-modules:+    Election+    Utils+  default-extensions:+    AllowAmbiguousTypes+    ConstraintKinds+    DefaultSignatures+    FlexibleContexts+    FlexibleInstances+    GeneralizedNewtypeDeriving+    LambdaCase+    MonoLocalBinds+    MultiParamTypeClasses+    NamedFieldPuns+    NoImplicitPrelude+    NoMonomorphismRestriction+    RecordWildCards+    ScopedTypeVariables+    TupleSections+    TypeApplications+    TypeFamilies+    TypeOperators+    UndecidableInstances+  ghc-options:+    -Wall+    -Wincomplete-uni-patterns+    -Wincomplete-record-updates+    -fno-warn-tabs+  build-depends:+    base >= 4.6 && < 5+    , hjugement-protocol+    , containers >= 0.5+    , criterion >= 1.4+    , QuickCheck >= 2.11+    , random >= 1.1+    , text >= 1.2+    , transformers >= 0.5

@@ -0,0 +1,11 @@+module Voting.Protocol+ ( module Voting.Protocol.Arithmetic+ , module Voting.Protocol.Credential+ , module Voting.Protocol.Election+ , module Voting.Protocol.Trustees+ ) where++import Voting.Protocol.Arithmetic+import Voting.Protocol.Credential+import Voting.Protocol.Election+import Voting.Protocol.Trustees

@@ -0,0 +1,337 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Voting.Protocol.Arithmetic+ ( module Voting.Protocol.Arithmetic+ , Natural+ , Random.RandomGen+ ) where++import Control.Arrow (first)+import Control.DeepSeq (NFData)+import Control.Monad (Monad(..))+import Data.Bits+import Data.Bool+import Data.Eq (Eq(..))+import Data.Foldable (Foldable, foldl')+import Data.Function (($), (.))+import Data.Functor ((<$>))+import Data.Int (Int)+import Data.Maybe (Maybe(..))+import Data.Ord (Ord(..))+import Data.Semigroup (Semigroup(..))+import Data.String (String, IsString(..))+import Numeric.Natural (Natural)+import Prelude (Integer, Integral(..), fromIntegral, Enum(..))+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.ByteString as BS+import qualified Data.List as List+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'.+	--+	-- ElGamal's hardness to decrypt requires a large prime number+	-- to form the 'Multiplicative' 'SubGroup'.+	fieldCharac :: Natural++-- ** Class 'Additive'+class Additive a where+	zero :: a+	(+) :: a -> a -> a; infixl 6 ++	sum :: Foldable f => f a -> a+	sum = foldl' (+) zero+instance Additive Natural where+	zero = 0+	(+)  = (Num.+)+instance Additive Integer where+	zero = 0+	(+)  = (Num.+)+instance Additive Int where+	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+	one :: a+	(*) :: a -> a -> a; infixl 7 *+instance Multiplicative Natural where+	one = 1+	(*) = (Num.*)+instance Multiplicative Integer where+	one = 1+	(*) = (Num.*)+instance Multiplicative 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))++-- ** 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++groupGenPowers :: SubGroup q => [G q]+groupGenPowers = go one+	where go g = g : go (g * groupGen)++-- | @('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 'E'+-- | An exponent of a (necessarily cyclic) 'SubGroup' of a 'PrimeField'.+-- 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+	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+	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) .+		Random.randomR+		 ( 0`max`toInteger lo+		 , toInteger hi`min`(toInteger (unF (groupOrder @q)) - 1) )+	random =+		first (E . F . fromIntegral) .+		Random.randomR (0, toInteger (unF (groupOrder @q)) - 1)+instance SubGroup q => Enum (E q) 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 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

@@ -0,0 +1,137 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+module Voting.Protocol.Credential where++import Control.DeepSeq (NFData)+import Control.Monad (Monad(..), replicateM)+import Data.Bits+import Data.Bool+import Data.Char (Char)+import Data.Either (Either(..))+import Data.Eq (Eq(..))+import Data.Function (($))+import Data.Functor ((<$>))+import Data.Int (Int)+import Data.Maybe (maybe)+import Data.Ord (Ord(..))+import Data.Text (Text)+import GHC.Generics (Generic)+import Numeric.Natural (Natural)+import Prelude (Integral(..), fromIntegral, div)+import Text.Show (Show)+import qualified Control.Monad.Trans.State.Strict as S+import qualified Crypto.KDF.PBKDF2 as Crypto+import qualified Data.ByteArray as ByteArray+import qualified Data.ByteString as BS+import qualified Data.Char as Char+import qualified Data.List as List+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import qualified System.Random as Random++import Voting.Protocol.Arithmetic++-- * Type 'Credential'+-- | A 'Credential' is a word of @('tokenLength'+1 '==' 15)@-characters+-- from a base alphabet of (@'tokenBase' '==' 58)@ characters:+-- "123456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz"+-- (beware the absence of "0", \"O", \"I", and "l").+-- The last character is a checksum.+-- The entropy is: @('tokenLength' * log 'tokenBase' / log 2) '==' 82.01… bits@.+newtype Credential = Credential Text+ deriving (Eq,Show,Generic,NFData)++credentialAlphabet :: [Char] -- TODO: make this an array+credentialAlphabet = "123456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz"+tokenBase :: Int+tokenBase = List.length credentialAlphabet+tokenLength ::Int+tokenLength = 14++-- | @'randomCredential'@ generates a random 'Credential'.+randomCredential ::+ Monad m =>+ Random.RandomGen r =>+ S.StateT r m Credential+randomCredential = do+	rs <- replicateM tokenLength (randomR (fromIntegral tokenBase))+	let (tot, cs) = List.foldl' (\(acc,ds) d ->+			( acc * tokenBase + d+			, charOfDigit d : ds )+		 ) (zero::Int, []) rs+	let checksum = (neg tot + 53) `mod` 53 -- NOTE: why 53 and not 'tokenBase' ?+	return $ Credential $ Text.reverse $ Text.pack (charOfDigit checksum:cs)+	where+	charOfDigit = (credentialAlphabet List.!!)++-- | @'readCredential'@ reads and check the well-formedness of a 'Credential'+-- from raw 'Text'.+readCredential :: Text -> Either CredentialError Credential+readCredential s+ | Text.length s /= tokenLength + 1 = Left CredentialError_Length+ | otherwise = do+	tot <- Text.foldl'+	 (\acc c -> acc >>= \a -> ((a * tokenBase) +) <$> digitOfChar c)+	 (Right (zero::Int))+	 (Text.init s)+	checksum <- digitOfChar (Text.last s)+	if (tot + checksum) `mod` 53 == 0+	then Right (Credential s)+	else Left CredentialError_Checksum+	where+	digitOfChar c =+		maybe (Left $ CredentialError_BadChar c) Right $+		List.elemIndex c credentialAlphabet++-- ** Type 'CredentialError'+data CredentialError+ =   CredentialError_BadChar Char.Char+ |   CredentialError_Checksum+ |   CredentialError_Length+ deriving (Eq,Show,Generic,NFData)++-- ** Type 'UUID'+newtype UUID = UUID Text+ deriving (Eq,Ord,Show,Generic,NFData)++-- | @'randomUUID'@ generates a random 'UUID'.+randomUUID ::+ Monad m =>+ Random.RandomGen r =>+ S.StateT r m UUID+randomUUID = do+	rs <- replicateM tokenLength (randomR (fromIntegral tokenBase))+	return $ UUID $ Text.pack $ charOfDigit <$> rs+	where+	charOfDigit = (credentialAlphabet List.!!)++-- ** Type 'SecretKey'+type SecretKey = E++-- | @('credentialSecretKey' uuid cred)@ returns the 'SecretKey'+-- derived from given 'uuid' and 'cred'+-- using 'Crypto.fastPBKDF2_SHA256'.+credentialSecretKey :: SubGroup q => UUID -> Credential -> SecretKey q+credentialSecretKey (UUID uuid) (Credential cred) =+	fromNatural $ BS.foldl'+	 (\acc b -> acc`shiftL`3 + fromIntegral b)+	 (0::Natural)+	 (ByteArray.convert deriv)+	where+	deriv :: BS.ByteString+	deriv =+		Crypto.fastPBKDF2_SHA256+		 Crypto.Parameters+		 { Crypto.iterCounts   = 1000+		 , Crypto.outputLength = 256 `div` 8+		 }+		 (Text.encodeUtf8 cred)+		 (Text.encodeUtf8 uuid)++-- ** Type 'PublicKey'+type PublicKey = G++-- | @('publicKey' secKey)@ returns the 'PublicKey'+-- derived from given 'SecretKey'.+publicKey :: SubGroup q => SecretKey q -> PublicKey q+publicKey = (groupGen ^)

@@ -0,0 +1,670 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+module Voting.Protocol.Election where++import Control.DeepSeq (NFData)+import Control.Monad (Monad(..), join, mapM, replicateM, unless, zipWithM)+import Control.Monad.Trans.Class (MonadTrans(..))+import Control.Monad.Trans.Except (Except, ExceptT, runExcept, throwE, withExceptT)+import Data.Bool+import Data.Either (either)+import Data.Eq (Eq(..))+import Data.Foldable (Foldable, foldMap, and)+import Data.Function (($), id, const)+import Data.Functor (Functor, (<$>))+import Data.Functor.Identity (Identity(..))+import Data.Maybe (Maybe(..), fromMaybe, maybe)+import Data.Ord (Ord(..))+import Data.Semigroup (Semigroup(..))+import Data.Text (Text)+import Data.Traversable (Traversable(..))+import Data.Tuple (fst, snd, uncurry)+import GHC.Natural (minusNaturalMaybe)+import GHC.Generics (Generic)+import Numeric.Natural (Natural)+import Prelude (fromIntegral)+import Text.Show (Show(..))+import qualified Control.Monad.Trans.State.Strict as S+import qualified Data.ByteString as BS+import qualified Data.List as List+import qualified Data.Map.Strict as Map++import Voting.Protocol.Utils+import Voting.Protocol.Arithmetic+import Voting.Protocol.Credential++-- * Type 'Encryption'+-- | ElGamal-like encryption.+-- Its security relies on the /Discrete Logarithm problem/.+--+-- Because ('groupGen' '^'encNonce '^'secKey '==' 'groupGen' '^'secKey '^'encNonce),+-- knowing @secKey@, one can divide 'encryption_vault' by @('encryption_nonce' '^'secKey)@+-- 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 randomness 'encNonce' used to 'encrypt' the 'clear' text,+   -- equal to @('groupGen' '^'encNonce)@+ , encryption_vault :: G q+   -- ^ Encrypted 'clear' text,+   -- equal to @('pubKey' '^'encNone '*' 'groupGen' '^'clear)@+ } deriving (Eq,Show,Generic,NFData)++-- | Additive homomorphism.+-- Using the fact that: @'groupGen' '^'x '*' 'groupGen' '^'y '==' 'groupGen' '^'(x'+'y)@.+instance SubGroup q => Additive (Encryption q) where+	zero = Encryption one one+	x+y = Encryption+	 (encryption_nonce x * encryption_nonce y)+	 (encryption_vault x * encryption_vault y)++-- *** Type 'EncryptionNonce'+type EncryptionNonce = E++-- | @('encrypt' pubKey clear)@ returns an ElGamal-like 'Encryption'.+--+-- WARNING: the secret encryption nonce (@encNonce@)+-- is returned alongside the 'Encryption'+-- 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 'SecretKey' associated with 'pubKey'.+encrypt ::+ Monad m => RandomGen r => SubGroup q =>+ PublicKey q -> E q ->+ S.StateT r m (EncryptionNonce q, Encryption q)+encrypt pubKey clear = do+	encNonce <- random+	-- NOTE: preserve the 'encNonce' for 'prove' in 'proveEncryption'.+	return $ (encNonce,)+		Encryption+		 { encryption_nonce = groupGen^encNonce+		 , encryption_vault = pubKey  ^encNonce * groupGen^clear+		 }++-- * Type 'Proof'+-- | 'Proof' of knowledge of a discrete logarithm:+-- @(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 to the prover,+   -- but derived from the prover's 'Commitment's and statements+   -- with a collision resistant 'hash'.+   -- Hence the prover cannot chose the 'proof_challenge' to his/her liking.+ , proof_response :: E q+   -- ^ A discrete logarithm sent by the prover to the verifier,+   -- as a response to 'proof_challenge'.+   --+   -- 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),+   -- the prover was not able to choose 'proof_challenge'+   -- yet was able to compute a 'proof_response' such that+   -- (@commitment '==' base '^' 'proof_response' '*' basePowSec '^' 'proof_challenge'@),+   -- that is to say: @('proof_response' '==' logBase base 'commitment' '-' sec '*' 'proof_challenge')@,+   -- therefore the prover knows 'sec'.+   --+   -- The prover choses 'commitment' to be a random power of @base@,+   -- to ensure that each 'prove' does not reveal any information+   -- about its secret.+ } deriving (Eq,Show,Generic,NFData)++-- ** Type 'ZKP'+-- | Zero-knowledge proof.+--+-- A protocol is /zero-knowledge/ if the verifier+-- learns nothing from the protocol except that the prover+-- knows the secret.+--+-- DOC: Mihir Bellare and Phillip Rogaway. Random oracles are practical:+--      A paradigm for designing efficient protocols. In ACM-CCS’93, 1993.+newtype ZKP = ZKP BS.ByteString++-- ** Type 'Challenge'+type Challenge = E++-- ** Type 'Oracle'+-- An 'Oracle' returns the 'Challenge' of the '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+-- into a /non-interactive zero-knowledge/ (NIZK) proof.+-- 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'+-- of the prover's commitments (and statements to be a stronger proof).+type Oracle list q = list (Commitment q) -> Challenge q++-- | @('prove' sec commitBases oracle)@+-- returns a 'Proof' that @sec@ is known+-- (by proving the knowledge of its discrete logarithm).+--+-- The 'Oracle' is given 'Commitment's equal to the 'commitBases'+-- raised to the power of the secret nonce of the 'Proof',+-- as those are the 'Commitment's that the verifier will obtain+-- when composing the 'proof_challenge' and 'proof_response' together+-- (with 'commit').+--+-- WARNING: for 'prove' to be a so-called /strong Fiat-Shamir transformation/ (not a weak):+-- the statement must be included in the 'hash' (along with the commitments).+--+-- NOTE: a 'random' @nonce@ is used to ensure each 'prove'+-- does not reveal any information regarding the secret @sec@,+-- because two 'Proof's using the same 'Commitment'+-- can be used to deduce @sec@ (using the special-soundness).+prove ::+ Monad m => RandomGen r => SubGroup q => Functor list =>+ E q -> list (G q) -> Oracle list q -> S.StateT r m (Proof q)+prove sec commitBases oracle = do+	nonce <- random+	let commitments = (^ nonce) <$> commitBases+	let proof_challenge = oracle commitments+	return Proof+	 { proof_challenge+	 , proof_response = nonce - sec*proof_challenge+	 }++-- | @('fakeProof')@ returns a 'Proof'+-- whose 'proof_challenge' and 'proof_response' are uniformly chosen at random,+-- instead of @('proof_challenge' '==' 'hash' statement commitments)@+-- and @('proof_response' '==' nonce '+' sec '*' 'proof_challenge')@+-- as a 'Proof' returned by 'prove'.+--+-- Used in 'proveEncryption' to fill the returned 'DisjProof'+-- with fake 'Proof's for all 'Disjunction's but the encrypted one.+fakeProof :: Monad m => RandomGen r => SubGroup q => S.StateT r m (Proof q)+fakeProof = do+	proof_challenge <- random+	proof_response  <- random+	return Proof{..}++-- ** Type 'Commitment'+-- | A commitment from the prover to the verifier.+-- It's a power of 'groupGen' chosen randomly by the prover+-- when making a 'Proof' with 'prove'.+type Commitment = G++-- | @('commit' proof base basePowSec)@ returns a 'Commitment'+-- from the given 'Proof' with the knowledge of the verifier.+commit :: SubGroup q => Proof q -> G q -> G q -> Commitment q+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 '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)@,+type Disjunction = G++booleanDisjunctions :: SubGroup q => [Disjunction q]+booleanDisjunctions = List.take 2 groupGenInverses++intervalDisjunctions :: SubGroup q => Opinion q -> Opinion q -> [Disjunction q]+intervalDisjunctions mini maxi =+	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 revealing which 'Opinion' it is.+newtype DisjProof q = DisjProof [Proof q]+ deriving (Eq,Show,Generic,NFData)++-- | @('proveEncryption' elecPubKey voterZKP (prevDisjs,nextDisjs) (encNonce,enc))@+-- returns a 'DisjProof' that 'enc' 'encrypt's+-- the 'Disjunction' 'd' between 'prevDisjs' and 'nextDisjs'.+--+-- The prover proves that it knows an 'encNonce', such that:+-- @(enc '==' Encryption{encryption_nonce='groupGen' '^'encNonce, encryption_vault=elecPubKey'^'encNonce '*' groupGen'^'d})@+--+-- A /NIZK Disjunctive Chaum Pedersen Logarithm Equality/ is used.+--+-- DOC: Pierrick Gaudry. <https://hal.inria.fr/hal-01576379 Some ZK security proofs for Belenios>, 2017.+proveEncryption ::+ Monad m => RandomGen r => SubGroup q =>+ PublicKey q -> ZKP ->+ ([Disjunction q],[Disjunction q]) ->+ (EncryptionNonce q, Encryption q) ->+ S.StateT r m (DisjProof q)+proveEncryption elecPubKey voterZKP (prevDisjs,nextDisjs) (encNonce,enc) = do+	-- Fake proofs for all 'Disjunction's except the genuine one.+	prevFakeProofs <- replicateM (List.length prevDisjs) fakeProof+	nextFakeProofs <- replicateM (List.length nextDisjs) fakeProof+	let fakeChallengeSum =+		sum (proof_challenge <$> prevFakeProofs) ++		sum (proof_challenge <$> nextFakeProofs)+	let statement = encryptionStatement voterZKP enc+	genuineProof <- prove encNonce [groupGen, elecPubKey] $ \genuineCommitments ->+		let validCommitments = List.zipWith (encryptionCommitments elecPubKey enc) in+		let prevCommitments = validCommitments prevDisjs prevFakeProofs in+		let nextCommitments = validCommitments nextDisjs nextFakeProofs in+		let commitments = join prevCommitments <> genuineCommitments <> join nextCommitments in+		let challenge = hash statement commitments in+		let genuineChallenge = challenge - fakeChallengeSum in+		genuineChallenge+		-- NOTE: here by construction (genuineChallenge == challenge - fakeChallengeSum)+		-- thus (sum (proof_challenge <$> proofs) == challenge)+		-- as checked in 'verifyEncryption'.+	let proofs = prevFakeProofs <> (genuineProof : nextFakeProofs)+	return (DisjProof proofs)++verifyEncryption ::+ Monad m => SubGroup q =>+ PublicKey q -> ZKP ->+ [Disjunction q] -> (Encryption q, DisjProof q) ->+ ExceptT ErrorVerifyEncryption m Bool+verifyEncryption elecPubKey voterZKP disjs (enc, DisjProof proofs) =+	case isoZipWith (encryptionCommitments elecPubKey enc) disjs proofs of+	 Nothing ->+		throwE $ ErrorVerifyEncryption_InvalidProofLength+		 (fromIntegral $ List.length proofs)+		 (fromIntegral $ List.length disjs)+	 Just commitments ->+		return $ challengeSum ==+			hash (encryptionStatement voterZKP enc) (join commitments)+	where+	challengeSum = sum (proof_challenge <$> proofs)++-- ** Hashing+encryptionStatement :: SubGroup q => ZKP -> Encryption q -> BS.ByteString+encryptionStatement (ZKP voterZKP) Encryption{..} =+	"prove|"<>voterZKP<>"|"+	 <> bytesNat encryption_nonce<>","+	 <> bytesNat encryption_vault<>"|"++-- | @('encryptionCommitments' elecPubKey enc disj proof)@+-- returns the 'Commitment's with only the knowledge of the verifier.+--+-- For the prover the 'Proof' comes from @fakeProof@,+-- and for the verifier the 'Proof' comes from the prover.+encryptionCommitments ::+ SubGroup q =>+ PublicKey q -> Encryption q ->+ Disjunction q -> Proof q -> [G q]+encryptionCommitments elecPubKey Encryption{..} disj proof =+	[ commit proof groupGen encryption_nonce+	  -- == groupGen ^ nonce if 'Proof' comes from 'prove'.+	  -- base==groupGen, basePowSec==groupGen^encNonce.+	, commit proof elecPubKey (encryption_vault*disj)+	  -- == elecPubKey ^ nonce if 'Proof' comes from 'prove'+	  -- and 'encryption_vault' encrypts (- logBase groupGen disj).+	  -- base==elecPubKey, basePowSec==elecPubKey^encNonce.+	]++-- ** Type 'ErrorVerifyEncryption'+-- | Error raised by 'verifyEncryption'.+data ErrorVerifyEncryption+ =   ErrorVerifyEncryption_InvalidProofLength Natural Natural+     -- ^ When the number of proofs is different than+     -- the number of 'Disjunction's.+ deriving (Eq,Show)++-- * Type 'Question'+data Question q = Question+ { question_text    :: Text+ , question_choices :: [Text]+ , question_mini    :: Opinion q+ , question_maxi    :: Opinion q+ -- , question_blank :: Maybe Bool+ } deriving (Eq,Show,Generic,NFData)++-- * Type 'Answer'+data Answer q = Answer+ { answer_opinions :: [(Encryption q, DisjProof q)]+   -- ^ Encrypted 'Opinion' for each 'question_choices'+   -- with a 'DisjProof' that they belong to [0,1].+ , answer_sumProof :: DisjProof q+   -- ^ Proofs that the sum of the 'Opinon's encrypted in 'answer_opinions'+   -- is an element of @[mini..maxi]@.+ -- , answer_blankProof ::+ } deriving (Eq,Show,Generic,NFData)++-- | @('encryptAnswer' elecPubKey zkp quest opinions)@+-- returns an 'Answer' validable by 'verifyAnswer',+-- unless an 'ErrorAnswer' is returned.+encryptAnswer ::+ Monad m => RandomGen r => SubGroup q =>+ PublicKey q -> ZKP ->+ Question q -> [Bool] ->+ S.StateT r (ExceptT ErrorAnswer m) (Answer q)+encryptAnswer elecPubKey zkp Question{..} opinionByChoice+ | not (question_mini <= opinionsSum && opinionsSum <= question_maxi) =+	lift $ throwE $+		ErrorAnswer_WrongSumOfOpinions+		 (nat opinionsSum)+		 (nat question_mini)+		 (nat question_maxi)+ | List.length opinions /= List.length question_choices =+	lift $ throwE $+		ErrorAnswer_WrongNumberOfOpinions+		 (fromIntegral $ List.length opinions)+		 (fromIntegral $ List.length question_choices)+ | otherwise = do+	encryptions <- encrypt elecPubKey `mapM` opinions+	individualProofs <- zipWithM+	 (\opinion -> proveEncryption elecPubKey zkp $+		if opinion+		then ([booleanDisjunctions List.!!0],[])+		else ([],[booleanDisjunctions List.!!1]))+	 opinionByChoice 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) <$> opinionByChoice++verifyAnswer ::+ SubGroup q =>+ PublicKey q -> ZKP ->+ Question q -> Answer q -> Bool+verifyAnswer elecPubKey zkp Question{..} Answer{..}+ | List.length question_choices /= List.length answer_opinions = False+ | otherwise = either (const False) id $ runExcept $ do+	validOpinions <-+		verifyEncryption elecPubKey zkp booleanDisjunctions+		 `traverse` answer_opinions+	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,Generic,NFData)++-- * Type 'Election'+data Election q = Election+ { election_name        :: Text+ , election_description :: Text+ , election_publicKey   :: PublicKey q+ , election_questions   :: [Question q]+ , election_uuid        :: UUID+ , election_hash        :: Hash -- TODO: serialize to JSON to calculate this+ } deriving (Eq,Show,Generic,NFData)++-- ** Type 'Hash'+newtype Hash = Hash Text+ deriving (Eq,Ord,Show,Generic,NFData)++-- * Type 'Ballot'+data Ballot q = Ballot+ { ballot_answers       :: [Answer q]+ , ballot_signature     :: Maybe (Signature q)+ , ballot_election_uuid :: UUID+ , ballot_election_hash :: Hash+ } deriving (Generic,NFData)++-- | @('encryptBallot' elec ('Just' ballotSecKey) opinionsByQuest)@+-- returns a 'Ballot' signed by 'secKey' (the voter's secret key)+-- where 'opinionsByQuest' is a list of 'Opinion's+-- on each 'question_choices' of each 'election_questions'.+encryptBallot ::+ Monad m => RandomGen r => SubGroup q =>+ Election q -> Maybe (SecretKey q) -> [[Bool]] ->+ S.StateT r (ExceptT ErrorBallot m) (Ballot q)+encryptBallot Election{..} ballotSecKeyMay opinionsByQuest+ | List.length election_questions /= List.length opinionsByQuest =+	lift $ throwE $+		ErrorBallot_WrongNumberOfAnswers+		 (fromIntegral $ List.length opinionsByQuest)+		 (fromIntegral $ List.length election_questions)+ | otherwise = do+	let (voterKeys, voterZKP) =+		case ballotSecKeyMay of+		 Nothing -> (Nothing, ZKP "")+		 Just ballotSecKey ->+			( Just (ballotSecKey, ballotPubKey)+			, ZKP (bytesNat ballotPubKey) )+			where ballotPubKey = publicKey ballotSecKey+	ballot_answers <-+		S.mapStateT (withExceptT ErrorBallot_Answer) $+			zipWithM (encryptAnswer election_publicKey voterZKP)+			 election_questions opinionsByQuest+	ballot_signature <- case voterKeys of+	 Nothing -> return Nothing+	 Just (ballotSecKey, signature_publicKey) -> do+		signature_proof <-+			prove ballotSecKey (Identity groupGen) $+			 \(Identity commitment) ->+				hash+				 -- 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+	 { ballot_answers+	 , ballot_election_hash = election_hash+	 , ballot_election_uuid = election_uuid+	 , ballot_signature+	 }++verifyBallot :: SubGroup q => Election q -> Ballot q -> Bool+verifyBallot Election{..} Ballot{..} =+	ballot_election_uuid == election_uuid &&+	ballot_election_hash == election_hash &&+	List.length election_questions == List.length ballot_answers &&+	let (isValidSign, zkpSign) =+		case ballot_signature of+		 Nothing -> (True, ZKP "")+		 Just Signature{..} ->+			let zkp = ZKP (bytesNat signature_publicKey) in+			(, zkp) $+				proof_challenge signature_proof == hash+				 (signatureCommitments zkp (commit signature_proof groupGen signature_publicKey))+				 (signatureStatement ballot_answers)+	in+	and $ isValidSign :+		List.zipWith (verifyAnswer election_publicKey zkpSign)+		 election_questions ballot_answers++-- ** Type 'Signature'+-- | Schnorr-like signature.+--+-- 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+ } deriving (Generic,NFData)++-- *** Hashing++-- | @('signatureStatement' 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' voterZKP commitment)@+signatureCommitments :: SubGroup q => ZKP -> Commitment q -> BS.ByteString+signatureCommitments (ZKP voterZKP) commitment =+	"sig|"<>voterZKP<>"|" -- NOTE: this is actually part of the statement+	 <> bytesNat commitment<>"|"++-- ** Type 'ErrorBallot'+-- | Error raised by 'encryptBallot'.+data ErrorBallot+ =   ErrorBallot_WrongNumberOfAnswers Natural Natural+     -- ^ When the number of answers+     -- is different than the number of questions.+ |   ErrorBallot_Answer ErrorAnswer+     -- ^ When 'encryptAnswer' raised an 'ErrorAnswer'.+ deriving (Eq,Show,Generic,NFData)++-- * 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 it didn't cheat.+data DecryptionShare q = DecryptionShare+ { decryptionShare_factors :: [[DecryptionFactor q]]+   -- ^ 'DecryptionFactor' by voter, by 'Question'.+ , decryptionShare_proofs  :: [[Proof q]]+   -- ^ 'Proof's that 'decryptionShare_factors' were correctly computed.+ } deriving (Eq,Show,Generic,NFData)++-- BELENIOS: compute_factor+-- @('proveDecryptionShare' trusteeSecKey encByQuestByBallot)@+proveDecryptionShare ::+ Monad m => SubGroup q => RandomGen r =>+ SecretKey q -> [[Encryption q]] -> S.StateT r m (DecryptionShare q)+proveDecryptionShare secKey encs = do+	res <- (proveDecryptionFactor secKey `mapM`) `mapM` encs+	return $ uncurry DecryptionShare $ List.unzip (List.unzip <$> res)++-- BELENIOS: eg_factor+proveDecryptionFactor ::+ Monad m => SubGroup q => RandomGen r =>+ SecretKey q -> Encryption q -> S.StateT r m (DecryptionFactor q, Proof q)+proveDecryptionFactor secKey Encryption{..} = do+	proof <- prove secKey [groupGen, encryption_nonce] (hash zkp)+	return (encryption_nonce^secKey, proof)+	where zkp = decryptionShareStatement (publicKey secKey)++decryptionShareStatement :: SubGroup q => PublicKey q -> BS.ByteString+decryptionShareStatement pubKey =+	"decrypt|"<>bytesNat pubKey<>"|"++-- ** Type 'DecryptionFactor'+type DecryptionFactor = G++-- ** Type 'ErrorDecryptionShare'+data ErrorDecryptionShare+ =   ErrorDecryptionShare_Invalid+     -- ^ The number of 'DecryptionFactor's or+     -- the number of 'Proof's is not the same+     -- or not the expected number.+ |   ErrorDecryptionShare_Wrong+     -- ^ The 'Proof' of a 'DecryptionFactor' is wrong.+ deriving (Eq,Show,Generic,NFData)++-- BELENIOS: check_factor+-- | @('verifyDecryptionShare' encByQuestByBallot pubKey decShare)@+-- checks that 'decShare'+-- (supposedly submitted by a trustee whose public key is 'pubKey')+-- is valid with respect to the encrypted tally 'encByQuestByBallot'.+verifyDecryptionShare ::+ Monad m => SubGroup q =>+ [[Encryption q]] ->+ PublicKey q -> DecryptionShare q -> ExceptT ErrorDecryptionShare m ()+verifyDecryptionShare encByQuestByBallot pubKey DecryptionShare{..} =+	let zkp = decryptionShareStatement pubKey in+	isoZipWith3M_ (throwE ErrorDecryptionShare_Invalid)+	 (isoZipWith3M_ (throwE ErrorDecryptionShare_Invalid) $+	 \Encryption{..} decFactor proof ->+		unless (proof_challenge proof == hash zkp+		 [ commit proof groupGen pubKey+		 , commit proof encryption_nonce decFactor+		 ]) $+			throwE ErrorDecryptionShare_Wrong)+	 encByQuestByBallot+	 decryptionShare_factors+	 decryptionShare_proofs++-- * Type 'Tally'+data Tally q = Tally+ { tally_numBallots :: Natural+ , tally_encByQuestByBallot :: [[Encryption q]]+   -- ^ 'Encryption' by 'Question' by 'Ballot'.+ , tally_decShareByTrustee :: [DecryptionShare q]+   -- ^ 'DecryptionShare' by trustee.+ , tally_countByQuestByBallot :: [[Natural]]+ } deriving (Eq,Show,Generic,NFData)++type DecryptionShareCombinator q =+	[DecryptionShare q] -> Except ErrorDecryptionShare [[DecryptionFactor q]]++-- BELENIOS: compute_result+proveTally ::+ Monad m => SubGroup q =>+ [[Encryption q]] -> [DecryptionShare q] ->+ DecryptionShareCombinator q ->+ Except ErrorDecryptionShare (Tally q)+proveTally tally_encByQuestByBallot tally_decShareByTrustee decShareCombinator = do+	decFactorByQuestByBallot <- decShareCombinator tally_decShareByTrustee+	dec <- isoZipWithM err+	 (\encByQuest decFactorByQuest ->+		maybe err return $+			isoZipWith (\Encryption{..} decFactor -> encryption_vault / decFactor)+			 encByQuest+			 decFactorByQuest+	 )+	 tally_encByQuestByBallot+	 decFactorByQuestByBallot+	let tally_numBallots = fromIntegral $ List.length tally_encByQuestByBallot+	let logMap = Map.fromDistinctAscList $ List.zip groupGenPowers [0..tally_numBallots]+	let log x = maybe err return $ Map.lookup x logMap+	tally_countByQuestByBallot <- (log `mapM`)`mapM`dec+	return Tally{..}+	where err = throwE ErrorDecryptionShare_Invalid++verifyTally ::+ Monad m => SubGroup q =>+ DecryptionShareCombinator q -> Tally q ->+ Except ErrorDecryptionShare ()+verifyTally decShareCombinator Tally{..} = do+	decFactorByQuestByBallot <- decShareCombinator tally_decShareByTrustee+	isoZipWith3M_ (throwE ErrorDecryptionShare_Invalid)+	 (isoZipWith3M_ (throwE ErrorDecryptionShare_Invalid)+		 (\Encryption{..} decFactor count -> do+			let dec = encryption_vault / decFactor+			unless (dec == groupGen ^ fromNatural count) $+				throwE ErrorDecryptionShare_Wrong+		 )+	 )+	 tally_encByQuestByBallot+	 decFactorByQuestByBallot+	 tally_countByQuestByBallot

@@ -0,0 +1,5 @@+module Voting.Protocol.Trustees+ ( module Voting.Protocol.Trustees.All+ ) where++import Voting.Protocol.Trustees.All

@@ -0,0 +1,92 @@+{-# LANGUAGE OverloadedStrings #-}+module Voting.Protocol.Trustees.All where++import Control.Monad (Monad(..), foldM, unless)+import Control.Monad.Trans.Except (ExceptT(..), throwE)+import Data.Eq (Eq(..))+import Data.Function (($))+import Data.Maybe (maybe)+import Data.Semigroup (Semigroup(..))+import Text.Show (Show(..))+import qualified Control.Monad.Trans.State.Strict as S+import qualified Data.ByteString as BS+import qualified Data.List as List++import Voting.Protocol.Utils+import Voting.Protocol.Arithmetic+import Voting.Protocol.Credential+import Voting.Protocol.Election++-- * Type 'TrusteePublicKey'+data TrusteePublicKey q = TrusteePublicKey+ { trustee_PublicKey      :: PublicKey q+ , trustee_SecretKeyProof :: Proof q+ } deriving (Eq,Show)++randomSecretKey :: Monad m => RandomGen r => SubGroup q => S.StateT r m (SecretKey q)+randomSecretKey = random++-- ** Type 'ErrorTrusteePublicKey'+data ErrorTrusteePublicKey+ =   ErrorTrusteePublicKey_Wrong+     -- ^ The 'trustee_SecretKeyProof' is wrong.+ deriving (Eq,Show)++-- BELENIOS: MakeSimple.prove+-- | @('proveTrusteePublicKey' trustSecKey)@+-- returns the 'PublicKey' associated to 'trustSecKey'+-- and a 'Proof' of its knowledge.+proveTrusteePublicKey ::+ Monad m => RandomGen r => SubGroup q =>+ SecretKey q -> S.StateT r m (TrusteePublicKey q)+proveTrusteePublicKey trustSecKey = do+	let trustee_PublicKey = publicKey trustSecKey+	trustee_SecretKeyProof <-+		prove trustSecKey [groupGen] $+			hash (trusteePublicKeyStatement trustee_PublicKey)+	return TrusteePublicKey{..}++-- BELENIOS: MakeSimple.check+-- | @('verifyTrusteePublicKey' trustPubKey)@+-- returns 'True' iif. the given 'trustee_SecretKeyProof'+-- does prove that the 'SecretKey' associated with+-- the given 'trustee_PublicKey' is known by the trustee.+verifyTrusteePublicKey ::+ Monad m => SubGroup q =>+ TrusteePublicKey q ->+ ExceptT ErrorTrusteePublicKey m ()+verifyTrusteePublicKey TrusteePublicKey{..} =+	unless ((proof_challenge trustee_SecretKeyProof ==) $+	hash+	 (trusteePublicKeyStatement trustee_PublicKey)+	 [commit trustee_SecretKeyProof groupGen trustee_PublicKey]) $+		throwE ErrorTrusteePublicKey_Wrong++-- ** Hashing+trusteePublicKeyStatement :: PublicKey q -> BS.ByteString+trusteePublicKeyStatement trustPubKey = "pok|"<>bytesNat trustPubKey<>"|"++-- BELENIOS: MakeSimple.combine+electionPublicKey :: SubGroup q => [TrusteePublicKey q] -> PublicKey q+electionPublicKey = List.foldr (\TrusteePublicKey{..} -> (trustee_PublicKey *)) one++-- BELENIOS: combine_factors+-- | @('combineDecryptionShares' checker pubKeyByTrustee decShareByTrustee)@+-- returns the 'DecryptionFactor's by voter by question+combineDecryptionShares ::+ SubGroup q =>+ [[Encryption q]] ->+ [PublicKey q] -> DecryptionShareCombinator q+combineDecryptionShares encByQuestByBallot pubKeyByTrustee decShareByTrustee = do+	isoZipWithM_ (throwE ErrorDecryptionShare_Invalid)+	 (verifyDecryptionShare encByQuestByBallot)+	 pubKeyByTrustee+	 decShareByTrustee+	(d0,ds) <- maybe err return $ List.uncons decShareByTrustee+	foldM+	 (\decFactorByQuestByBallot DecryptionShare{..} ->+		isoZipWithM err+		 (\acc df -> maybe err return $ isoZipWith (*) acc df)+		 decFactorByQuestByBallot decryptionShare_factors)+	 (decryptionShare_factors d0) ds+	where err = throwE ErrorDecryptionShare_Invalid

@@ -0,0 +1,63 @@+module Voting.Protocol.Utils where++import Control.Applicative (Applicative(..))+import Data.Bool+import Data.Eq (Eq(..))+import Data.Foldable (sequenceA_)+import Data.Function (($))+import Data.Functor ((<$))+import Data.Maybe (Maybe(..), maybe)+import Data.Traversable (Traversable(..))+import qualified Data.List as List++-- | NOTE: check the lengths before applying @f@.+isoZipWith :: (a->b->c) -> [a]->[b]->Maybe [c]+isoZipWith f as bs+ | List.length as /= List.length bs = Nothing+ | otherwise = Just (List.zipWith f as bs)++-- | NOTE: check the lengths before applying @f@.+isoZipWith3 :: (a->b->c->d) -> [a]->[b]->[c]->Maybe [d]+isoZipWith3 f as bs cs+ | al /= List.length bs = Nothing+ | al /= List.length cs = Nothing+ | otherwise = Just (List.zipWith3 f as bs cs)+ where al = List.length as++isoZipWithM ::+ Applicative m =>+ m () ->+ (a -> b -> m c) ->+ [a] -> [b] -> m [c]+isoZipWithM err f as bs =+	maybe ([] <$ err) sequenceA $+		isoZipWith f as bs++isoZipWithM_ ::+ Applicative m =>+ m () ->+ (a -> b -> m c) ->+ [a] -> [b] -> m ()+isoZipWithM_ err f as bs =+	maybe err sequenceA_ $+		isoZipWith f as bs++isoZipWith3M ::+ Applicative m =>+ m () ->+ (a -> b -> c -> m d) ->+ [a] -> [b] -> [c] -> m [d]+isoZipWith3M err f as bs cs =+	maybe ([] <$ err) sequenceA $+		isoZipWith3 f as bs cs++isoZipWith3M_ ::+ Applicative m =>+ m () ->+ (a -> b -> c -> m d) ->+ [a] -> [b] -> [c] ->+ m ()+isoZipWith3M_ err f as bs cs =+	maybe err sequenceA_ $+		isoZipWith3 f as bs cs+

@@ -1,13 +0,0 @@-module HUnit where-import Test.Tasty-import qualified HUnit.Arithmetic-import qualified HUnit.Credential-import qualified HUnit.Election--hunits :: TestTree-hunits =-	testGroup "HUnit"-	 [ HUnit.Arithmetic.hunit-	 , HUnit.Credential.hunit-	 , HUnit.Election.hunit-	 ]

@@ -1,40 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE OverloadedStrings #-}-module HUnit.Arithmetic where--import Protocol.Arithmetic-import HUnit.Utils--hunit :: TestTree-hunit = testGroup "Arithmetic"- [ testGroup "inv"-	 [ testGroup "WeakParams"-		 [ testCase "groupGen" $-			inv (groupGen @WeakParams) @?=-				groupGen ^ E (groupOrder @WeakParams + neg one)-		 ]-	 , testGroup "BeleniosParams"-		 [ testCase "groupGen" $-			inv (groupGen @BeleniosParams) @?=-				groupGen ^ E (groupOrder @BeleniosParams + neg one)-		 ]-	 ]- , testGroup "hash"-	 [ testGroup "WeakParams"-		 [ testCase "[groupGen]" $-			hash "start" [groupGen @WeakParams] @?=-				fromNatural 100-		 , testCase "[groupGen, groupGen]" $-			hash "start" [groupGen @WeakParams, groupGen] @?=-				fromNatural 16-		 ]-	 , testGroup "BeleniosParams"-		 [ testCase "[groupGen]" $-			hash "start" [groupGen @BeleniosParams] @?=-				fromNatural 1832875488615060263192702367259-		 , testCase "[groupGen, groupGen]" $-			hash "start" [groupGen @BeleniosParams, groupGen] @?=-				fromNatural 2495277906542783643199702546512-		 ]-	 ]- ]

@@ -1,53 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE OverloadedStrings #-}-module HUnit.Credential where--import Control.Applicative (Applicative(..))-import qualified Control.Monad.Trans.State.Strict as S-import qualified System.Random as Random--import Protocol.Arithmetic-import Protocol.Credential-import HUnit.Utils--hunit :: TestTree-hunit = testGroup "Credential"- [ testGroup "randomCredential"-	 [ testCase "0" $-		S.evalState randomCredential (Random.mkStdGen 0) @?=-			Credential "xLcs7ev6Jy6FHHE"-	 ]- , testGroup "randomUUID"-	 [ testCase "0" $-		S.evalState randomUUID (Random.mkStdGen 0) @?=-			UUID "xLcs7ev6Jy6FHH"-	 ]- , testGroup "readCredential" $-		let (==>) inp exp =-			testCase (show inp) $ readCredential inp @?= exp in-	 [ "" ==> Left CredentialError_Length-	 , "xLcs7ev6Jy6FH_E"  ==> Left (CredentialError_BadChar '_')-	 , "xLcs7ev6Jy6FHIE"  ==> Left (CredentialError_BadChar 'I')-	 , "xLcs7ev6Jy6FH0E"  ==> Left (CredentialError_BadChar '0')-	 , "xLcs7ev6Jy6FHOE"  ==> Left (CredentialError_BadChar 'O')-	 , "xLcs7ev6Jy6FHlE"  ==> Left (CredentialError_BadChar 'l')-	 , "xLcs7ev6Jy6FH6"   ==> Left CredentialError_Length-	 , "xLcs7ev6Jy6FHHy1" ==> Left CredentialError_Length-	 , "xLcs7ev6Jy6FHHF"  ==> Left CredentialError_Checksum-	 , "xLcs7ev6Jy6FHHE"  ==> Right (Credential "xLcs7ev6Jy6FHHE")-	 ]- , testGroup "secretKey" $-	 [ testSecretKey @WeakParams 0 $ E (F 122)-	 , testSecretKey @WeakParams 1 $ E (F 35)-	 , testSecretKey @BeleniosParams 0 $ E (F 2317630607062989137269685509390)-	 , testSecretKey @BeleniosParams 1 $ E (F 1968146140481358915910346867611)-	 ]- ]--testSecretKey :: forall q. SubGroup q => Int -> E q -> TestTree-testSecretKey seed exp =-	let (uuid@(UUID u), cred@(Credential c)) =-		(`S.evalState` Random.mkStdGen seed) $-			(,) <$> randomUUID <*> randomCredential in-	testCase (show (u,c)) $-		secretKey @q uuid cred @?= exp

@@ -1,111 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PatternSynonyms #-}-module HUnit.Election where---- import Control.Applicative (Applicative(..))-import qualified Control.Monad.Trans.Except as Exn-import qualified Control.Monad.Trans.State.Strict as S-import qualified Data.List as List-import qualified System.Random as Random--import Protocol.Arithmetic-import Protocol.Credential-import Protocol.Election-import HUnit.Utils---- * Type 'Params'-class SubGroup q => Params q where-	paramsName :: String-instance Params WeakParams where-	paramsName = "WeakParams"-instance Params BeleniosParams where-	paramsName = "BeleniosParams"--hunit :: TestTree-hunit = testGroup "Election"- [ testGroup "groupGenInverses"-	 [ testCase "WeakParams" $-		List.take 10 (groupGenInverses @WeakParams) @?=-			[groupGen^neg (fromNatural n) | n <- [0..9]]-	 , testCase "BeleniosParams" $-		List.take 10 (groupGenInverses @BeleniosParams) @?=-			[groupGen^neg (fromNatural n) | n <- [0..9]]-	 ]- , testGroup "encryptBallot" $-	 [ testsEncryptBallot @WeakParams-	 , testsEncryptBallot @BeleniosParams-	 ]- ]--testsEncryptBallot :: forall q. Params q => TestTree-testsEncryptBallot =-	testGroup (paramsName @q)-	 [ testEncryptBallot @q 0-		 [Question "q1" ["a1","a2","a3"] zero one]-		 [[True, False, False]]-		 (Right True)-	 , testEncryptBallot @q 0-		 [Question "q1" ["a1","a2","a3"] zero one]-		 [[False, False, False]]-		 (Right True)-	 , testEncryptBallot @q 0-		 [Question "q1" ["a1","a2","a3"] zero one]-		 [[False, False, False]]-		 (Right True)-	 , testEncryptBallot @q 0-		 [Question "q1" [] zero one]-		 []-		 (Left (ErrorBallot_WrongNumberOfAnswers 0 1))-	 , testEncryptBallot @q 0-		 [Question "q1" ["a1","a2"] one one]-		 [[True]]-		 (Left (ErrorBallot_Answer (ErrorAnswer_WrongNumberOfOpinions 1 2)))-	 , testEncryptBallot @q 0-		 [Question "q1" ["a1","a2","a3"] zero one]-		 [[True, True, False]]-		 (Left (ErrorBallot_Answer (ErrorAnswer_WrongSumOfOpinions 2 0 1)))-	 , testEncryptBallot @q 0-		 [Question "q1" ["a1","a2","a3"] one one]-		 [[False, False, False]]-		 (Left (ErrorBallot_Answer (ErrorAnswer_WrongSumOfOpinions 0 1 1)))-	 , testEncryptBallot @q 0-		 [Question "q1" ["a1","a2"] one one]-		 [[False, False, True]]-		 (Left (ErrorBallot_Answer (ErrorAnswer_WrongNumberOfOpinions 3 2)))-	 , testEncryptBallot @q 0-		 [ Question "q1" ["a11","a12","a13"] zero (one+one)-		 , Question "q2" ["a21","a22","a23"] one one-		 ]-		 [ [True, False, True]-		 , [False, True, False] ]-		 (Right True)-	 ]--testEncryptBallot ::- forall q. SubGroup q =>- Int -> [Question q] -> [[Bool]] ->- Either ErrorBallot Bool ->- TestTree-testEncryptBallot seed quests opins exp =-	let verify =-		Exn.runExcept $-		(`S.evalStateT` Random.mkStdGen seed) $ do-			uuid <- randomUUID-			cred <- randomCredential-			let secKey = secretKey @q uuid cred-			let pubKey = publicKey secKey-			let elec = Election-				 { election_name        = "election"-				 , election_description = "description"-				 , election_publicKey   = pubKey-				 , election_questions   = quests-				 , election_uuid        = uuid-				 , election_hash        = Hash ""-				 }-			verifyBallot elec-			 <$> encryptBallot elec (Just secKey) opins-	in-	testCase (show opins) $-		verify @?= exp

@@ -1,37 +0,0 @@-module HUnit.Utils- ( module Test.Tasty- , module Test.Tasty.HUnit- , Monad(..), replicateM, when- , module Data.Bool- , Eq(..)- , Either(..)- , ($), (.)- , (<$>)- , Int- , Maybe(..)- , Monoid(..)- , Ord(..)- , String- , Text- , Word8- , Num, Fractional(..), Integral(..), Integer, undefined, fromIntegral- , Show(..)- ) where--import Control.Monad (Monad(..), replicateM, when)-import Data.Bool-import Data.Either (Either(..))-import Data.Eq (Eq(..))-import Data.Function (($), (.))-import Data.Functor ((<$>))-import Data.Int (Int)-import Data.Maybe (Maybe(..))-import Data.Monoid (Monoid(..))-import Data.Ord (Ord(..))-import Data.String (String)-import Data.Text (Text)-import Data.Word (Word8)-import Prelude (Num, Fractional(..), Integral(..), Integer, undefined, fromIntegral)-import Test.Tasty-import Test.Tasty.HUnit-import Text.Show (Show(..))

@@ -1,15 +0,0 @@-module Main where--import System.IO (IO)-import Data.Function (($))-import Test.Tasty--- import QuickCheck-import HUnit--main :: IO ()-main =-	defaultMain $-	testGroup "Protocol"-	 [ hunits-	 -- , quickchecks-	 ]

@@ -0,0 +1,13 @@+module HUnit where+import Test.Tasty+import qualified HUnit.Arithmetic+import qualified HUnit.Credential+import qualified HUnit.Election++hunits :: TestTree+hunits =+	testGroup "HUnit"+	 [ HUnit.Arithmetic.hunit+	 , HUnit.Credential.hunit+	 , HUnit.Election.hunit+	 ]

@@ -0,0 +1,41 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE OverloadedStrings #-}+module HUnit.Arithmetic where++import Test.Tasty.HUnit+import Protocol.Arithmetic+import Utils++hunit :: TestTree+hunit = testGroup "Arithmetic"+ [ testGroup "inv"+	 [ testGroup "WeakParams"+		 [ testCase "groupGen" $+			inv (groupGen @WeakParams) @?=+				groupGen ^ E (groupOrder @WeakParams + neg one)+		 ]+	 , testGroup "BeleniosParams"+		 [ testCase "groupGen" $+			inv (groupGen @BeleniosParams) @?=+				groupGen ^ E (groupOrder @BeleniosParams + neg one)+		 ]+	 ]+ , testGroup "hash"+	 [ testGroup "WeakParams"+		 [ testCase "[groupGen]" $+			hash "start" [groupGen @WeakParams] @?=+				fromNatural 100+		 , testCase "[groupGen, groupGen]" $+			hash "start" [groupGen @WeakParams, groupGen] @?=+				fromNatural 16+		 ]+	 , testGroup "BeleniosParams"+		 [ testCase "[groupGen]" $+			hash "start" [groupGen @BeleniosParams] @?=+				fromNatural 1832875488615060263192702367259+		 , testCase "[groupGen, groupGen]" $+			hash "start" [groupGen @BeleniosParams, groupGen] @?=+				fromNatural 2495277906542783643199702546512+		 ]+	 ]+ ]

@@ -0,0 +1,54 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE OverloadedStrings #-}+module HUnit.Credential where++import Control.Applicative (Applicative(..))+import Test.Tasty.HUnit+import qualified Control.Monad.Trans.State.Strict as S+import qualified System.Random as Random++import Protocol.Arithmetic+import Protocol.Credential+import Utils++hunit :: TestTree+hunit = testGroup "Credential"+ [ testGroup "randomCredential"+	 [ testCase "0" $+		S.evalState randomCredential (Random.mkStdGen 0) @?=+			Credential "xLcs7ev6Jy6FHHE"+	 ]+ , testGroup "randomUUID"+	 [ testCase "0" $+		S.evalState randomUUID (Random.mkStdGen 0) @?=+			UUID "xLcs7ev6Jy6FHH"+	 ]+ , testGroup "readCredential" $+		let (==>) inp exp =+			testCase (show inp) $ readCredential inp @?= exp in+	 [ "" ==> Left CredentialError_Length+	 , "xLcs7ev6Jy6FH_E"  ==> Left (CredentialError_BadChar '_')+	 , "xLcs7ev6Jy6FHIE"  ==> Left (CredentialError_BadChar 'I')+	 , "xLcs7ev6Jy6FH0E"  ==> Left (CredentialError_BadChar '0')+	 , "xLcs7ev6Jy6FHOE"  ==> Left (CredentialError_BadChar 'O')+	 , "xLcs7ev6Jy6FHlE"  ==> Left (CredentialError_BadChar 'l')+	 , "xLcs7ev6Jy6FH6"   ==> Left CredentialError_Length+	 , "xLcs7ev6Jy6FHHy1" ==> Left CredentialError_Length+	 , "xLcs7ev6Jy6FHHF"  ==> Left CredentialError_Checksum+	 , "xLcs7ev6Jy6FHHE"  ==> Right (Credential "xLcs7ev6Jy6FHHE")+	 ]+ , testGroup "credentialSecretKey" $+	 [ testSecretKey @WeakParams 0 $ E (F 122)+	 , testSecretKey @WeakParams 1 $ E (F 35)+	 , testSecretKey @BeleniosParams 0 $ E (F 2317630607062989137269685509390)+	 , testSecretKey @BeleniosParams 1 $ E (F 1968146140481358915910346867611)+	 ]+ ]++testSecretKey :: forall q. SubGroup q => Int -> E q -> TestTree+testSecretKey seed exp =+	let (uuid@(UUID u), cred@(Credential c)) =+		(`S.evalState` Random.mkStdGen seed) $+			(,) <$> randomUUID <*> randomCredential in+	testCase (show (u,c)) $+		credentialSecretKey @q uuid cred @?= exp

@@ -0,0 +1,126 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+module HUnit.Election where++import Test.Tasty.HUnit+import qualified Data.List as List+import qualified System.Random as Random++import Protocol.Arithmetic+import Protocol.Credential+import Protocol.Election+import Protocol.Trustees.Simple++import Utils++hunit :: TestTree+hunit = testGroup "Election"+ [ testGroup "groupGenInverses"+	 [ testCase "WeakParams" $+		List.take 10 (groupGenInverses @WeakParams) @?=+			[groupGen^neg (fromNatural n) | n <- [0..9]]+	 , testCase "BeleniosParams" $+		List.take 10 (groupGenInverses @BeleniosParams) @?=+			[groupGen^neg (fromNatural n) | n <- [0..9]]+	 ]+ , testGroup "encryptBallot" $+	 [ testsEncryptBallot @WeakParams+	 , testsEncryptBallot @BeleniosParams+	 ]+ , testGroup "trustee" $+	 [ testsTrustee @WeakParams+	 ]+ ]++testsEncryptBallot :: forall q. Params q => TestTree+testsEncryptBallot =+	testGroup (paramsName @q)+	 [ testEncryptBallot @q 0+		 [Question "q1" ["a1","a2","a3"] zero one]+		 [[True, False, False]]+		 (Right True)+	 , testEncryptBallot @q 0+		 [Question "q1" ["a1","a2","a3"] zero one]+		 [[False, False, False]]+		 (Right True)+	 , testEncryptBallot @q 0+		 [Question "q1" ["a1","a2","a3"] zero one]+		 [[False, False, False]]+		 (Right True)+	 , testEncryptBallot @q 0+		 [Question "q1" [] zero one]+		 []+		 (Left (ErrorBallot_WrongNumberOfAnswers 0 1))+	 , testEncryptBallot @q 0+		 [Question "q1" ["a1","a2"] one one]+		 [[True]]+		 (Left (ErrorBallot_Answer (ErrorAnswer_WrongNumberOfOpinions 1 2)))+	 , testEncryptBallot @q 0+		 [Question "q1" ["a1","a2","a3"] zero one]+		 [[True, True, False]]+		 (Left (ErrorBallot_Answer (ErrorAnswer_WrongSumOfOpinions 2 0 1)))+	 , testEncryptBallot @q 0+		 [Question "q1" ["a1","a2","a3"] one one]+		 [[False, False, False]]+		 (Left (ErrorBallot_Answer (ErrorAnswer_WrongSumOfOpinions 0 1 1)))+	 , testEncryptBallot @q 0+		 [Question "q1" ["a1","a2"] one one]+		 [[False, False, True]]+		 (Left (ErrorBallot_Answer (ErrorAnswer_WrongNumberOfOpinions 3 2)))+	 , testEncryptBallot @q 0+		 [ Question "q1" ["a11","a12","a13"] zero (one+one)+		 , Question "q2" ["a21","a22","a23"] one one+		 ]+		 [ [True, False, True]+		 , [False, True, False] ]+		 (Right True)+	 ]++testEncryptBallot ::+ forall q. SubGroup q =>+ Int -> [Question q] -> [[Bool]] ->+ Either ErrorBallot Bool ->+ TestTree+testEncryptBallot seed quests opins exp =+	let verify =+		runExcept $+		(`evalStateT` Random.mkStdGen seed) $ do+			uuid <- randomUUID+			cred <- randomCredential+			let ballotSecKey = credentialSecretKey @q uuid cred+			let elecPubKey = publicKey ballotSecKey -- FIXME: wrong key+			let elec = Election+				 { election_name        = "election"+				 , election_description = "description"+				 , election_publicKey   = elecPubKey+				 , election_questions   = quests+				 , election_uuid        = uuid+				 , election_hash        = Hash "" -- FIXME: when implemented+				 }+			verifyBallot elec+			 <$> encryptBallot elec (Just ballotSecKey) opins+	in+	testCase (show opins) $+		verify @?= exp++testsTrustee :: forall q. Params q => TestTree+testsTrustee =+	testGroup (paramsName @q)+	 [ testTrustee @q 0 (Right ())+	 ]++testTrustee ::+ forall q. SubGroup q =>+ Int -> Either ErrorTrusteePublicKey () -> TestTree+testTrustee seed exp =+	let verify =+		runExcept $+		(`evalStateT` Random.mkStdGen seed) $ do+			trustSecKey <- randomSecretKey @_ @_ @q+			trustPubKey <- proveTrusteePublicKey trustSecKey+			lift $ verifyTrusteePublicKey trustPubKey+	in+	testCase (show seed) $+		verify @?= exp

@@ -0,0 +1,15 @@+module Main where++import System.IO (IO)+import Data.Function (($))+import Test.Tasty+import QuickCheck+import HUnit++main :: IO ()+main =+	defaultMain $+	testGroup "Protocol"+	 [ hunits+	 , quickchecks+	 ]

@@ -0,0 +1,11 @@+module QuickCheck where+import Test.Tasty+import qualified QuickCheck.Election+import qualified QuickCheck.Trustee++quickchecks :: TestTree+quickchecks =+	testGroup "QuickCheck"+	 [ QuickCheck.Election.quickcheck+	 , QuickCheck.Trustee.quickcheck+	 ]

@@ -0,0 +1,151 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS -fno-warn-orphans #-}+module QuickCheck.Election where++import Test.Tasty.QuickCheck+import qualified Data.List as List+import qualified Data.Text as Text+import Data.Eq (Eq(..))+import Data.Int (Int)+import Data.Ord (Ord(..))+import Prelude (undefined)++import Protocol.Arithmetic+import Protocol.Credential+import Protocol.Election++import Utils++-- Hardcoded limits to avoid keep a reasonable testing time.+maxArbitraryChoices :: Natural+maxArbitraryChoices = 5+maxArbitraryQuestions :: Natural+maxArbitraryQuestions = 5++quickcheck :: TestTree+quickcheck =+	testGroup "Election"+	 [ testGroup "verifyBallot" $+		 [ testElection @WeakParams+		 , testElection @BeleniosParams+		 ]+	 ]++testElection :: forall q. Params q => TestTree+testElection  =+	testGroup (paramsName @q)+	 [ testProperty "Right" $ \(seed, (elec::Election q) :> votes) ->+		isRight $ runExcept $+			(`evalStateT` mkStdGen seed) $ do+				-- ballotSecKey :: SecretKey q <- randomSecretKey+				ballot <- encryptBallot elec Nothing votes+				unless (verifyBallot elec ballot) $+					lift $ throwE $ ErrorBallot_WrongNumberOfAnswers 0 0+	 ]++instance PrimeField p => Arbitrary (F p) where+	arbitrary = choose (zero, F (fieldCharac @p) - one)+instance SubGroup q => Arbitrary (G q) where+	arbitrary = do+		m <- arbitrary+		return (groupGen ^ m)+instance SubGroup q => Arbitrary (E q) where+	arbitrary = E <$> choose (zero, groupOrder @q - one)+instance Arbitrary UUID where+	arbitrary = do+		seed <- arbitrary+		(`evalStateT` mkStdGen seed) $ do+			randomUUID+instance SubGroup q => Arbitrary (Proof q) where+	arbitrary = do+		proof_challenge <- arbitrary+		proof_response  <- arbitrary+		return Proof{..}+instance SubGroup q => Arbitrary (Question q) where+	arbitrary = do+		let question_text = "question"+		choices :: Natural <- choose (1, maxArbitraryChoices)+		let question_choices = [Text.pack ("c"<>show c) | c <- [1..choices]]+		question_mini <- fromNatural <$> choose (0, choices)+		question_maxi <- fromNatural <$> choose (nat question_mini, choices)+		return Question{..}+	shrink quest =+		[ quest{question_choices, question_mini, question_maxi}+		| question_choices <- shrinkList pure $ question_choices quest+		, let nChoices = fromNatural $ fromIntegral $ List.length question_choices+		, question_mini <- shrink $ min nChoices $ max zero $ question_mini quest+		, question_maxi <- shrink $ min nChoices $ max question_mini $ question_maxi quest+		]+instance SubGroup q => Arbitrary (Election q) where+	arbitrary = do+		let election_name = "election"+		let election_description = "description"+		election_publicKey <- arbitrary+		election_questions <- resize (fromIntegral maxArbitraryQuestions) $ listOf1 arbitrary+		election_uuid <- arbitrary+		let election_hash = Hash ""+		return Election{..}+	shrink elec =+		[ elec{election_questions}+		| election_questions <- shrink $ election_questions elec+		]++-- | A type to declare an 'Arbitrary' instance where @b@ depends on @a@.+data (:>) a b = a :> b+ deriving (Eq,Show)+instance SubGroup q => Arbitrary (Question q :> [Bool]) where+	arbitrary = do+		quest@Question{..} <- arbitrary+		votes <- do+			let numChoices = List.length question_choices+			numTrue <- fromIntegral <$> choose (nat question_mini, nat question_maxi)+			rank <- choose (0, nCk numChoices numTrue - 1)+			return $ boolsOfCombin numChoices numTrue rank+		return (quest :> votes)+	shrink (quest :> votes) =+		[ q :> shrinkVotes q votes+		| q <- shrink quest+		]+instance SubGroup q => Arbitrary (Election q :> [[Bool]]) where+	arbitrary = do+		elec@Election{..} <- arbitrary+		votes <- forM election_questions $ \Question{..} -> do+			let numChoices = List.length question_choices+			numTrue <- fromIntegral <$> choose (nat question_mini, nat question_maxi)+			rank <- choose (0, nCk numChoices numTrue - 1)+			return $ boolsOfCombin numChoices numTrue rank+		return (elec :> votes)+	shrink (elec :> votes) =+		[ e :> List.zipWith shrinkVotes (election_questions e) votes+		| e <- shrink elec+		]++-- | @('boolsOfCombin' nBits nTrue rank)@ returns the 'rank'-th sequence of 'nBits'-bits possible+-- with 'nTrue' bits set at 'True' and @(nBits-nTrue)@ set at 'False'.+-- @rank@ has to be in @[0 .. 'nCk' nBits nTrue '-' 1]@+boolsOfCombin :: Int -> Int -> Int -> [Bool]+boolsOfCombin nBits nTrue rank+ | rank < 0 = undefined+ | nTrue == 0 = List.replicate nBits False+ | otherwise = go 0 cs <> List.replicate (nBits-List.last cs) False+	where+	cs = combinOfRank nBits nTrue rank+	go _d [] = []+	go curr (next:ns) =+		List.replicate (next-1-curr) False <> [True]+		 <> go next ns++-- | @('shrinkVotes' quest votes)@+-- returns a reduced version of the given @votes@+-- to fit the requirement of the given @quest@.+shrinkVotes :: Question q -> [Bool] -> [Bool]+shrinkVotes Question{..} votes =+	(\(nTrue, b) -> if nTrue <= nat question_maxi then b else False)+	 <$> List.zip (countTrue votes) votes+	where+	countTrue :: [Bool] -> [Natural]+	countTrue = List.foldl' (\ns b -> if b then inc ns else ns) []+		where+		inc [] = [zero]+		inc (n:ns) = (n+one):n:ns+

@@ -0,0 +1,37 @@+{-# OPTIONS -fno-warn-orphans #-}+module QuickCheck.Trustee where++import Test.Tasty.QuickCheck++import Protocol.Arithmetic+import Protocol.Credential+import Protocol.Trustees.Simple++import Utils+import QuickCheck.Election ()++quickcheck :: TestTree+quickcheck =+	testGroup "Trustee"+	 [ testGroup "verifyTrusteePublicKey" $+		 [ testTrusteePublicKey @WeakParams+		 , testTrusteePublicKey @BeleniosParams+		 ]+	 ]++testTrusteePublicKey :: forall q. Params q => TestTree+testTrusteePublicKey  =+	testGroup (paramsName @q)+	 [ testProperty "Right" $ \seed ->+		isRight $ runExcept $+			(`evalStateT` mkStdGen seed) $ do+				trustSecKey :: SecretKey q <- randomSecretKey+				trustPubKey <- proveTrusteePublicKey trustSecKey+				lift $ verifyTrusteePublicKey trustPubKey+	 ]++instance SubGroup q => Arbitrary (TrusteePublicKey q) where+	arbitrary = do+		trustee_PublicKey <- arbitrary+		trustee_SecretKeyProof <- arbitrary+		return TrusteePublicKey{..}

@@ -0,0 +1,83 @@+module Utils+ ( module Test.Tasty+ , module Data.Bool+ , Applicative(..)+ , Monad(..), forM, replicateM, unless, when+ , Eq(..)+ , Either(..), either, isLeft, isRight+ , ($), (.), id, const, flip+ , (<$>)+ , Int+ , Maybe(..)+ , Monoid(..), Semigroup(..)+ , Ord(..)+ , String+ , Text+ , Word8+ , Num, Fractional(..), Integral(..), Integer, fromIntegral+ , Show(..)+ , MonadTrans(..)+ , ExceptT+ , runExcept+ , throwE+ , StateT+ , evalStateT+ , mkStdGen+ , debug+ , nCk+ , combinOfRank+ ) where++import Control.Applicative (Applicative(..))+import Control.Monad+import Control.Monad.Trans.Class+import Control.Monad.Trans.Except+import Control.Monad.Trans.State.Strict+import Data.Bool+import Data.Either (Either(..), either, isLeft, isRight)+import Data.Eq (Eq(..))+import Data.Function+import Data.Functor ((<$>))+import Data.Int (Int)+import Data.Maybe (Maybe(..))+import Data.Monoid (Monoid(..))+import Data.Ord (Ord(..))+import Data.Semigroup (Semigroup(..))+import Data.String (String)+import Data.Text (Text)+import Data.Word (Word8)+import Debug.Trace+import Prelude (Num(..), Fractional(..), Integral(..), Integer, undefined, fromIntegral)+import System.Random (mkStdGen)+import Test.Tasty+import Text.Show (Show(..))++debug msg x = trace (msg<>": "<>show x) x++-- | @'nCk' n k@ returns the number of combinations+-- of size 'k' from a set of size 'n'.+--+-- Computed using the formula:+-- @'nCk' n (k+1) == 'nCk' n (k-1) * (n-k+1) / k@+nCk :: Integral i => i -> i -> i+n`nCk`k | n<0||k<0||n<k = undefined+        | otherwise     = go 1 1+        where+        go i acc = if k' < i then acc else go (i+1) (acc * (n-i+1) `div` i)+        -- Use a symmetry to compute over smaller numbers,+        -- which is more efficient and safer+        k' = if n`div`2 < k then n-k else k++-- | @'combinOfRank' n k r@ returns the @r@-th combination+-- of @k@ elements from a set of @n@ elements.+-- DOC: <http://www.site.uottawa.ca/~lucia/courses/5165-09/GenCombObj.pdf>, p.26+combinOfRank :: Integral i => i -> i -> i -> [i]+combinOfRank n k rk | rk<0||n`nCk`k<rk = undefined+                    | otherwise = for1K 1 1 rk+	where+	for1K i j r | i <  k    = uptoRank i j r+	            | i == k    = [j+r] -- because when i == k, nbCombs is always 1+	            | otherwise = []+	uptoRank i j r | nbCombs <- (n-j)`nCk`(k-i)+	               , nbCombs <= r = uptoRank i (j+1) (r-nbCombs)+	               | otherwise    = j : for1K (i+1) (j+1) r