summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--benchmarks/Election.hs66
-rw-r--r--benchmarks/Utils.hs4
-rw-r--r--hjugement-protocol.cabal21
-rw-r--r--src/Voting/Protocol.hs4
-rw-r--r--src/Voting/Protocol/Arithmetic.hs335
-rw-r--r--src/Voting/Protocol/Credential.hs69
-rw-r--r--src/Voting/Protocol/Election.hs269
-rw-r--r--src/Voting/Protocol/FFC.hs415
-rw-r--r--src/Voting/Protocol/Tally.hs148
-rw-r--r--src/Voting/Protocol/Trustee/Indispensable.hs78
-rw-r--r--src/Voting/Protocol/Utils.hs31
-rw-r--r--stack.yaml2
-rw-r--r--tests/HUnit.hs4
-rw-r--r--tests/HUnit/Arithmetic.hs41
-rw-r--r--tests/HUnit/Credential.hs34
-rw-r--r--tests/HUnit/Election.hs53
-rw-r--r--tests/HUnit/FFC.hs46
-rw-r--r--tests/HUnit/Trustee/Indispensable.hs64
-rw-r--r--tests/QuickCheck/Election.hs68
-rw-r--r--tests/QuickCheck/Trustee.hs18
-rw-r--r--tests/Utils.hs1
21 files changed, 1004 insertions, 767 deletions
diff --git a/benchmarks/Election.hs b/benchmarks/Election.hs
index 8af3fde..c51b40d 100644
--- a/benchmarks/Election.hs
+++ b/benchmarks/Election.hs
@@ -8,15 +8,15 @@ import qualified Text.Printf as Printf
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 @@ makeElection nQuests nChoices = Election
}
} 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 @@ makeBallot elec =
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 @@ titleElection Election{..} =
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 @@ benchmarks =
| 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
]
]
diff --git a/benchmarks/Utils.hs b/benchmarks/Utils.hs
index 45eba67..6a65ab0 100644
--- a/benchmarks/Utils.hs
+++ b/benchmarks/Utils.hs
@@ -16,8 +16,6 @@ module Utils
, Text
, Word8
, Num, Fractional(..), Integral(..), Integer, fromIntegral
- , min
- , max
, Show(..)
, MonadTrans(..)
, ExceptT
@@ -50,7 +48,7 @@ import Data.String (String)
import Data.Text (Text)
import Data.Word (Word8)
import Debug.Trace
-import Prelude (Num(..), Fractional(..), Integral(..), Integer, undefined, fromIntegral, error)
+import Prelude (Num(..), Fractional(..), Integral(..), Integer, fromIntegral, error)
import System.IO (IO)
import System.Random (mkStdGen)
import Text.Show (Show(..))
diff --git a/hjugement-protocol.cabal b/hjugement-protocol.cabal
index cbf673f..8d70869 100644
--- a/hjugement-protocol.cabal
+++ b/hjugement-protocol.cabal
@@ -2,7 +2,7 @@ name: hjugement-protocol
-- 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 @@ description:
<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 @@ Library
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 @@ Library
NoMonomorphismRestriction
RecordWildCards
ScopedTypeVariables
+ StandaloneDeriving
TupleSections
TypeApplications
TypeFamilies
TypeOperators
- UndecidableInstances
ghc-options:
-Wall
-Wincomplete-uni-patterns
@@ -100,6 +97,9 @@ Library
-- -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 @@ Library
-- , 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 @@ Test-Suite hjugement-protocol-test
main-is: Main.hs
other-modules:
HUnit
- HUnit.Arithmetic
+ HUnit.FFC
HUnit.Credential
HUnit.Election
HUnit.Trustee
@@ -146,11 +146,11 @@ Test-Suite hjugement-protocol-test
NoMonomorphismRestriction
RecordWildCards
ScopedTypeVariables
+ StandaloneDeriving
TupleSections
TypeApplications
TypeFamilies
TypeOperators
- UndecidableInstances
ghc-options:
-Wall
-Wincomplete-uni-patterns
@@ -160,6 +160,7 @@ Test-Suite hjugement-protocol-test
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 @@ Benchmark hjugement-protocol-benchmark
NoMonomorphismRestriction
RecordWildCards
ScopedTypeVariables
+ StandaloneDeriving
TupleSections
TypeApplications
TypeFamilies
TypeOperators
- UndecidableInstances
ghc-options:
-Wall
-Wincomplete-uni-patterns
diff --git a/src/Voting/Protocol.hs b/src/Voting/Protocol.hs
index 6d973c5..e7dc8b8 100644
--- a/src/Voting/Protocol.hs
+++ b/src/Voting/Protocol.hs
@@ -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
diff --git a/src/Voting/Protocol/Arithmetic.hs b/src/Voting/Protocol/Arithmetic.hs
deleted file mode 100644
index a8ff6b4..0000000
--- a/src/Voting/Protocol/Arithmetic.hs
+++ /dev/null
@@ -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
diff --git a/src/Voting/Protocol/Credential.hs b/src/Voting/Protocol/Credential.hs
index 39ac87b..9ad56ce 100644
--- a/src/Voting/Protocol/Credential.hs
+++ b/src/Voting/Protocol/Credential.hs
@@ -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 as Text
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 @@ import Voting.Protocol.Arithmetic
-- 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 @@ randomCredential = do
-- | @'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 @@ readCredential s
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 @@ randomUUID = do
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 @@ credentialSecretKey (UUID uuid) (Credential cred) =
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 ^)
diff --git a/src/Voting/Protocol/Election.hs b/src/Voting/Protocol/Election.hs
index a9660d8..12f59b5 100644
--- a/src/Voting/Protocol/Election.hs
+++ b/src/Voting/Protocol/Election.hs
@@ -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 @@ import Voting.Protocol.Credential
--
-- 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 @@ type EncryptionNonce = E
-- 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 @@ encrypt pubKey clear = do
-- | 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 @@ data Proof q = Proof
-- 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 @@ data Proof q = Proof
-- 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 @@ type Challenge = E
-- 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 @@ type Oracle list q = list (Commitment q) -> Challenge q
-- 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 @@ prove sec commitBases oracle = do
--
-- 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 @@ type Commitment = G
-- | @('commit' proof base basePowSec)@ returns a 'Commitment'
-- from the given 'Proof' with the knowledge of the verifier.
-commit :: SubGroup q => Proof q -> G q -> G q -> Commitment q
+commit :: 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 @@ commit Proof{..} base basePowSec =
-- 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 @@ type Opinion = E
-- | 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 @@ newtype DisjProof q = DisjProof [Proof q]
--
-- 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 @@ proveEncryption elecPubKey voterZKP (prevDisjs,nextDisjs) (encNonce,enc) = do
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 @@ verifyEncryption elecPubKey voterZKP disjs (enc, DisjProof proofs) =
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 @@ encryptionStatement (ZKP voterZKP) Encryption{..} =
-- 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 @@ data ErrorVerifyEncryption
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 @@ encryptAnswer elecPubKey zkp Question{..} opinionByChoice
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 @@ encryptAnswer elecPubKey zkp Question{..} opinionByChoice
, 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 @@ data ErrorAnswer
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 @@ encryptBallot Election{..} ballotSecKeyMay opinionsByQuest
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 @@ encryptBallot Election{..} ballotSecKeyMay opinionsByQuest
, 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 @@ verifyBallot Election{..} Ballot{..} =
(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 @@ verifyBallot Election{..} Ballot{..} =
-- 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<>"|"
diff --git a/src/Voting/Protocol/FFC.hs b/src/Voting/Protocol/FFC.hs
new file mode 100644
index 0000000..5917ffa
--- /dev/null
+++ b/src/Voting/Protocol/FFC.hs
@@ -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
diff --git a/src/Voting/Protocol/Tally.hs b/src/Voting/Protocol/Tally.hs
index 5c709d2..46bfd86 100644
--- a/src/Voting/Protocol/Tally.hs
+++ b/src/Voting/Protocol/Tally.hs
@@ -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.List as List
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 @@ type DecryptionFactor = G
-- @('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 @@ data ErrorDecryptionShare
-- (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)
diff --git a/src/Voting/Protocol/Trustee/Indispensable.hs b/src/Voting/Protocol/Trustee/Indispensable.hs
index bfa475c..fbd035b 100644
--- a/src/Voting/Protocol/Trustee/Indispensable.hs
+++ b/src/Voting/Protocol/Trustee/Indispensable.hs
@@ -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 @@ data TrusteePublicKey q = TrusteePublicKey
-- 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 @@ data ErrorTrusteePublicKey
-- 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 @@ proveIndispensableTrusteePublicKey trustSecKey = do
-- 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
diff --git a/src/Voting/Protocol/Utils.hs b/src/Voting/Protocol/Utils.hs
index ea1fbb9..1cc30f0 100644
--- a/src/Voting/Protocol/Utils.hs
+++ b/src/Voting/Protocol/Utils.hs
@@ -10,6 +10,12 @@ import Data.Maybe (Maybe(..), maybe)
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 @@ isoZipWith3 f as bs cs
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
diff --git a/stack.yaml b/stack.yaml
index f5e1ae0..4a83955 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -1,4 +1,4 @@
-resolver: lts-12.26
+resolver: lts-13.19
packages:
- '.'
- location: '../hjugement'
diff --git a/tests/HUnit.hs b/tests/HUnit.hs
index 76f2a48..bd6c3f0 100644
--- a/tests/HUnit.hs
+++ b/tests/HUnit.hs
@@ -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 @@ import qualified HUnit.Trustee
hunits :: TestTree
hunits =
testGroup "HUnit"
- [ HUnit.Arithmetic.hunit
+ [ HUnit.FFC.hunit
, HUnit.Credential.hunit
, HUnit.Election.hunit
, HUnit.Trustee.hunit
diff --git a/tests/HUnit/Arithmetic.hs b/tests/HUnit/Arithmetic.hs
deleted file mode 100644
index 6a4a304..0000000
--- a/tests/HUnit/Arithmetic.hs
+++ /dev/null
@@ -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
- ]
- ]
- ]
diff --git a/tests/HUnit/Credential.hs b/tests/HUnit/Credential.hs
index 3e358f8..10d8a92 100644
--- a/tests/HUnit/Credential.hs
+++ b/tests/HUnit/Credential.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE OverloadedStrings #-}
module HUnit.Credential where
@@ -25,29 +24,30 @@ hunit = testGroup "Credential"
, 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
diff --git a/tests/HUnit/Election.hs b/tests/HUnit/Election.hs
index 465f910..5e193eb 100644
--- a/tests/HUnit/Election.hs
+++ b/tests/HUnit/Election.hs
@@ -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 :: TestTree
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 @@ testsEncryptBallot =
]
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
diff --git a/tests/HUnit/FFC.hs b/tests/HUnit/FFC.hs
new file mode 100644
index 0000000..07cd2e4
--- /dev/null
+++ b/tests/HUnit/FFC.hs
@@ -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
+ ]
+ ]
+ ]
diff --git a/tests/HUnit/Trustee/Indispensable.hs b/tests/HUnit/Trustee/Indispensable.hs
index 3de29c3..b035d5d 100644
--- a/tests/HUnit/Trustee/Indispensable.hs
+++ b/tests/HUnit/Trustee/Indispensable.hs
@@ -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 @@ import Utils
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 @@ testVerifyTally seed nTrustees nQuests nChoices =
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 @@ dummyTallyResult nQuests nChoices =
]
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 $
diff --git a/tests/QuickCheck/Election.hs b/tests/QuickCheck/Election.hs
index 9ea92d8..5bd09df 100644
--- a/tests/QuickCheck/Election.hs
+++ b/tests/QuickCheck/Election.hs
@@ -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 @@ import Utils
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 @@ instance SubGroup q => Arbitrary (Question q :> [Bool]) where
[ 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 @@ boolsOfCombin nBits nTrue rank
-- | @('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
diff --git a/tests/QuickCheck/Trustee.hs b/tests/QuickCheck/Trustee.hs
index 82cfe14..586295c 100644
--- a/tests/QuickCheck/Trustee.hs
+++ b/tests/QuickCheck/Trustee.hs
@@ -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 :: TestTree
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
diff --git a/tests/Utils.hs b/tests/Utils.hs
index dc7bc66..b034b6d 100644
--- a/tests/Utils.hs
+++ b/tests/Utils.hs
@@ -56,6 +56,7 @@ import Text.Show (Show(..))
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