hjugement-protocol 0.0.0.20190513 → 0.0.0.20190519

raw patch · 21 files changed

+1004/−767 lines, 21 filesdep +aesondep +base64-bytestringdep +binaryPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: aeson, base64-bytestring, binary, reflection

API changes (from Hackage documentation)

Files

• benchmarks/Election.hs +33/−33
• benchmarks/Utils.hs +1/−3
• hjugement-protocol.cabal +11/−10
• src/Voting/Protocol.hs +2/−2
• src/Voting/Protocol/Arithmetic.hs +0/−335
• src/Voting/Protocol/Credential.hs +50/−19
• src/Voting/Protocol/Election.hs +183/−86
• src/Voting/Protocol/FFC.hs +415/−0
• src/Voting/Protocol/Tally.hs +72/−76
• src/Voting/Protocol/Trustee/Indispensable.hs +47/−31
• src/Voting/Protocol/Utils.hs +14/−17
• stack.yaml +1/−1
• tests/HUnit.hs +2/−2
• tests/HUnit/Arithmetic.hs +0/−41
• tests/HUnit/Credential.hs +17/−17
• tests/HUnit/Election.hs +28/−25
• tests/HUnit/FFC.hs +46/−0
• tests/HUnit/Trustee/Indispensable.hs +32/−32
• tests/QuickCheck/Election.hs +39/−29
• tests/QuickCheck/Trustee.hs +10/−8
• tests/Utils.hs +1/−0

@@ -8,15 +8,15 @@ import Voting.Protocol import Utils -makeElection :: SubGroup q => Int -> Int -> Election q-makeElection nQuests nChoices = Election+makeElection :: forall c. Reifies c FFC => Int -> Int -> Election c+makeElection nQuests nChoices = hashElection $ Election  { election_name = Text.pack $ "elec"<>show nQuests<>show nChoices  , election_description = "benchmarkable election"  , election_uuid- , election_PublicKey =+ , election_crypto = ElectionCrypto_FFC (reflect (Proxy::Proxy c)) $ 	let secKey = credentialSecretKey election_uuid (Credential "xLcs7ev6Jy6FHHE") in 	publicKey secKey- , election_hash = Hash "" -- FIXME: when implemented+ , election_hash = Hash ""  , election_questions = 	(<$> [1..nQuests]) $ \quest -> Question 	 { question_text = Text.pack $ "quest"<>show quest@@ -26,16 +26,16 @@ 	 }  } where election_uuid = UUID "xLcs7ev6Jy6FHH" -makeVotes :: Election q -> [[Bool]]+makeVotes :: Election c -> [[Bool]] makeVotes Election{..} = 	[ True : List.tail [ False | _choice <- question_choices quest ] 	| quest <- election_questions 	] -makeBallot :: forall q. SubGroup q => Election q -> Ballot q+makeBallot :: Reifies c FFC => Election c -> Ballot c makeBallot elec = 	case runExcept $ (`evalStateT` mkStdGen seed) $ do-		ballotSecKey :: SecretKey q <- randomSecretKey+		ballotSecKey <- randomSecretKey 		encryptBallot elec (Just ballotSecKey) $ 			makeVotes elec of 	 Right ballot -> ballot@@ -43,7 +43,7 @@ 	where 	seed = 0 -titleElection :: Election q -> String+titleElection :: Election c -> String titleElection Election{..} = 	Printf.printf "(questions=%i)×(choices=%i)==%i" 	 nQuests nChoices (nQuests * nChoices)@@ -51,26 +51,26 @@ 	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+benchEncryptBallot :: FFC -> Int -> Int -> Benchmark+benchEncryptBallot ffc nQuests nChoices =+	reify ffc $ \(Proxy::Proxy c) ->+		let setupEnv = do+			let elec :: Election c = makeElection nQuests nChoices+			return elec in+		env setupEnv $ \ ~(elec) ->+			bench (titleElection elec) $+				nf makeBallot 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)+benchVerifyBallot :: FFC -> Int -> Int -> Benchmark+benchVerifyBallot ffc nQuests nChoices =+	reify ffc $ \(Proxy::Proxy c) ->+		let setupEnv = do+			let elec :: Election c = makeElection nQuests nChoices+			let ballot = makeBallot elec+			return (elec,ballot) in+		env setupEnv $ \ ~(elec, ballot) ->+			bench (titleElection elec) $+				nf (verifyBallot elec) ballot  benchmarks :: [Benchmark] benchmarks =@@ -79,23 +79,23 @@ 	 | nQ <- [1,5,10,15,20,25] 	 , nC <- [5,7] 	 ] in- [ bgroup "WeakParams"+ [ bgroup "weakFFC" 	 [ bgroup "encryptBallot"-		 [ benchEncryptBallot @WeakParams nQuests nChoices+		 [ benchEncryptBallot weakFFC nQuests nChoices 		 | (nQuests,nChoices) <- inputs 		 ] 	 , bgroup "verifyBallot"-		 [ benchVerifyBallot @WeakParams nQuests nChoices+		 [ benchVerifyBallot weakFFC nQuests nChoices 		 | (nQuests,nChoices) <- inputs 		 ] 	 ]- , bgroup "BeleniosParams"+ , bgroup "beleniosFFC" 	 [ bgroup "encryptBallot"-		 [ benchEncryptBallot @BeleniosParams nQuests nChoices+		 [ benchEncryptBallot beleniosFFC nQuests nChoices 		 | (nQuests,nChoices) <- inputs 		 ] 	 , bgroup "verifyBallot"-		 [ benchVerifyBallot @BeleniosParams nQuests nChoices+		 [ benchVerifyBallot beleniosFFC nQuests nChoices 		 | (nQuests,nChoices) <- inputs 		 ] 	 ]

@@ -16,8 +16,6 @@  , Text  , Word8  , Num, Fractional(..), Integral(..), Integer, fromIntegral- , min- , max  , Show(..)  , MonadTrans(..)  , ExceptT@@ -50,7 +48,7 @@ import Data.Text (Text) import Data.Word (Word8) import Debug.Trace-import Prelude (Num(..), Fractional(..), Integral(..), Integer, undefined, fromIntegral, error)+import Prelude (Num(..), Fractional(..), Integral(..), Integer, fromIntegral, error) import System.IO (IO) import System.Random (mkStdGen) import Text.Show (Show(..))

@@ -2,7 +2,7 @@ -- PVP:  +-+------- breaking API changes --       | | +----- non-breaking API additions --       | | | +--- code changes with no API change-version: 0.0.0.20190513+version: 0.0.0.20190519 category: Politic synopsis: A cryptographic protocol for the Majority Judgment. description:@@ -17,9 +17,6 @@   <http://stephane.glondu.net/ Stéphane Glondu>   and Malika Izabachène.   .-  (TODO) Actually, this protocol is adapted a little bit here to better support-  a better method of voting known as the <http://libgen.io/book/index.php?md5=BF67AA4298C1CE7633187546AA53E01D Majority Judgment>.-  .   * A large-public introduction (in french) to Helios-C is available here:     <https://members.loria.fr/VCortier/files/Papers/Bulletin1024-2016.pdf Bulletin de la société informatique de France – numéro 9, novembre 2016>.   * A more scientific (yet understandable) introduction (in english) to Belenios@@ -64,7 +61,7 @@   hs-source-dirs: src   exposed-modules:     Voting.Protocol-    Voting.Protocol.Arithmetic+    Voting.Protocol.FFC     Voting.Protocol.Credential     Voting.Protocol.Election     Voting.Protocol.Tally@@ -87,11 +84,11 @@     NoMonomorphismRestriction     RecordWildCards     ScopedTypeVariables+    StandaloneDeriving     TupleSections     TypeApplications     TypeFamilies     TypeOperators-    UndecidableInstances   ghc-options:     -Wall     -Wincomplete-uni-patterns@@ -100,6 +97,9 @@     -- -fhide-source-paths   build-depends:       base >= 4.6 && < 5+    , aeson >= 1.3+    , base64-bytestring >= 1.0+    , binary >= 0.8     , bytestring >= 0.10     , containers >= 0.5     , cryptonite >= 0.25@@ -110,7 +110,7 @@     -- , monad-classes >= 0.3     , deepseq >= 1.4     , random >= 1.1-    -- , reflection >= 2.1+    , reflection >= 2.1     , text >= 1.2     , transformers >= 0.5     , unordered-containers >= 0.2.8@@ -121,7 +121,7 @@   main-is: Main.hs   other-modules:     HUnit-    HUnit.Arithmetic+    HUnit.FFC     HUnit.Credential     HUnit.Election     HUnit.Trustee@@ -146,11 +146,11 @@     NoMonomorphismRestriction     RecordWildCards     ScopedTypeVariables+    StandaloneDeriving     TupleSections     TypeApplications     TypeFamilies     TypeOperators-    UndecidableInstances   ghc-options:     -Wall     -Wincomplete-uni-patterns@@ -160,6 +160,7 @@   build-depends:       hjugement-protocol     , base >= 4.6 && < 5+    , aeson >= 1.3     , containers >= 0.5     -- , hashable >= 1.2.6     , QuickCheck >= 2.11@@ -196,11 +197,11 @@     NoMonomorphismRestriction     RecordWildCards     ScopedTypeVariables+    StandaloneDeriving     TupleSections     TypeApplications     TypeFamilies     TypeOperators-    UndecidableInstances   ghc-options:     -Wall     -Wincomplete-uni-patterns

@@ -1,12 +1,12 @@ module Voting.Protocol- ( module Voting.Protocol.Arithmetic+ ( module Voting.Protocol.FFC  , module Voting.Protocol.Credential  , module Voting.Protocol.Election  , module Voting.Protocol.Tally  , module Voting.Protocol.Trustee  ) where -import Voting.Protocol.Arithmetic+import Voting.Protocol.FFC import Voting.Protocol.Credential import Voting.Protocol.Election import Voting.Protocol.Tally

@@ -1,335 +0,0 @@-{-# 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

@@ -1,26 +1,30 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-} module Voting.Protocol.Credential where  import Control.DeepSeq (NFData)-import Control.Monad (Monad(..), replicateM)+import Control.Monad (Monad(..), forM_, replicateM) import Data.Bits import Data.Bool import Data.Char (Char)-import Data.Either (Either(..))+import Data.Either (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.Semigroup (Semigroup(..)) import Data.Text (Text) import GHC.Generics (Generic) import Numeric.Natural (Natural) import Prelude (Integral(..), fromIntegral, div)-import Text.Show (Show)+import Text.Show (Show(..)) import qualified Control.Monad.Trans.State.Strict as S import qualified Crypto.KDF.PBKDF2 as Crypto+import qualified Data.Aeson as JSON+import qualified Data.Aeson.Types as JSON import qualified Data.ByteArray as ByteArray import qualified Data.ByteString as BS import qualified Data.Char as Char@@ -29,7 +33,7 @@ import qualified Data.Text.Encoding as Text import qualified System.Random as Random -import Voting.Protocol.Arithmetic+import Voting.Protocol.FFC  -- * Type 'Credential' -- | A 'Credential' is a word of @('tokenLength'+1 '==' 15)@-characters@@ -39,7 +43,14 @@ -- 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)+ deriving (Eq,Show,Generic)+ deriving newtype NFData+ deriving newtype JSON.ToJSON+instance JSON.FromJSON Credential where+	parseJSON json@(JSON.String s) =+		either (\err -> JSON.typeMismatch ("Credential: "<>show err) json) return $+		readCredential s+	parseJSON json = JSON.typeMismatch "Credential" json  credentialAlphabet :: [Char] -- TODO: make this an array credentialAlphabet = "123456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz"@@ -63,9 +74,9 @@  -- | @'readCredential'@ reads and check the well-formedness of a 'Credential' -- from raw 'Text'.-readCredential :: Text -> Either CredentialError Credential+readCredential :: Text -> Either ErrorToken Credential readCredential s- | Text.length s /= tokenLength + 1 = Left CredentialError_Length+ | Text.length s /= tokenLength + 1 = Left ErrorToken_Length  | otherwise = do 	tot <- Text.foldl' 	 (\acc c -> acc >>= \a -> ((a * tokenBase) +) <$> digitOfChar c)@@ -74,22 +85,29 @@ 	checksum <- digitOfChar (Text.last s) 	if (tot + checksum) `mod` 53 == 0 	then Right (Credential s)-	else Left CredentialError_Checksum+	else Left ErrorToken_Checksum 	where 	digitOfChar c =-		maybe (Left $ CredentialError_BadChar c) Right $+		maybe (Left $ ErrorToken_BadChar c) Right $ 		List.elemIndex c credentialAlphabet --- ** Type 'CredentialError'-data CredentialError- =   CredentialError_BadChar Char.Char- |   CredentialError_Checksum- |   CredentialError_Length+-- ** Type 'ErrorToken'+data ErrorToken+ =   ErrorToken_BadChar Char.Char+ |   ErrorToken_Checksum+ |   ErrorToken_Length  deriving (Eq,Show,Generic,NFData)  -- ** Type 'UUID' newtype UUID = UUID Text- deriving (Eq,Ord,Show,Generic,NFData)+ deriving (Eq,Ord,Show,Generic)+ deriving anyclass (JSON.ToJSON)+ deriving newtype NFData+instance JSON.FromJSON UUID where+	parseJSON json@(JSON.String s) =+		either (\err -> JSON.typeMismatch ("UUID: "<>show err) json) return $+		readUUID s+	parseJSON json = JSON.typeMismatch "UUID" json  -- | @'randomUUID'@ generates a random 'UUID'. randomUUID ::@@ -102,16 +120,29 @@ 	where 	charOfDigit = (credentialAlphabet List.!!) +-- | @'readCredential'@ reads and check the well-formedness of a 'Credential'+-- from raw 'Text'.+readUUID :: Text -> Either ErrorToken UUID+readUUID s+ | Text.length s /= tokenLength = Left ErrorToken_Length+ | otherwise = do+	forM_ (Text.unpack s) digitOfChar+	return (UUID s)+	where+	digitOfChar c =+		maybe (Left $ ErrorToken_BadChar c) Right $+		List.elemIndex c credentialAlphabet+ -- ** Type 'SecretKey' type SecretKey = E -randomSecretKey :: Monad m => RandomGen r => SubGroup q => S.StateT r m (SecretKey q)+randomSecretKey :: Reifies c FFC => Monad m => RandomGen r => S.StateT r m (SecretKey c) randomSecretKey = random  -- | @('credentialSecretKey' uuid cred)@ returns the 'SecretKey' -- derived from given 'uuid' and 'cred' -- using 'Crypto.fastPBKDF2_SHA256'.-credentialSecretKey :: SubGroup q => UUID -> Credential -> SecretKey q+credentialSecretKey :: Reifies c FFC => UUID -> Credential -> (SecretKey c) credentialSecretKey (UUID uuid) (Credential cred) = 	fromNatural $ BS.foldl' 	 (\acc b -> acc`shiftL`3 + fromIntegral b)@@ -132,6 +163,6 @@ type PublicKey = G  -- | @('publicKey' secKey)@ returns the 'PublicKey'--- derived from given 'SecretKey'.-publicKey :: SubGroup q => SecretKey q -> PublicKey q+-- derived from given 'SecretKey' @secKey@.+publicKey :: Reifies c FFC => SecretKey c -> PublicKey c publicKey = (groupGen ^)

@@ -2,36 +2,44 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Rank2Types #-} -- for reifyElection+{-# LANGUAGE UndecidableInstances #-} -- for Reifies instances module Voting.Protocol.Election where +import Control.Applicative (Applicative(..)) import Control.DeepSeq (NFData) import Control.Monad (Monad(..), join, mapM, replicateM, zipWithM) import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.Trans.Except (ExceptT, runExcept, throwE, withExceptT)+import Data.Aeson (ToJSON(..),FromJSON(..),(.:),(.=)) import Data.Bool import Data.Either (either) import Data.Eq (Eq(..)) import Data.Foldable (Foldable, foldMap, and)-import Data.Function (($), id, const)+import Data.Function (($), (.), id, const) import Data.Functor (Functor, (<$>)) import Data.Functor.Identity (Identity(..))-import Data.Maybe (Maybe(..), fromMaybe)+import Data.Maybe (Maybe(..), fromJust) import Data.Ord (Ord(..)) import Data.Semigroup (Semigroup(..)) import Data.Text (Text) import Data.Traversable (Traversable(..)) import Data.Tuple (fst, snd)-import GHC.Natural (minusNaturalMaybe) import GHC.Generics (Generic)+import GHC.Natural (minusNaturalMaybe) import Numeric.Natural (Natural) import Prelude (fromIntegral) import Text.Show (Show(..)) import qualified Control.Monad.Trans.State.Strict as S+import qualified Data.Aeson as JSON import qualified Data.ByteString as BS+import qualified Data.ByteString.Base64.Lazy as BSL64 import qualified Data.List as List+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Encoding as TL  import Voting.Protocol.Utils-import Voting.Protocol.Arithmetic+import Voting.Protocol.FFC import Voting.Protocol.Credential  -- * Type 'Encryption'@@ -46,18 +54,20 @@ -- -- 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+data Encryption c = Encryption+ { encryption_nonce :: !(G c)    -- ^ Public part of the randomness 'encNonce' used to 'encrypt' the 'clear' text,    -- equal to @('groupGen' '^'encNonce)@- , encryption_vault :: G q+ , encryption_vault :: !(G c)    -- ^ Encrypted 'clear' text,    -- equal to @('pubKey' '^'encNone '*' 'groupGen' '^'clear)@  } deriving (Eq,Show,Generic,NFData)+deriving instance Reifies c FFC => ToJSON (Encryption c)+deriving instance Reifies c FFC => FromJSON (Encryption c)  -- | Additive homomorphism. -- Using the fact that: @'groupGen' '^'x '*' 'groupGen' '^'y '==' 'groupGen' '^'(x'+'y)@.-instance SubGroup q => Additive (Encryption q) where+instance Reifies c FFC => Additive (Encryption c) where 	zero = Encryption one one 	x+y = Encryption 	 (encryption_nonce x * encryption_nonce y)@@ -75,9 +85,10 @@ -- 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)+ Reifies c FFC =>+ Monad m => RandomGen r =>+ PublicKey c -> E c ->+ S.StateT r m (EncryptionNonce c, Encryption c) encrypt pubKey clear = do 	encNonce <- random 	-- NOTE: preserve the 'encNonce' for 'prove' in 'proveEncryption'.@@ -91,8 +102,8 @@ -- | Non-Interactive Zero-Knowledge 'Proof' -- of knowledge of a discrete logarithm: -- @(secret == logBase base (base^secret))@.-data Proof q = Proof- { proof_challenge :: Challenge q+data Proof c = Proof+ { proof_challenge :: Challenge c    -- ^ 'Challenge' sent by the verifier to the prover    -- to ensure that the prover really has knowledge    -- of the secret and is not replaying.@@ -100,7 +111,7 @@    -- 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+ , proof_response :: E c    -- ^ A discrete logarithm sent by the prover to the verifier,    -- as a response to 'proof_challenge'.    --@@ -122,6 +133,8 @@    -- to ensure that each 'prove' does not reveal any information    -- about its secret.  } deriving (Eq,Show,Generic,NFData)+deriving instance Reifies c FFC => ToJSON (Proof c)+deriving instance Reifies c FFC => FromJSON (Proof c)  -- ** Type 'ZKP' -- | Zero-knowledge proof.@@ -149,13 +162,13 @@ -- 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+type Oracle list c = list (Commitment c) -> Challenge c --- | @('prove' sec commitBases oracle)@+-- | @('prove' sec commitmentBases 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'+-- The 'Oracle' is given 'Commitment's equal to the 'commitmentBases' -- 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@@ -169,11 +182,12 @@ -- 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+ Reifies c FFC =>+ Monad m => RandomGen r => Functor list =>+ E c -> list (G c) -> Oracle list c -> S.StateT r m (Proof c)+prove sec commitmentBases oracle = do 	nonce <- random-	let commitments = (^ nonce) <$> commitBases+	let commitments = (^ nonce) <$> commitmentBases 	let proof_challenge = oracle commitments 	return Proof 	 { proof_challenge@@ -188,7 +202,10 @@ -- -- 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 ::+ Reifies c FFC =>+ Monad m =>+ RandomGen r => S.StateT r m (Proof c) fakeProof = do 	proof_challenge <- random 	proof_response  <- random@@ -202,7 +219,7 @@  -- | @('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 :: Reifies c FFC => Proof c -> G c -> G c -> Commitment c commit Proof{..} base basePowSec = 	base^proof_response * 	basePowSec^proof_challenge@@ -218,12 +235,12 @@ -- that an 'encryption_vault' contains a given @('groupGen' '^'opinion)@, type Disjunction = G -booleanDisjunctions :: SubGroup q => [Disjunction q]+booleanDisjunctions :: Reifies c FFC => [Disjunction c] booleanDisjunctions = List.take 2 groupGenInverses -intervalDisjunctions :: SubGroup q => Opinion q -> Opinion q -> [Disjunction q]+intervalDisjunctions :: Reifies c FFC => Natural -> Natural -> [Disjunction c] intervalDisjunctions mini maxi =-	List.genericTake (fromMaybe 0 $ (nat maxi + 1)`minusNaturalMaybe`nat mini) $+	List.genericTake (fromJust $ (nat maxi + 1)`minusNaturalMaybe`nat mini) $ 	List.genericDrop (nat mini) $ 	groupGenInverses @@ -236,9 +253,11 @@ -- | 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]+newtype DisjProof c = DisjProof [Proof c]  deriving (Eq,Show,Generic)  deriving newtype NFData+deriving newtype instance Reifies c FFC => ToJSON (DisjProof c)+deriving newtype instance Reifies c FFC => FromJSON (DisjProof c)  -- | @('proveEncryption' elecPubKey voterZKP (prevDisjs,nextDisjs) (encNonce,enc))@ -- returns a 'DisjProof' that 'enc' 'encrypt's@@ -251,11 +270,12 @@ -- -- 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)+ Reifies c FFC =>+ Monad m => RandomGen r =>+ PublicKey c -> ZKP ->+ ([Disjunction c],[Disjunction c]) ->+ (EncryptionNonce c, Encryption c) ->+ S.StateT r m (DisjProof c) proveEncryption elecPubKey voterZKP (prevDisjs,nextDisjs) (encNonce,enc) = do 	-- Fake proofs for all 'Disjunction's except the genuine one. 	prevFakeProofs <- replicateM (List.length prevDisjs) fakeProof@@ -279,9 +299,9 @@ 	return (DisjProof proofs)  verifyEncryption ::- Monad m => SubGroup q =>- PublicKey q -> ZKP ->- [Disjunction q] -> (Encryption q, DisjProof q) ->+ Reifies c FFC => Monad m =>+ PublicKey c -> ZKP ->+ [Disjunction c] -> (Encryption c, DisjProof c) ->  ExceptT ErrorVerifyEncryption m Bool verifyEncryption elecPubKey voterZKP disjs (enc, DisjProof proofs) = 	case isoZipWith (encryptionCommitments elecPubKey enc) disjs proofs of@@ -296,7 +316,7 @@ 	challengeSum = sum (proof_challenge <$> proofs)  -- ** Hashing-encryptionStatement :: SubGroup q => ZKP -> Encryption q -> BS.ByteString+encryptionStatement :: Reifies c FFC => ZKP -> Encryption c -> BS.ByteString encryptionStatement (ZKP voterZKP) Encryption{..} = 	"prove|"<>voterZKP<>"|" 	 <> bytesNat encryption_nonce<>","@@ -308,9 +328,9 @@ -- 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]+ Reifies c FFC =>+ PublicKey c -> Encryption c ->+ Disjunction c -> Proof c -> [G c] encryptionCommitments elecPubKey Encryption{..} disj proof = 	[ commit proof groupGen encryption_nonce 	  -- == groupGen ^ nonce if 'Proof' comes from 'prove'.@@ -330,40 +350,40 @@  deriving (Eq,Show)  -- * Type 'Question'-data Question q = Question- { question_text    :: Text- , question_choices :: [Text]- , question_mini    :: Opinion q- , question_maxi    :: Opinion q+data Question = Question+ { question_text    :: !Text+ , question_choices :: ![Text]+ , question_mini    :: !Natural+ , question_maxi    :: !Natural  -- , question_blank :: Maybe Bool- } deriving (Eq,Show,Generic,NFData)+ } deriving (Eq,Show,Generic,NFData,ToJSON,FromJSON)  -- * Type 'Answer'-data Answer q = Answer- { answer_opinions :: [(Encryption q, DisjProof q)]+data Answer c = Answer+ { answer_opinions :: ![(Encryption c, DisjProof c)]    -- ^ Encrypted 'Opinion' for each 'question_choices'    -- with a 'DisjProof' that they belong to [0,1].- , answer_sumProof :: DisjProof q+ , answer_sumProof :: !(DisjProof c)    -- ^ 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)+deriving instance Reifies c FFC => ToJSON (Answer c)+deriving instance Reifies c FFC => FromJSON (Answer c)  -- | @('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)+ Reifies c FFC =>+ Monad m => RandomGen r =>+ PublicKey c -> ZKP ->+ Question -> [Bool] ->+ S.StateT r (ExceptT ErrorAnswer m) (Answer c) encryptAnswer elecPubKey zkp Question{..} opinionByChoice  | not (question_mini <= opinionsSum && opinionsSum <= question_maxi) = 	lift $ throwE $-		ErrorAnswer_WrongSumOfOpinions-		 (nat opinionsSum)-		 (nat question_mini)-		 (nat question_maxi)+		ErrorAnswer_WrongSumOfOpinions opinionsSum question_mini question_maxi  | List.length opinions /= List.length question_choices = 	lift $ throwE $ 		ErrorAnswer_WrongNumberOfOpinions@@ -374,12 +394,12 @@ 	individualProofs <- zipWithM 	 (\opinion -> proveEncryption elecPubKey zkp $ 		if opinion-		then ([booleanDisjunctions List.!!0],[])-		else ([],[booleanDisjunctions List.!!1]))+		then (List.init booleanDisjunctions,[])+		else ([],List.tail booleanDisjunctions)) 	 opinionByChoice encryptions 	sumProof <- proveEncryption elecPubKey zkp 	 (List.tail <$> List.genericSplitAt-		 (nat (opinionsSum - question_mini))+		 (fromJust $ opinionsSum`minusNaturalMaybe`question_mini) 		 (intervalDisjunctions question_mini question_maxi)) 	 ( sum (fst <$> encryptions) -- NOTE: sum the 'encNonce's 	 , sum (snd <$> encryptions) -- NOTE: sum the 'Encryption's@@ -391,13 +411,13 @@ 	 , answer_sumProof = sumProof 	 }  where-	opinionsSum = sum opinions+	opinionsSum = sum $ nat <$> opinions 	opinions = (\o -> if o then one else zero) <$> opinionByChoice  verifyAnswer ::- SubGroup q =>- PublicKey q -> ZKP ->- Question q -> Answer q -> Bool+ Reifies c FFC =>+ PublicKey c -> ZKP ->+ Question -> Answer c -> Bool verifyAnswer elecPubKey zkp Question{..} Answer{..}  | List.length question_choices /= List.length answer_opinions = False  | otherwise = either (const False) id $ runExcept $ do@@ -422,36 +442,110 @@  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+data Election c = Election+ { election_name        :: !Text+ , election_description :: !Text+ , election_crypto      :: !(ElectionCrypto c)+ , election_questions   :: ![Question]+ , election_uuid        :: !UUID+ , election_hash        :: !Hash  } deriving (Eq,Show,Generic,NFData) +instance ToJSON (Election c) where+	toJSON Election{..} =+		JSON.object+		 [ "name"        .= election_name+		 , "description" .= election_description+		 , "public_key"  .= election_crypto+		 , "questions"   .= election_questions+		 , "uuid"        .= election_uuid+		 ]+	toEncoding Election{..} =+		JSON.pairs+		 (  "name"        .= election_name+		 <> "description" .= election_description+		 <> "public_key"  .= election_crypto+		 <> "questions"   .= election_questions+		 <> "uuid"        .= election_uuid+		 )+instance FromJSON (Election c) where+	parseJSON = JSON.withObject "Election" $ \o -> Election+	 <$> o .: "name"+	 <*> o .: "description"+	 <*> o .: "public_key"+	 <*> o .: "questions"+	 <*> o .: "uuid"+	 <*> pure (hashJSON (JSON.Object o))++-- ** Type 'ElectionCrypto'+data ElectionCrypto c =+ ElectionCrypto_FFC+ { electionCrypto_FFC_params    :: !FFC+ , electionCrypto_FFC_PublicKey :: !(PublicKey c)+ } deriving (Eq,Show,Generic,NFData)++reifyElection :: Election () -> (forall c. Reifies c FFC => Election c -> k) -> k+reifyElection Election{..} k =+	case election_crypto of+	 ElectionCrypto_FFC ffc (G (F pubKey)) ->+		reify ffc $ \(_::Proxy c) -> k @c+		 Election{election_crypto = ElectionCrypto_FFC ffc (G (F pubKey)), ..}+++instance ToJSON (ElectionCrypto c) where+	toJSON (ElectionCrypto_FFC ffc pubKey) =+		JSON.object+		 [ "group" .= ffc+		 , "y"     .= nat pubKey+		 ]+	toEncoding (ElectionCrypto_FFC ffc pubKey) =+		JSON.pairs+		 (  "group" .= ffc+		 <> "y"     .= nat pubKey+		 )+instance FromJSON (ElectionCrypto c) where+	parseJSON = JSON.withObject "ElectionCrypto" $ \o -> do+		ffc <- o .: "group"+		pubKey <- reify ffc $ \(_::Proxy s) -> nat <$> ((.:) @(PublicKey s) o "y")+		{-+		unless (nat ffc_groupGen < ffc_fieldCharac) $+			JSON.typeMismatch "FFC: groupGen is not lower than fieldCharac" (JSON.Object o)+		-}+		return $ ElectionCrypto_FFC ffc (G (F pubKey))++ -- ** Type 'Hash' newtype Hash = Hash Text  deriving (Eq,Ord,Show,Generic)+ deriving anyclass (ToJSON,FromJSON)  deriving newtype NFData +hashJSON :: ToJSON a => a -> Hash+hashJSON = Hash . TL.toStrict . TL.decodeUtf8 . BSL64.encode . JSON.encode++hashElection :: Election c -> Election c+hashElection elec = elec{election_hash=hashJSON elec}+ -- * Type 'Ballot'-data Ballot q = Ballot- { ballot_answers       :: [Answer q]- , ballot_signature     :: Maybe (Signature q)- , ballot_election_uuid :: UUID- , ballot_election_hash :: Hash+data Ballot c = Ballot+ { ballot_answers       :: ![Answer c]+ , ballot_signature     :: !(Maybe (Signature c))+ , ballot_election_uuid :: !UUID+ , ballot_election_hash :: !Hash  } deriving (Generic,NFData)+deriving instance Reifies c FFC => ToJSON (Ballot c)+deriving instance Reifies c FFC => FromJSON (Ballot c)  -- | @('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)+ Reifies c FFC =>+ Monad m => RandomGen r =>+ Election c ->+ Maybe (SecretKey c) -> [[Bool]] ->+ S.StateT r (ExceptT ErrorBallot m) (Ballot c) encryptBallot Election{..} ballotSecKeyMay opinionsByQuest  | List.length election_questions /= List.length opinionsByQuest = 	lift $ throwE $@@ -468,7 +562,7 @@ 			where ballotPubKey = publicKey ballotSecKey 	ballot_answers <- 		S.mapStateT (withExceptT ErrorBallot_Answer) $-			zipWithM (encryptAnswer election_PublicKey voterZKP)+			zipWithM (encryptAnswer (electionCrypto_FFC_PublicKey election_crypto) voterZKP) 			 election_questions opinionsByQuest 	ballot_signature <- case voterKeys of 	 Nothing -> return Nothing@@ -490,8 +584,9 @@ 	 , ballot_signature 	 } -verifyBallot :: SubGroup q => Election q -> Ballot q -> Bool+verifyBallot :: Reifies c FFC => Election c -> Ballot c -> Bool verifyBallot Election{..} Ballot{..} =+	let elecPubKey = electionCrypto_FFC_PublicKey election_crypto in 	ballot_election_uuid == election_uuid && 	ballot_election_hash == election_hash && 	List.length election_questions == List.length ballot_answers &&@@ -506,7 +601,7 @@ 				 (signatureStatement ballot_answers) 	in 	and $ isValidSign :-		List.zipWith (verifyAnswer election_PublicKey zkpSign)+		List.zipWith (verifyAnswer elecPubKey zkpSign) 		 election_questions ballot_answers  -- ** Type 'Signature'@@ -515,25 +610,27 @@ -- 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+data Signature c = Signature+ { signature_publicKey :: !(PublicKey c)    -- ^ Verification key.- , signature_proof     :: Proof q+ , signature_proof     :: !(Proof c)  } deriving (Generic,NFData)+deriving instance Reifies c FFC => ToJSON (Signature c)+deriving instance Reifies c FFC => FromJSON (Signature c)  -- *** 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 :: Reifies c FFC => Foldable f => f (Answer c) -> [G c] 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 -> Commitment c -> BS.ByteString signatureCommitments (ZKP voterZKP) commitment = 	"sig|"<>voterZKP<>"|" -- NOTE: this is actually part of the statement 	 <> bytesNat commitment<>"|"

@@ -0,0 +1,415 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE UndecidableInstances #-} -- for Reifies instances+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- | Finite Field Cryptography (FFC)+-- is a method of implementing discrete logarithm cryptography+-- using finite field mathematics.+module Voting.Protocol.FFC+ ( module Voting.Protocol.FFC+ , Natural+ , Random.RandomGen+ , Reifies(..), reify+ , Proxy(..)+ ) where++import Control.Arrow (first)+import Control.Applicative (Applicative(..))+import Control.DeepSeq (NFData)+import Control.Monad (Monad(..), unless)+import Control.Monad.Trans.Reader (ReaderT(..), asks)+import Control.Monad.Trans.Class (MonadTrans(..))+import Data.Aeson (ToJSON(..),FromJSON(..),(.:),(.:?),(.=))+import Data.Bits+import Data.Bool+import Data.Eq (Eq(..))+import Data.Foldable (Foldable, foldl')+import Data.Function (($), (.), id)+import Data.Functor ((<$>))+import Data.Int (Int)+import Data.Maybe (Maybe(..), fromMaybe, fromJust)+import Data.Ord (Ord(..))+import Data.Proxy (Proxy(..))+import Data.Reflection (Reifies(..), reify)+import Data.Semigroup (Semigroup(..))+import Data.String (IsString(..))+import Data.Text (Text)+import GHC.Generics (Generic)+import GHC.Natural (minusNaturalMaybe)+import Numeric.Natural (Natural)+import Prelude (Integer, Integral(..), fromIntegral, Enum(..))+import Text.Read (readMaybe)+import Text.Show (Show(..))+import qualified Control.Monad.Trans.State.Strict as S+import qualified Crypto.Hash as Crypto+import qualified Data.Aeson as JSON+import qualified Data.Aeson.Types as JSON+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 Prelude as Num+import qualified System.Random as Random++-- * Type 'FFC'+-- | Mutiplicative Sub-Group of a Finite Prime Field.+--+-- NOTE: an 'FFC' term-value is brought into the context of many functions+-- through a type-variable @c@ whose 'Reifies' constraint enables to 'reflect'+-- that 'FFC' at the term-level (a surprising technique but a very useful one).+-- Doing like this is simpler than working in a 'Monad' (like a 'Reader'),+-- and enables that 'FFC' term to be used simply in instances' methods+-- not supporting an inner 'Monad', like 'parseJSON', 'randomR', 'fromEnum' or 'arbitrary'.+-- Aside from that, the sharing of 'FFC' amongst several types+-- is encoded at the type-level by including @c@+-- as a phantom type of 'F', 'G' and 'E'.+data FFC = FFC+ {   ffc_name :: Text+ ,   ffc_fieldCharac :: !Natural+     -- ^ The prime number characteristic of a Finite Prime Field.+     --+     -- ElGamal's hardness to decrypt requires a large prime number+     -- to form the 'Multiplicative' subgroup.+ ,   ffc_groupGen :: !Natural+     -- ^ A generator of the 'Multiplicative' subgroup of the Finite Prime Field.+     --+     -- NOTE: since 'ffc_fieldCharac' is prime,+     -- 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.+ ,   ffc_groupOrder :: !Natural+     -- ^ The order of the subgroup.+     --+     -- WARNING: 'ffc_groupOrder' MUST be a prime number dividing @('ffc_fieldCharac'-1)@+     -- to ensure that ElGamal is secure in terms of the DDH assumption.+ } deriving (Eq,Show,Generic,NFData)+deriving instance ToJSON FFC+instance FromJSON FFC where+	parseJSON = JSON.withObject "FFC" $ \o -> do+		ffc_name <- fromMaybe "" <$> (o .:? "name")+		ffc_fieldCharac <- o .: "p"+		ffc_groupGen    <- o .: "g"+		ffc_groupOrder  <- o .: "q"+		-- TODO: check p is probable prime+		-- TODO: check q is probable prime+		unless (nat ffc_groupGen < ffc_fieldCharac) $+			JSON.typeMismatch "FFC: groupGen is not lower than fieldCharac" (JSON.Object o)+		unless (ffc_groupOrder < ffc_fieldCharac) $+			JSON.typeMismatch "FFC: groupOrder is not lower than fieldCharac" (JSON.Object o)+		unless (nat ffc_groupGen > 1) $+			JSON.typeMismatch "FFC: groupGen is not greater than 1" (JSON.Object o)+		unless (fromJust (ffc_fieldCharac`minusNaturalMaybe`one) `rem` ffc_groupOrder == 0) $+			JSON.typeMismatch "FFC: groupOrder does not divide fieldCharac-1" (JSON.Object o)+		return FFC{..}++fieldCharac :: forall c. Reifies c FFC => Natural+fieldCharac = ffc_fieldCharac (reflect (Proxy::Proxy c))++groupGen :: forall c. Reifies c FFC => G c+groupGen = G $ F $ ffc_groupGen (reflect (Proxy::Proxy c))++groupOrder :: forall c. Reifies c FFC => Natural+groupOrder = ffc_groupOrder (reflect (Proxy::Proxy c))++-- ** Examples+-- | Weak parameters for debugging purposes only.+weakFFC :: FFC+weakFFC = FFC+ { ffc_name        = "weakFFC"+ , ffc_fieldCharac = 263+ , ffc_groupGen    = 2+ , ffc_groupOrder  = 131+ }++-- | Parameters used in Belenios.+-- A 2048-bit 'fieldCharac' of a Finite Prime Field,+-- with a 256-bit 'groupOrder' for a 'Multiplicative' subgroup+-- generated by 'groupGen'.+beleniosFFC :: FFC+beleniosFFC = FFC+ { ffc_name        = "beleniosFFC"+ , ffc_fieldCharac = 20694785691422546401013643657505008064922989295751104097100884787057374219242717401922237254497684338129066633138078958404960054389636289796393038773905722803605973749427671376777618898589872735865049081167099310535867780980030790491654063777173764198678527273474476341835600035698305193144284561701911000786737307333564123971732897913240474578834468260652327974647951137672658693582180046317922073668860052627186363386088796882120769432366149491002923444346373222145884100586421050242120365433561201320481118852408731077014151666200162313177169372189248078507711827842317498073276598828825169183103125680162072880719+ , ffc_groupGen    =  2402352677501852209227687703532399932712287657378364916510075318787663274146353219320285676155269678799694668298749389095083896573425601900601068477164491735474137283104610458681314511781646755400527402889846139864532661215055797097162016168270312886432456663834863635782106154918419982534315189740658186868651151358576410138882215396016043228843603930989333662772848406593138406010231675095763777982665103606822406635076697764025346253773085133173495194248967754052573659049492477631475991575198775177711481490920456600205478127054728238140972518639858334115700568353695553423781475582491896050296680037745308460627+ , ffc_groupOrder  = 78571733251071885079927659812671450121821421258408794611510081919805623223441+ }++-- * Type 'F'+-- | The type of the elements of a Finite Prime Field.+--+-- 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 c = F { unF :: Natural }+ deriving (Eq,Ord,Show)+ deriving newtype NFData+instance ToJSON (F c) where+	toJSON (F x) = JSON.toJSON (show x)+instance Reifies c FFC => FromJSON (F c) where+	parseJSON (JSON.String s)+	 | Just (c0,_) <- Text.uncons s+	 , c0 /= '0'+	 , Text.all Char.isDigit s+	 , Just x <- readMaybe (Text.unpack s)+	 , x < fieldCharac @c+	 = return (F x)+	parseJSON json = JSON.typeMismatch "F" json+instance Reifies c FFC => FromNatural (F c) where+	fromNatural i = F $ abs $ i `mod` fieldCharac @c+		where+		abs x | x < 0 = x + fieldCharac @c+		      | otherwise = x+instance ToNatural (F c) where+	nat = unF+instance Reifies c FFC => Additive (F c) where+	zero = F 0+	F x + F y = F $ (x + y) `mod` fieldCharac @c+instance Reifies c FFC => Negable (F c) where+	neg (F x)+	 | x == 0 = zero+	 | otherwise = F $ fromJust $ nat (fieldCharac @c)`minusNaturalMaybe`x+instance Reifies c FFC => Multiplicative (F c) where+	one = F 1+	F x * F y = F $ (x * y) `mod` fieldCharac @c+instance Reifies c FFC => Random.Random (F c) where+	randomR (F lo, F hi) =+		first (F . fromIntegral) .+		Random.randomR+		 ( 0`max`toInteger lo+		 , toInteger hi`min`(toInteger (fieldCharac @c) - 1) )+	random =+		first (F . fromIntegral) .+		Random.randomR (0, toInteger (fieldCharac @c) - 1)++-- ** 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 Finite Prime Field.+newtype G c = G { unG :: F c }+ deriving (Eq,Ord,Show)+ deriving newtype NFData+instance ToJSON (G c) where+	toJSON (G x) = JSON.toJSON x+instance Reifies c FFC => FromJSON (G c) where+	parseJSON (JSON.String s)+	 | Just (c0,_) <- Text.uncons s+	 , c0 /= '0'+	 , Text.all Char.isDigit s+	 , Just x <- readMaybe (Text.unpack s)+	 , x < fieldCharac @c+	 , r <- G (F x)+	 , r ^ E (groupOrder @c) == one+	 = return r+	parseJSON json = JSON.typeMismatch "G" json+instance Reifies c FFC => FromNatural (G c) where+	fromNatural = G . fromNatural+instance ToNatural (G c) where+	nat = unF . unG+instance Reifies c FFC => Multiplicative (G c) where+	one = G $ F one+	G x * G y = G (x * y)+instance Reifies c FFC => Invertible (G c) where+	-- | NOTE: add 'groupOrder' so the exponent given to (^) is positive.+	inv = (^ E (fromJust $ groupOrder @c`minusNaturalMaybe`1))++-- | '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.+--+-- Used by 'intervalDisjunctions'.+groupGenInverses :: forall c. Reifies c FFC => [G c]+groupGenInverses = go one+	where+	invGen = inv $ groupGen @c+	go g = g : go (g * invGen)++groupGenPowers :: forall c. Reifies c FFC => [G c]+groupGenPowers = go one+	where go g = g : go (g * groupGen @c)++-- | @('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 :: Reifies c FFC => BS.ByteString -> [G c] -> E c+hash bs gs = do+	let s = bs <> BS.intercalate (fromString ",") (bytesNat <$> gs)+	let h = ByteArray.convert (Crypto.hashWith Crypto.SHA256 s)+	fromNatural (BS.foldl' (\acc b -> acc`shiftL`3 + fromIntegral b) (0::Natural) h)++-- * Type 'E'+-- | An exponent of a (necessarily cyclic) subgroup of a Finite Prime Field.+-- The value is always in @[0..'groupOrder'-1]@.+newtype E c = E { unE :: Natural }+ deriving (Eq,Ord,Show)+ deriving newtype NFData+instance ToJSON (E c) where+	toJSON (E x) = JSON.toJSON x+instance Reifies c FFC => FromJSON (E c) where+	parseJSON (JSON.String s)+	 | Just (c0,_) <- Text.uncons s+	 , c0 /= '0'+	 , Text.all Char.isDigit s+	 , Just x <- readMaybe (Text.unpack s)+	 , x < groupOrder @c+	 = return (E x)+	parseJSON json = JSON.typeMismatch "E" json++instance Reifies c FFC => FromNatural (E c) where+	fromNatural i =+		E $ abs $ i `mod` groupOrder @c+		where+		abs x | x < 0 = x + groupOrder @c+		      | otherwise = x+instance ToNatural (E c) where+	nat = unE++instance Reifies c FFC => Additive (E c) where+	zero = E zero+	E x + E y = E $ (x + y) `mod` groupOrder @c+instance Reifies c FFC => Negable (E c) where+	neg (E x)+	 | x == 0 = zero+	 | otherwise = E $ fromJust $ nat (groupOrder @c)`minusNaturalMaybe`x+instance Reifies c FFC => Multiplicative (E c) where+	one = E one+	E x * E y = E $ (x * y) `mod` groupOrder @c+instance Reifies c FFC => Random.Random (E c) where+	randomR (E lo, E hi) =+		first (E . fromIntegral) .+		Random.randomR+		 ( 0`max`toInteger lo+		 , toInteger hi`min`(toInteger (groupOrder @c) - 1) )+	random =+		first (E . fromIntegral) .+		Random.randomR (0, toInteger (groupOrder @c) - 1)+instance Reifies c FFC => Enum (E c) where+	toEnum = fromNatural . fromIntegral+	fromEnum = fromIntegral . nat+	enumFromTo lo hi = List.unfoldr+	 (\i -> if i<=hi then Just (i, i+one) else Nothing) lo++infixr 8 ^+-- | @(b '^' e)@ returns the modular exponentiation of base 'b' by exponent 'e'.+(^) :: Reifies c FFC => G c -> E c -> G c+(^) b (E e)+ | e == 0 = one+ | otherwise = t * (b*b) ^ E (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++-- * Conversions++-- ** Class 'FromNatural'+class FromNatural a where+	fromNatural :: Natural -> a++-- ** Class 'ToNatural'+class ToNatural a where+	nat :: a -> Natural+instance ToNatural Natural where+	nat = id++-- | @('bytesNat' x)@ returns the serialization of 'x'.+bytesNat :: ToNatural n => n -> BS.ByteString+bytesNat = fromString . show . nat

@@ -1,18 +1,19 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE UndecidableInstances #-} -- for Reifies instances module Voting.Protocol.Tally where  import Control.DeepSeq (NFData) import Control.Monad (Monad(..), mapM, unless) import Control.Monad.Trans.Except (Except, ExceptT, throwE)+import Data.Aeson (ToJSON(..),FromJSON(..)) import Data.Eq (Eq(..)) import Data.Function (($)) import Data.Functor ((<$>)) import Data.Maybe (maybe) import Data.Semigroup (Semigroup(..))-import Data.Text (Text)-import Data.Tuple (fst, uncurry)+import Data.Tuple (fst) import GHC.Generics (Generic) import Numeric.Natural (Natural) import Prelude (fromIntegral)@@ -23,103 +24,97 @@ import qualified Data.Map.Strict as Map  import Voting.Protocol.Utils-import Voting.Protocol.Arithmetic+import Voting.Protocol.FFC import Voting.Protocol.Credential import Voting.Protocol.Election  -- * Type 'Tally'-data Tally q = Tally- { tally_countMax :: Natural+data Tally c = Tally+ { tally_countMax :: !Natural    -- ^ The maximal number of supportive 'Opinion's that a choice can get,    -- which is here the same as the number of 'Ballot's.    --    -- Used in 'proveTally' to decrypt the actual    -- count of votes obtained by a choice,    -- by precomputing all powers of 'groupGen's up to it.- , tally_encByChoiceByQuest :: EncryptedTally q+ , tally_encByChoiceByQuest :: !(EncryptedTally c)    -- ^ 'Encryption' by 'Question' by 'Ballot'.- , tally_decShareByTrustee :: [DecryptionShare q]+ , tally_decShareByTrustee :: ![DecryptionShare c]    -- ^ 'DecryptionShare' by trustee.- , tally_countByChoiceByQuest :: [[Natural]]+ , tally_countByChoiceByQuest :: ![[Natural]]    -- ^ The decrypted count of supportive 'Opinion's, by choice by 'Question'.  } deriving (Eq,Show,Generic,NFData)+deriving instance Reifies c FFC => ToJSON (Tally c)+deriving instance Reifies c FFC => FromJSON (Tally c)  -- ** Type 'EncryptedTally'--- | 'Encryption' by 'Choice' by 'Question'.-type EncryptedTally q = [[Encryption q]]+-- | 'Encryption' by choice by 'Question'.+type EncryptedTally c = [[Encryption c]]  -- | @('encryptedTally' ballots)@ -- returns the sum of the 'Encryption's of the given @ballots@, -- along with the number of 'Ballot's.-encryptedTally :: SubGroup q => [Ballot q] -> (EncryptedTally q, Natural)+encryptedTally :: Reifies c FFC => [Ballot c] -> (EncryptedTally c, Natural) encryptedTally ballots = 	( List.foldr (\Ballot{..} -> 		List.zipWith (\Answer{..} -> 			List.zipWith (+) 			 (fst <$> answer_opinions))-		 ballot_answers-	 )+		 ballot_answers) 	 (List.repeat (List.repeat zero)) 	 ballots 	, fromIntegral $ List.length ballots 	)  -- ** Type 'DecryptionShareCombinator'-type DecryptionShareCombinator q =-	[DecryptionShare q] -> Except ErrorDecryptionShare [[DecryptionFactor q]]+type DecryptionShareCombinator c =+	EncryptedTally c -> [DecryptionShare c] -> Except ErrorTally [[DecryptionFactor c]]  proveTally ::- SubGroup q =>- (EncryptedTally q, Natural) -> [DecryptionShare q] ->- DecryptionShareCombinator q ->- Except ErrorDecryptionShare (Tally q)+ Reifies c FFC =>+ (EncryptedTally c, Natural) -> [DecryptionShare c] ->+ DecryptionShareCombinator c ->+ Except ErrorTally (Tally c) proveTally  (tally_encByChoiceByQuest, tally_countMax)  tally_decShareByTrustee  decShareCombinator = do-	decFactorByChoiceByQuest <- decShareCombinator tally_decShareByTrustee-	dec <- isoZipWithM err-	 (\encByChoice decFactorByChoice ->-		maybe err return $-			isoZipWith (\Encryption{..} decFactor -> encryption_vault / decFactor)-			 encByChoice-			 decFactorByChoice)+	decFactorByChoiceByQuest <-+		decShareCombinator+		 tally_encByChoiceByQuest+		 tally_decShareByTrustee+	dec <- isoZipWithM (throwE ErrorTally_NumberOfQuestions)+	 (maybe (throwE ErrorTally_NumberOfChoices) return `o2`+		isoZipWith (\Encryption{..} decFactor -> encryption_vault / decFactor)) 	 tally_encByChoiceByQuest 	 decFactorByChoiceByQuest 	let logMap = Map.fromList $ List.zip groupGenPowers [0..tally_countMax] 	let log x =-		maybe (throwE $ ErrorDecryptionShare_InvalidMaxCount) return $+		maybe (throwE ErrorTally_CannotDecryptCount) return $ 		Map.lookup x logMap 	tally_countByChoiceByQuest <- (log `mapM`)`mapM`dec 	return Tally{..}-	where err = throwE $ ErrorDecryptionShare_Invalid "proveTally"  verifyTally ::- SubGroup q =>- Tally q -> DecryptionShareCombinator q ->- Except ErrorDecryptionShare ()+ Reifies c FFC =>+ Tally c -> DecryptionShareCombinator c ->+ Except ErrorTally () verifyTally Tally{..} decShareCombinator = do-	decFactorByChoiceByQuest <- decShareCombinator tally_decShareByTrustee-	isoZipWith3M_ (throwE $ ErrorDecryptionShare_Invalid "verifyTally")-	 (isoZipWith3M_ (throwE $ ErrorDecryptionShare_Invalid "verifyTally")+	decFactorByChoiceByQuest <- decShareCombinator tally_encByChoiceByQuest tally_decShareByTrustee+	isoZipWith3M_ (throwE ErrorTally_NumberOfQuestions)+	 (isoZipWith3M_ (throwE ErrorTally_NumberOfChoices) 		 (\Encryption{..} decFactor count -> do 			let groupGenPowCount = encryption_vault / decFactor 			unless (groupGenPowCount == groupGen ^ fromNatural count) $-				throwE ErrorDecryptionShare_Wrong))+				throwE ErrorTally_WrongProof)) 	 tally_encByChoiceByQuest 	 decFactorByChoiceByQuest 	 tally_countByChoiceByQuest  -- ** Type 'DecryptionShare'--- | A decryption share. It is computed by a trustee--- from its 'SecretKey' share and the 'EncryptedTally',--- and contains a cryptographic 'Proof' that it hasn't cheated.-data DecryptionShare q = DecryptionShare- { decryptionShare_factors :: [[DecryptionFactor q]]-   -- ^ 'DecryptionFactor' by choice by 'Question'.- , decryptionShare_proofs  :: [[Proof q]]-   -- ^ 'Proof's that 'decryptionShare_factors' were correctly computed.- } deriving (Eq,Show,Generic,NFData)+-- | A decryption share is a 'DecryptionFactor' and a decryption 'Proof', by choice by 'Question'.+-- Computed by a trustee in 'proveDecryptionShare'.+type DecryptionShare c = [[(DecryptionFactor c, Proof c)]]  -- *** Type 'DecryptionFactor' -- | @'encryption_nonce' '^'trusteeSecKey@@@ -127,33 +122,37 @@  -- @('proveDecryptionShare' encByChoiceByQuest trusteeSecKey)@ proveDecryptionShare ::- Monad m => SubGroup q => RandomGen r =>- EncryptedTally q -> SecretKey q -> S.StateT r m (DecryptionShare q)-proveDecryptionShare encByChoiceByQuest trusteeSecKey = do-	res <- (proveDecryptionFactor trusteeSecKey `mapM`) `mapM` encByChoiceByQuest-	return $ uncurry DecryptionShare $ List.unzip (List.unzip <$> res)+ Monad m => Reifies c FFC => RandomGen r =>+ EncryptedTally c -> SecretKey c -> S.StateT r m (DecryptionShare c)+proveDecryptionShare encByChoiceByQuest trusteeSecKey =+	(proveDecryptionFactor trusteeSecKey `mapM`) `mapM` encByChoiceByQuest  proveDecryptionFactor ::- Monad m => SubGroup q => RandomGen r =>- SecretKey q -> Encryption q -> S.StateT r m (DecryptionFactor q, Proof q)+ Monad m => Reifies c FFC => RandomGen r =>+ SecretKey c -> Encryption c -> S.StateT r m (DecryptionFactor c, Proof c) proveDecryptionFactor trusteeSecKey Encryption{..} = do 	proof <- prove trusteeSecKey [groupGen, encryption_nonce] (hash zkp) 	return (encryption_nonce^trusteeSecKey, proof) 	where zkp = decryptionShareStatement (publicKey trusteeSecKey) -decryptionShareStatement :: SubGroup q => PublicKey q -> BS.ByteString+decryptionShareStatement :: Reifies c FFC => PublicKey c -> BS.ByteString decryptionShareStatement pubKey = 	"decrypt|"<>bytesNat pubKey<>"|" --- *** Type 'ErrorDecryptionShare'-data ErrorDecryptionShare- =   ErrorDecryptionShare_Invalid Text-     -- ^ The number of 'DecryptionFactor's or-     -- the number of 'Proof's is not the same-     -- or not the expected number.- |   ErrorDecryptionShare_Wrong+-- *** Type 'ErrorTally'+data ErrorTally+ =   ErrorTally_NumberOfQuestions+     -- ^ The number of 'Question's is not the one expected.+ |   ErrorTally_NumberOfChoices+     -- ^ The number of choices is not the one expected.+ |   ErrorTally_NumberOfTrustees+     -- ^ The number of trustees is not the one expected.+ |   ErrorTally_WrongProof      -- ^ The 'Proof' of a 'DecryptionFactor' is wrong.- |   ErrorDecryptionShare_InvalidMaxCount+ |   ErrorTally_CannotDecryptCount+     -- ^ Raised by 'proveTally' when the discrete logarithm of @'groupGen' '^'count@+     -- cannot be computed, likely because 'tally_countMax' is wrong,+     -- or because the 'EncryptedTally' or 'DecryptionShare's have not been verified.  deriving (Eq,Show,Generic,NFData)  -- | @('verifyDecryptionShare' encTally trusteePubKey trusteeDecShare)@@@ -161,27 +160,24 @@ -- (supposedly submitted by a trustee whose 'PublicKey' is 'trusteePubKey') -- is valid with respect to the 'EncryptedTally' 'encTally'. verifyDecryptionShare ::- Monad m => SubGroup q =>- EncryptedTally q -> PublicKey q -> DecryptionShare q ->- ExceptT ErrorDecryptionShare m ()-verifyDecryptionShare encTally trusteePubKey DecryptionShare{..} =+ Monad m => Reifies c FFC =>+ EncryptedTally c -> PublicKey c -> DecryptionShare c ->+ ExceptT ErrorTally m ()+verifyDecryptionShare encByChoiceByQuest trusteePubKey = 	let zkp = decryptionShareStatement trusteePubKey in-	isoZipWith3M_ (throwE $ ErrorDecryptionShare_Invalid "verifyDecryptionShare")-	 (isoZipWith3M_ (throwE $ ErrorDecryptionShare_Invalid "verifyDecryptionShare") $-	 \Encryption{..} decFactor proof ->+	isoZipWithM_ (throwE ErrorTally_NumberOfQuestions)+	 (isoZipWithM_ (throwE ErrorTally_NumberOfChoices) $+	 \Encryption{..} (decFactor, proof) -> 		unless (proof_challenge proof == hash zkp 		 [ commit proof groupGen trusteePubKey 		 , commit proof encryption_nonce decFactor-		 ]) $-			throwE ErrorDecryptionShare_Wrong)-	 encTally-	 decryptionShare_factors-	 decryptionShare_proofs+		 ]) $ throwE ErrorTally_WrongProof)+	 encByChoiceByQuest  verifyDecryptionShareByTrustee ::- Monad m => SubGroup q =>- EncryptedTally q -> [PublicKey q] -> [DecryptionShare q] ->- ExceptT ErrorDecryptionShare m ()+ Monad m => Reifies c FFC =>+ EncryptedTally c -> [PublicKey c] -> [DecryptionShare c] ->+ ExceptT ErrorTally m () verifyDecryptionShareByTrustee encTally =-	isoZipWithM_ (throwE $ ErrorDecryptionShare_Invalid "verifyDecryptionShare")+	isoZipWithM_ (throwE ErrorTally_NumberOfTrustees) 	 (verifyDecryptionShare encTally)

@@ -1,27 +1,35 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE UndecidableInstances #-} -- for Reifies instances module Voting.Protocol.Trustee.Indispensable where +import Control.DeepSeq (NFData) import Control.Monad (Monad(..), foldM, unless) import Control.Monad.Trans.Except (ExceptT(..), throwE)+import Data.Aeson (ToJSON(..),FromJSON(..)) import Data.Eq (Eq(..)) import Data.Function (($))+import Data.Functor ((<$>)) import Data.Maybe (maybe) import Data.Semigroup (Semigroup(..))+import Data.Tuple (fst)+import GHC.Generics (Generic) 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.FFC import Voting.Protocol.Credential import Voting.Protocol.Election import Voting.Protocol.Tally  -- * Type 'TrusteePublicKey'-data TrusteePublicKey q = TrusteePublicKey- { trustee_PublicKey      :: PublicKey q- , trustee_SecretKeyProof :: Proof q+data TrusteePublicKey c = TrusteePublicKey+ { trustee_PublicKey      :: !(PublicKey c)+ , trustee_SecretKeyProof :: !(Proof c) 	-- ^ NOTE: It is important to ensure 	-- that each trustee generates its key pair independently 	-- of the 'PublicKey's published by the other trustees.@@ -35,11 +43,13 @@ 	-- must 'prove' knowledge of the corresponding 'SecretKey'. 	-- Which is done in 'proveIndispensableTrusteePublicKey' 	-- and 'verifyIndispensableTrusteePublicKey'.- } deriving (Eq,Show)+ } deriving (Eq,Show,Generic,NFData)+deriving instance Reifies c FFC => ToJSON (TrusteePublicKey c)+deriving instance Reifies c FFC => FromJSON (TrusteePublicKey c)  -- ** Type 'ErrorTrusteePublicKey' data ErrorTrusteePublicKey- =   ErrorTrusteePublicKey_Wrong+ =   ErrorTrusteePublicKey_WrongProof      -- ^ The 'trustee_SecretKeyProof' is wrong.  deriving (Eq,Show) @@ -47,8 +57,8 @@ -- returns the 'PublicKey' associated to 'trustSecKey' -- and a 'Proof' of its knowledge. proveIndispensableTrusteePublicKey ::- Monad m => RandomGen r => SubGroup q =>- SecretKey q -> S.StateT r m (TrusteePublicKey q)+ Reifies c FFC => Monad m => RandomGen r =>+ SecretKey c -> S.StateT r m (TrusteePublicKey c) proveIndispensableTrusteePublicKey trustSecKey = do 	let trustee_PublicKey = publicKey trustSecKey 	trustee_SecretKeyProof <-@@ -61,46 +71,52 @@ -- does 'prove' that the 'SecretKey' associated with -- the given 'trustee_PublicKey' is known by the trustee. verifyIndispensableTrusteePublicKey ::- Monad m => SubGroup q =>- TrusteePublicKey q ->+ Reifies c FFC => Monad m =>+ TrusteePublicKey c ->  ExceptT ErrorTrusteePublicKey m () verifyIndispensableTrusteePublicKey TrusteePublicKey{..} = 	unless ((proof_challenge trustee_SecretKeyProof ==) $ 	hash 	 (indispensableTrusteePublicKeyStatement trustee_PublicKey) 	 [commit trustee_SecretKeyProof groupGen trustee_PublicKey]) $-		throwE ErrorTrusteePublicKey_Wrong+		throwE ErrorTrusteePublicKey_WrongProof  -- ** Hashing-indispensableTrusteePublicKeyStatement :: PublicKey q -> BS.ByteString-indispensableTrusteePublicKeyStatement trustPubKey = "pok|"<>bytesNat trustPubKey<>"|"+indispensableTrusteePublicKeyStatement :: PublicKey c -> BS.ByteString+indispensableTrusteePublicKeyStatement trustPubKey =+	"pok|"<>bytesNat trustPubKey<>"|"  -- * 'Election''s 'PublicKey'  combineIndispensableTrusteePublicKeys ::- SubGroup q => [TrusteePublicKey q] -> PublicKey q+ Reifies c FFC => [TrusteePublicKey c] -> PublicKey c combineIndispensableTrusteePublicKeys = 	List.foldr (\TrusteePublicKey{..} -> (trustee_PublicKey *)) one  verifyIndispensableDecryptionShareByTrustee ::- SubGroup q => Monad m =>- EncryptedTally q -> [PublicKey q] -> [DecryptionShare q] ->- ExceptT ErrorDecryptionShare m ()-verifyIndispensableDecryptionShareByTrustee encTally =-	isoZipWithM_ (throwE $ ErrorDecryptionShare_Invalid "verifyIndispensableDecryptionShareByTrustee")-	 (verifyDecryptionShare encTally)+ Reifies c FFC => Monad m =>+ EncryptedTally c -> [PublicKey c] -> [DecryptionShare c] ->+ ExceptT ErrorTally m ()+verifyIndispensableDecryptionShareByTrustee encByChoiceByQuest =+	isoZipWithM_ (throwE $ ErrorTally_NumberOfTrustees)+	 (verifyDecryptionShare encByChoiceByQuest)  -- | @('combineDecryptionShares' pubKeyByTrustee decShareByTrustee)@ -- returns the 'DecryptionFactor's by choice by 'Question' combineIndispensableDecryptionShares ::- SubGroup q => [PublicKey q] -> EncryptedTally q -> DecryptionShareCombinator q-combineIndispensableDecryptionShares pubKeyByTrustee encTally decShareByTrustee = do-	verifyIndispensableDecryptionShareByTrustee encTally pubKeyByTrustee decShareByTrustee-	(d0,ds) <- maybe err return $ List.uncons decShareByTrustee-	foldM-	 (\decFactorByChoiceByQuest DecryptionShare{..} ->-		isoZipWithM err-		 (\acc df -> maybe err return $ isoZipWith (*) acc df)-		 decFactorByChoiceByQuest decryptionShare_factors)-	 (decryptionShare_factors d0) ds-	where err = throwE $ ErrorDecryptionShare_Invalid "combineIndispensableDecryptionShares"+ Reifies c FFC => [PublicKey c] -> DecryptionShareCombinator c+combineIndispensableDecryptionShares+ pubKeyByTrustee+ encByChoiceByQuest+ decByChoiceByQuestByTrustee = do+	verifyIndispensableDecryptionShareByTrustee+	 encByChoiceByQuest+	 pubKeyByTrustee+	 decByChoiceByQuestByTrustee+	(dec0,decs) <-+		maybe (throwE ErrorTally_NumberOfTrustees) return $+		List.uncons decByChoiceByQuestByTrustee+	foldM (isoZipWithM (throwE ErrorTally_NumberOfQuestions)+	 (maybe (throwE ErrorTally_NumberOfChoices) return `o2`+		isoZipWith (\a (decFactor, _proof) -> a * decFactor)))+	 ((fst <$>) <$> dec0) decs

@@ -10,6 +10,12 @@ import Data.Traversable (Traversable(..)) import qualified Data.List as List +-- | Like ('.') but with two arguments.+o2 :: (c -> d) -> (a -> b -> c) -> a -> b -> d+o2 f g = \x y -> f (g x y)+infixr 9 `o2`+{-# INLINE o2 #-}+ -- | NOTE: check the lengths before applying @f@. isoZipWith :: (a->b->c) -> [a]->[b]->Maybe [c] isoZipWith f as bs@@ -25,38 +31,29 @@  where al = List.length as  isoZipWithM ::- Applicative m =>- m () ->- (a -> b -> m c) ->- [a] -> [b] -> m [c]+ Applicative f =>+ f () -> (a->b->f c) -> [a]->[b]->f [c] isoZipWithM err f as bs = 	maybe ([] <$ err) sequenceA $ 		isoZipWith f as bs  isoZipWithM_ ::- Applicative m =>- m () ->- (a -> b -> m c) ->- [a] -> [b] -> m ()+ Applicative f =>+ f () -> (a->b->f c) -> [a]->[b]->f () 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]+ Applicative f =>+ f () -> (a->b->c->f d) -> [a]->[b]->[c]->f [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 ()+ Applicative f =>+ f () -> (a->b->c->f d) -> [a]->[b]->[c]->f () isoZipWith3M_ err f as bs cs = 	maybe err sequenceA_ $ 		isoZipWith3 f as bs cs

@@ -1,4 +1,4 @@-resolver: lts-12.26+resolver: lts-13.19 packages: - '.' - location: '../hjugement'

@@ -1,6 +1,6 @@ module HUnit where import Test.Tasty-import qualified HUnit.Arithmetic+import qualified HUnit.FFC import qualified HUnit.Credential import qualified HUnit.Election import qualified HUnit.Trustee@@ -8,7 +8,7 @@ hunits :: TestTree hunits = 	testGroup "HUnit"-	 [ HUnit.Arithmetic.hunit+	 [ HUnit.FFC.hunit 	 , HUnit.Credential.hunit 	 , HUnit.Election.hunit 	 , HUnit.Trustee.hunit

@@ -1,41 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE OverloadedStrings #-}-module HUnit.Arithmetic where--import Test.Tasty.HUnit-import Voting.Protocol-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-		 ]-	 ]- ]

@@ -1,4 +1,3 @@-{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE OverloadedStrings #-} module HUnit.Credential where @@ -25,29 +24,30 @@  , 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+	 [ "" ==> Left ErrorToken_Length+	 , "xLcs7ev6Jy6FH_E"  ==> Left (ErrorToken_BadChar '_')+	 , "xLcs7ev6Jy6FHIE"  ==> Left (ErrorToken_BadChar 'I')+	 , "xLcs7ev6Jy6FH0E"  ==> Left (ErrorToken_BadChar '0')+	 , "xLcs7ev6Jy6FHOE"  ==> Left (ErrorToken_BadChar 'O')+	 , "xLcs7ev6Jy6FHlE"  ==> Left (ErrorToken_BadChar 'l')+	 , "xLcs7ev6Jy6FH6"   ==> Left ErrorToken_Length+	 , "xLcs7ev6Jy6FHHy1" ==> Left ErrorToken_Length+	 , "xLcs7ev6Jy6FHHF"  ==> Left ErrorToken_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 weakFFC 0 122+	 , testSecretKey weakFFC 1 35+	 , testSecretKey beleniosFFC 0 2317630607062989137269685509390+	 , testSecretKey beleniosFFC 1 1968146140481358915910346867611 	 ]  ] -testSecretKey :: forall q. SubGroup q => Int -> E q -> TestTree-testSecretKey seed exp =+testSecretKey :: FFC -> Int -> Natural -> TestTree+testSecretKey ffc seed exp =+	reify ffc $ \(Proxy::Proxy c) -> 	let (uuid@(UUID u), cred@(Credential c)) = 		(`S.evalState` Random.mkStdGen seed) $ 			(,) <$> randomUUID <*> randomCredential in 	testCase (show (u,c)) $-		credentialSecretKey @q uuid cred @?= exp+		credentialSecretKey @c uuid cred @?= E exp

@@ -1,11 +1,12 @@-{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} module HUnit.Election where  import Test.Tasty.HUnit+import qualified Data.Aeson as JSON import qualified Data.List as List+import qualified Data.Text as Text import qualified System.Random as Random  import Voting.Protocol@@ -16,54 +17,56 @@ hunit = testGroup "Election"  [ testGroup "groupGenInverses" 	 [ testCase "WeakParams" $-		List.take 10 (groupGenInverses @WeakParams) @?=-			[groupGen^neg (fromNatural n) | n <- [0..9]]+		reify weakFFC $ \(Proxy::Proxy c) ->+			List.take 10 (groupGenInverses @c) @?=+				[groupGen^neg (fromNatural n) | n <- [0..9]] 	 , testCase "BeleniosParams" $-		List.take 10 (groupGenInverses @BeleniosParams) @?=-			[groupGen^neg (fromNatural n) | n <- [0..9]]+		reify beleniosFFC $ \(Proxy::Proxy c) ->+			List.take 10 (groupGenInverses @c) @?=+				[groupGen^neg (fromNatural n) | n <- [0..9]] 	 ]  , testGroup "encryptBallot" $-	 [ testsEncryptBallot @WeakParams-	 , testsEncryptBallot @BeleniosParams+	 [ testsEncryptBallot weakFFC+	 , testsEncryptBallot beleniosFFC 	 ]  ] -testsEncryptBallot :: forall q. Params q => TestTree-testsEncryptBallot =-	testGroup (paramsName @q)-	 [ testEncryptBallot @q 0+testsEncryptBallot :: FFC -> TestTree+testsEncryptBallot ffc =+	testGroup (Text.unpack $ ffc_name ffc)+	 [ testEncryptBallot ffc 0 		 [Question "q1" ["a1","a2","a3"] zero one] 		 [[True, False, False]] 		 (Right True)-	 , testEncryptBallot @q 0+	 , testEncryptBallot ffc 0 		 [Question "q1" ["a1","a2","a3"] zero one] 		 [[False, False, False]] 		 (Right True)-	 , testEncryptBallot @q 0+	 , testEncryptBallot ffc 0 		 [Question "q1" ["a1","a2","a3"] zero one] 		 [[False, False, False]] 		 (Right True)-	 , testEncryptBallot @q 0+	 , testEncryptBallot ffc 0 		 [Question "q1" [] zero one] 		 [] 		 (Left (ErrorBallot_WrongNumberOfAnswers 0 1))-	 , testEncryptBallot @q 0+	 , testEncryptBallot ffc 0 		 [Question "q1" ["a1","a2"] one one] 		 [[True]] 		 (Left (ErrorBallot_Answer (ErrorAnswer_WrongNumberOfOpinions 1 2)))-	 , testEncryptBallot @q 0+	 , testEncryptBallot ffc 0 		 [Question "q1" ["a1","a2","a3"] zero one] 		 [[True, True, False]] 		 (Left (ErrorBallot_Answer (ErrorAnswer_WrongSumOfOpinions 2 0 1)))-	 , testEncryptBallot @q 0+	 , testEncryptBallot ffc 0 		 [Question "q1" ["a1","a2","a3"] one one] 		 [[False, False, False]] 		 (Left (ErrorBallot_Answer (ErrorAnswer_WrongSumOfOpinions 0 1 1)))-	 , testEncryptBallot @q 0+	 , testEncryptBallot ffc 0 		 [Question "q1" ["a1","a2"] one one] 		 [[False, False, True]] 		 (Left (ErrorBallot_Answer (ErrorAnswer_WrongNumberOfOpinions 3 2)))-	 , testEncryptBallot @q 0+	 , testEncryptBallot ffc 0 		 [ Question "q1" ["a11","a12","a13"] zero (one+one) 		 , Question "q2" ["a21","a22","a23"] one one 		 ]@@ -73,25 +76,25 @@ 	 ]  testEncryptBallot ::- forall q. SubGroup q =>- Int -> [Question q] -> [[Bool]] ->+ FFC -> Int -> [Question] -> [[Bool]] ->  Either ErrorBallot Bool ->  TestTree-testEncryptBallot seed quests opins exp =+testEncryptBallot ffc seed quests opins exp = 	let got =+		reify ffc $ \(Proxy::Proxy c) -> 		runExcept $ 		(`evalStateT` Random.mkStdGen seed) $ do 			uuid <- randomUUID 			cred <- randomCredential-			let ballotSecKey = credentialSecretKey @q uuid cred+			let ballotSecKey = credentialSecretKey @c uuid cred 			elecPubKey <- publicKey <$> randomSecretKey 			let elec = Election 				 { election_name        = "election" 				 , election_description = "description"-				 , election_PublicKey   = elecPubKey+				 , election_crypto      = ElectionCrypto_FFC ffc elecPubKey 				 , election_questions   = quests 				 , election_uuid        = uuid-				 , election_hash        = Hash "" -- FIXME: when implemented+				 , election_hash        = hashJSON JSON.Null 				 } 			verifyBallot elec 			 <$> encryptBallot elec (Just ballotSecKey) opins

@@ -0,0 +1,46 @@+{-# LANGUAGE OverloadedStrings #-}+module HUnit.FFC where++import GHC.Natural (minusNaturalMaybe)+import Data.Maybe (fromJust)+import Test.Tasty.HUnit+import Voting.Protocol+import Utils++hunit :: TestTree+hunit = testGroup "FFC"+ [ testGroup "inv"+	 [ testGroup "WeakParams"+		 [ testCase "groupGen" $+			reify weakFFC $ \(Proxy::Proxy c) ->+				inv (groupGen @c) @?=+					groupGen ^ E (fromJust $ groupOrder @c `minusNaturalMaybe` one)+		 ]+	 , testGroup "BeleniosParams"+		 [ testCase "groupGen" $+			reify beleniosFFC $ \(Proxy::Proxy c) ->+				inv (groupGen @c) @?=+					groupGen ^ E (fromJust $ groupOrder @c `minusNaturalMaybe` one)+		 ]+	 ]+ , testGroup "hash"+	 [ testGroup "WeakParams" $+		reify weakFFC $ \(Proxy::Proxy c) ->+		 [ testCase "[groupGen]" $+			hash "start" [groupGen @c] @?=+				fromNatural 100+		 , testCase "[groupGen, groupGen]" $+			hash "start" [groupGen @c, groupGen] @?=+				fromNatural 16+		 ]+	 , testGroup "BeleniosParams" $+		reify beleniosFFC $ \(Proxy::Proxy c) ->+		 [ testCase "[groupGen]" $+			hash "start" [groupGen @c] @?=+				fromNatural 1832875488615060263192702367259+		 , testCase "[groupGen, groupGen]" $+			hash "start" [groupGen @c, groupGen] @?=+				fromNatural 2495277906542783643199702546512+		 ]+	 ]+ ]

@@ -1,10 +1,10 @@-{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} module HUnit.Trustee.Indispensable where  import Test.Tasty.HUnit+import qualified Data.Text as Text import qualified System.Random as Random import qualified Text.Printf as Printf @@ -15,53 +15,52 @@ hunit :: TestTree hunit = testGroup "Indispensable"  [ testGroup "verifyIndispensableTrusteePublicKey" $-	 [ testsVerifyIndispensableTrusteePublicKey @WeakParams+	 [ testsVerifyIndispensableTrusteePublicKey weakFFC 	 ]  , testGroup "verifyTally" $-	 [ testsVerifyTally @WeakParams-	 , testsVerifyTally @BeleniosParams+	 [ testsVerifyTally weakFFC+	 , testsVerifyTally beleniosFFC 	 ]  ] -testsVerifyIndispensableTrusteePublicKey :: forall q. Params q => TestTree-testsVerifyIndispensableTrusteePublicKey =-	testGroup (paramsName @q)-	 [ testVerifyIndispensableTrusteePublicKey @q 0 (Right ())+testsVerifyIndispensableTrusteePublicKey :: FFC -> TestTree+testsVerifyIndispensableTrusteePublicKey ffc =+	testGroup (Text.unpack $ ffc_name ffc)+	 [ testVerifyIndispensableTrusteePublicKey ffc 0 (Right ()) 	 ]  testVerifyIndispensableTrusteePublicKey ::- forall q. Params q =>- Int -> Either ErrorTrusteePublicKey () -> TestTree-testVerifyIndispensableTrusteePublicKey seed exp =+ FFC -> Int -> Either ErrorTrusteePublicKey () -> TestTree+testVerifyIndispensableTrusteePublicKey ffc seed exp = 	let got =+		reify ffc $ \(Proxy::Proxy c) -> 		runExcept $ 		(`evalStateT` Random.mkStdGen seed) $ do-			trusteeSecKey :: SecretKey q <- randomSecretKey+			trusteeSecKey :: SecretKey c <- randomSecretKey 			trusteePubKey <- proveIndispensableTrusteePublicKey trusteeSecKey 			lift $ verifyIndispensableTrusteePublicKey trusteePubKey 	in-	testCase (show (paramsName @q)) $+	testCase (Text.unpack $ ffc_name ffc) $ 		got @?= exp -testsVerifyTally :: forall q. Params q => TestTree-testsVerifyTally =-	testGroup (paramsName @q)-	 [ testVerifyTally @q 0 1 1 1-	 , testVerifyTally @q 0 2 1 1-	 , testVerifyTally @q 0 1 2 1-	 , testVerifyTally @q 0 2 2 1-	 , testVerifyTally @q 0 5 10 5+testsVerifyTally :: FFC -> TestTree+testsVerifyTally ffc =+	testGroup (Text.unpack $ ffc_name ffc)+	 [ testVerifyTally ffc 0 1 1 1+	 , testVerifyTally ffc 0 2 1 1+	 , testVerifyTally ffc 0 1 2 1+	 , testVerifyTally ffc 0 2 2 1+	 , testVerifyTally ffc 0 5 10 5 	 ] -testVerifyTally ::- forall q. Params q =>- Int -> Natural -> Natural -> Natural -> TestTree-testVerifyTally seed nTrustees nQuests nChoices =+testVerifyTally :: FFC -> Int -> Natural -> Natural -> Natural -> TestTree+testVerifyTally ffc seed nTrustees nQuests nChoices = 	let clearTallyResult = dummyTallyResult nQuests nChoices in-	let decryptedTallyResult :: Either ErrorDecryptionShare [[Natural]] =+	let decryptedTallyResult :: Either ErrorTally [[Natural]] =+		reify ffc $ \(Proxy::Proxy c) -> 		runExcept $ 		(`evalStateT` Random.mkStdGen seed) $ do-			secKeyByTrustee :: [SecretKey q] <-+			secKeyByTrustee :: [SecretKey c] <- 				replicateM (fromIntegral nTrustees) $ randomSecretKey 			trusteePubKeys <- forM secKeyByTrustee $ proveIndispensableTrusteePublicKey 			let pubKeyByTrustee = trustee_PublicKey <$> trusteePubKeys@@ -71,12 +70,12 @@ 			lift $ verifyDecryptionShareByTrustee encTally pubKeyByTrustee decShareByTrustee 			tally@Tally{..} <- lift $ 				proveTally (encTally, countMax) decShareByTrustee $-					combineIndispensableDecryptionShares pubKeyByTrustee encTally+					combineIndispensableDecryptionShares pubKeyByTrustee 			lift $ verifyTally tally $-				combineIndispensableDecryptionShares pubKeyByTrustee encTally+				combineIndispensableDecryptionShares pubKeyByTrustee 			return tally_countByChoiceByQuest 	in-	testCase (Printf.printf "nT=%i,nQ=%i,nC=%i (%i maxCount)"+	testCase (Printf.printf "#T=%i,#Q=%i,#C=%i (%i maxCount)" 	 nTrustees nQuests nChoices 	 (dummyTallyCount nQuests nChoices)) $ 		decryptedTallyResult @?= Right clearTallyResult@@ -91,8 +90,9 @@ 	]  encryptTallyResult ::- Monad m => RandomGen r => SubGroup q =>- PublicKey q -> [[Natural]] -> StateT r m (EncryptedTally q, Natural)+ Reifies c FFC =>+ Monad m => RandomGen r =>+ PublicKey c -> [[Natural]] -> StateT r m (EncryptedTally c, Natural) encryptTallyResult pubKey countByChoiceByQuest = 	(`runStateT` 0) $ 		forM countByChoiceByQuest $

@@ -1,14 +1,18 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE UndecidableInstances #-} -- for Reifies instances {-# 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.Maybe (fromJust) import Data.Ord (Ord(..))+import GHC.Natural (minusNaturalMaybe) import Prelude (undefined)+import Test.Tasty.QuickCheck+import qualified Data.Aeson as JSON+import qualified Data.List as List+import qualified Data.Text as Text  import Voting.Protocol @@ -18,80 +22,86 @@ maxArbitraryChoices :: Natural maxArbitraryChoices = 5 maxArbitraryQuestions :: Natural-maxArbitraryQuestions = 5+maxArbitraryQuestions = 2  quickcheck :: TestTree quickcheck = 	testGroup "Election" 	 [ testGroup "verifyBallot" $-		 [ testElection @WeakParams-		 , testElection @BeleniosParams+		 [ testElection weakFFC+		 , testElection beleniosFFC 		 ] 	 ] -testElection :: forall q. Params q => TestTree-testElection  =-	testGroup (paramsName @q)-	 [ testProperty "verifyBallot" $ \(seed, (elec::Election q) :> votes) ->+testElection :: FFC -> TestTree+testElection ffc =+	reify ffc $ \(Proxy::Proxy c) ->+	testGroup (Text.unpack $ ffc_name ffc)+	 [ testProperty "verifyBallot" $ \(seed, (elec::Election c) :> votes) -> 		isRight $ runExcept $ 			(`evalStateT` mkStdGen seed) $ do-				-- ballotSecKey :: SecretKey q <- randomSecretKey+				-- ballotSecKey :: SecretKey c <- randomSecretKey 				ballot <- encryptBallot elec Nothing votes 				unless (verifyBallot elec ballot) $ 					lift $ throwE $ ErrorBallot_Wrong 	 ] -instance PrimeField p => Arbitrary (F p) where-	arbitrary = choose (zero, F (fieldCharac @p) - one)-instance SubGroup q => Arbitrary (G q) where+instance Reifies c FFC => Arbitrary (F c) where+	arbitrary = F <$> choose (zero, fromJust $ fieldCharac @c `minusNaturalMaybe` one)+instance Reifies c FFC => Arbitrary (G c) where 	arbitrary = do 		m <- arbitrary 		return (groupGen ^ m)-instance SubGroup q => Arbitrary (E q) where-	arbitrary = E <$> choose (zero, groupOrder @q - one)+instance Reifies c FFC => Arbitrary (E c) where+	arbitrary = E <$> choose (zero, fromJust $ groupOrder @c `minusNaturalMaybe` one) instance Arbitrary UUID where 	arbitrary = do 		seed <- arbitrary 		(`evalStateT` mkStdGen seed) $ 			randomUUID-instance SubGroup q => Arbitrary (Proof q) where+instance Reifies c FFC => Arbitrary (Proof c) where 	arbitrary = do 		proof_challenge <- arbitrary 		proof_response  <- arbitrary 		return Proof{..}-instance SubGroup q => Arbitrary (Question q) where+instance Arbitrary Question 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)+		question_mini <- choose (0, choices)+		question_maxi <- 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+		, let nChoices = fromIntegral $ List.length question_choices+		, question_mini <- shrinkIntegral $ min nChoices $ max zero $ question_mini quest+		, question_maxi <- shrinkIntegral $ min nChoices $ max question_mini $ question_maxi quest 		]-instance SubGroup q => Arbitrary (Election q) where+instance Reifies c FFC => Arbitrary (Election c) where 	arbitrary = do 		let election_name = "election" 		let election_description = "description"-		election_PublicKey <- arbitrary+		election_crypto <- arbitrary 		election_questions <- resize (fromIntegral maxArbitraryQuestions) $ listOf1 arbitrary 		election_uuid <- arbitrary-		let election_hash = Hash ""+		let election_hash = hashJSON JSON.Null 		return Election{..} 	shrink elec = 		[ elec{election_questions} 		| election_questions <- shrink $ election_questions elec 		]+instance Reifies c FFC => Arbitrary (ElectionCrypto c) where+	arbitrary = do+		let electionCrypto_FFC_params = reflect (Proxy::Proxy c)+		electionCrypto_FFC_PublicKey <- arbitrary+		return ElectionCrypto_FFC{..}  -- | 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+instance Arbitrary (Question :> [Bool]) where 	arbitrary = do 		quest@Question{..} <- arbitrary 		votes <- do@@ -104,7 +114,7 @@ 		[ q :> shrinkVotes q votes 		| q <- shrink quest 		]-instance SubGroup q => Arbitrary (Election q :> [[Bool]]) where+instance Reifies c FFC => Arbitrary (Election c :> [[Bool]]) where 	arbitrary = do 		elec@Election{..} <- arbitrary 		votes <- forM election_questions $ \Question{..} -> do@@ -136,7 +146,7 @@ -- | @('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 -> [Bool] -> [Bool] shrinkVotes Question{..} votes = 	(\(nTrue, b) -> nTrue <= nat question_maxi && b) 	 <$> List.zip (countTrue votes) votes

@@ -1,10 +1,11 @@ {-# OPTIONS -fno-warn-orphans #-}+{-# LANGUAGE UndecidableInstances #-} -- for Reifies instances module QuickCheck.Trustee where  import Test.Tasty.QuickCheck+import qualified Data.Text as Text  import Voting.Protocol-import Voting.Protocol.Trustee.Indispensable  import Utils import QuickCheck.Election ()@@ -13,23 +14,24 @@ quickcheck = 	testGroup "Trustee" 	 [ testGroup "verifyIndispensableTrusteePublicKey" $-		 [ testIndispensableTrusteePublicKey @WeakParams-		 , testIndispensableTrusteePublicKey @BeleniosParams+		 [ testIndispensableTrusteePublicKey weakFFC+		 , testIndispensableTrusteePublicKey beleniosFFC 		 ] 	 ] -testIndispensableTrusteePublicKey :: forall q. Params q => TestTree-testIndispensableTrusteePublicKey  =-	testGroup (paramsName @q)+testIndispensableTrusteePublicKey :: FFC -> TestTree+testIndispensableTrusteePublicKey ffc =+	reify ffc $ \(Proxy::Proxy c) ->+	testGroup (Text.unpack $ ffc_name ffc) 	 [ testProperty "Right" $ \seed -> 		isRight $ runExcept $ 			(`evalStateT` mkStdGen seed) $ do-				trusteeSecKey :: SecretKey q <- randomSecretKey+				trusteeSecKey :: SecretKey c <- randomSecretKey 				trusteePubKey <- proveIndispensableTrusteePublicKey trusteeSecKey 				lift $ verifyIndispensableTrusteePublicKey trusteePubKey 	 ] -instance SubGroup q => Arbitrary (TrusteePublicKey q) where+instance Reifies c FFC => Arbitrary (TrusteePublicKey c) where 	arbitrary = do 		trustee_PublicKey <- arbitrary 		trustee_SecretKeyProof <- arbitrary

@@ -56,6 +56,7 @@  import Voting.Protocol.Utils +debug :: Show a => String -> a -> a debug msg x = trace (msg<>": "<>show x) x  -- | @'nCk' n k@ returns the number of combinations