hjugement-protocol/src/Voting/Protocol/Election.hs

   1 {-# LANGUAGE DeriveAnyClass #-}
   2 {-# LANGUAGE DeriveGeneric #-}
   3 {-# LANGUAGE OverloadedStrings #-}
   4 module Voting.Protocol.Election where
   5
   6 import Control.DeepSeq (NFData)
   7 import Control.Monad (Monad(..), join, mapM, replicateM, unless, zipWithM)
   8 import Control.Monad.Trans.Class (MonadTrans(..))
   9 import Control.Monad.Trans.Except (Except, ExceptT, runExcept, throwE, withExceptT)
  10 import Data.Bool
  11 import Data.Either (either)
  12 import Data.Eq (Eq(..))
  13 import Data.Foldable (Foldable, foldMap, and)
  14 import Data.Function (($), id, const)
  15 import Data.Functor (Functor, (<$>))
  16 import Data.Functor.Identity (Identity(..))
  17 import Data.Maybe (Maybe(..), fromMaybe, maybe)
  18 import Data.Ord (Ord(..))
  19 import Data.Semigroup (Semigroup(..))
  20 import Data.Text (Text)
  21 import Data.Traversable (Traversable(..))
  22 import Data.Tuple (fst, snd, uncurry)
  23 import GHC.Natural (minusNaturalMaybe)
  24 import GHC.Generics (Generic)
  25 import Numeric.Natural (Natural)
  26 import Prelude (fromIntegral)
  27 import Text.Show (Show(..))
  28 import qualified Control.Monad.Trans.State.Strict as S
  29 import qualified Data.ByteString as BS
  30 import qualified Data.List as List
  31 import qualified Data.Map.Strict as Map
  32
  33 import Voting.Protocol.Utils
  34 import Voting.Protocol.Arithmetic
  35 import Voting.Protocol.Credential
  36
  37 -- * Type 'Encryption'
  38 -- | ElGamal-like encryption.
  39 -- Its security relies on the /Discrete Logarithm problem/.
  40 --
  41 -- Because ('groupGen' '^'encNonce '^'secKey '==' 'groupGen' '^'secKey '^'encNonce),
  42 -- knowing @secKey@, one can divide 'encryption_vault' by @('encryption_nonce' '^'secKey)@
  43 -- to decipher @('groupGen' '^'clear)@, then the @clear@ text must be small to be decryptable,
  44 -- because it is encrypted as a power of 'groupGen' (hence the "-like" in "ElGamal-like")
  45 -- to enable the additive homomorphism.
  46 --
  47 -- NOTE: Since @('encryption_vault' '*' 'encryption_nonce' '==' 'encryption_nonce' '^' (secKey '+' clear))@,
  48 -- then: @(logBase 'encryption_nonce' ('encryption_vault' '*' 'encryption_nonce') '==' secKey '+' clear)@.
  49 data Encryption q = Encryption
  50  { encryption_nonce :: G q
  51    -- ^ Public part of the randomness 'encNonce' used to 'encrypt' the 'clear' text,
  52    -- equal to @('groupGen' '^'encNonce)@
  53  , encryption_vault :: G q
  54    -- ^ Encrypted 'clear' text,
  55    -- equal to @('pubKey' '^'encNone '*' 'groupGen' '^'clear)@
  56  } deriving (Eq,Show,Generic,NFData)
  57
  58 -- | Additive homomorphism.
  59 -- Using the fact that: @'groupGen' '^'x '*' 'groupGen' '^'y '==' 'groupGen' '^'(x'+'y)@.
  60 instance SubGroup q => Additive (Encryption q) where
  61         zero = Encryption one one
  62         x+y = Encryption
  63          (encryption_nonce x * encryption_nonce y)
  64          (encryption_vault x * encryption_vault y)
  65
  66 -- *** Type 'EncryptionNonce'
  67 type EncryptionNonce = E
  68
  69 -- | @('encrypt' pubKey clear)@ returns an ElGamal-like 'Encryption'.
  70 --
  71 -- WARNING: the secret encryption nonce (@encNonce@)
  72 -- is returned alongside the 'Encryption'
  73 -- in order to 'prove' the validity of the encrypted 'clear' text in 'proveEncryption',
  74 -- but this secret @encNonce@ MUST be forgotten after that,
  75 -- as it may be used to decipher the 'Encryption'
  76 -- without the 'SecretKey' associated with 'pubKey'.
  77 encrypt ::
  78  Monad m => RandomGen r => SubGroup q =>
  79  PublicKey q -> E q ->
  80  S.StateT r m (EncryptionNonce q, Encryption q)
  81 encrypt pubKey clear = do
  82         encNonce <- random
  83         -- NOTE: preserve the 'encNonce' for 'prove' in 'proveEncryption'.
  84         return $ (encNonce,)
  85                 Encryption
  86                  { encryption_nonce = groupGen^encNonce
  87                  , encryption_vault = pubKey  ^encNonce * groupGen^clear
  88                  }
  89
  90 -- * Type 'Proof'
  91 -- | Non-Interactive Zero-Knowledge 'Proof'
  92 -- of knowledge of a discrete logarithm:
  93 -- @(secret == logBase base (base^secret))@.
  94 data Proof q = Proof
  95  { proof_challenge :: Challenge q
  96    -- ^ 'Challenge' sent by the verifier to the prover
  97    -- to ensure that the prover really has knowledge
  98    -- of the secret and is not replaying.
  99    -- Actually, 'proof_challenge' is not sent to the prover,
 100    -- but derived from the prover's 'Commitment's and statements
 101    -- with a collision resistant 'hash'.
 102    -- Hence the prover cannot chose the 'proof_challenge' to his/her liking.
 103  , proof_response :: E q
 104    -- ^ A discrete logarithm sent by the prover to the verifier,
 105    -- as a response to 'proof_challenge'.
 106    --
 107    -- If the verifier observes that @('proof_challenge' '==' 'hash' statement [commitment])@, where:
 108    --
 109    -- * @statement@ is a serialization of a tag, @base@ and @basePowSec@,
 110    -- * @commitment '==' 'commit' proof base basePowSec '=='
 111    --   base '^' 'proof_response' '*' basePowSec '^' 'proof_challenge'@,
 112    -- * and @basePowSec '==' base'^'sec@,
 113    --
 114    -- then, with overwhelming probability (due to the 'hash' function),
 115    -- the prover was not able to choose 'proof_challenge'
 116    -- yet was able to compute a 'proof_response' such that
 117    -- (@commitment '==' base '^' 'proof_response' '*' basePowSec '^' 'proof_challenge'@),
 118    -- that is to say: @('proof_response' '==' logBase base 'commitment' '-' sec '*' 'proof_challenge')@,
 119    -- therefore the prover knows 'sec'.
 120    --
 121    -- The prover choses 'commitment' to be a random power of @base@,
 122    -- to ensure that each 'prove' does not reveal any information
 123    -- about its secret.
 124  } deriving (Eq,Show,Generic,NFData)
 125
 126 -- ** Type 'ZKP'
 127 -- | Zero-knowledge proof.
 128 --
 129 -- A protocol is /zero-knowledge/ if the verifier
 130 -- learns nothing from the protocol except that the prover
 131 -- knows the secret.
 132 --
 133 -- DOC: Mihir Bellare and Phillip Rogaway. Random oracles are practical:
 134 --      A paradigm for designing efficient protocols. In ACM-CCS’93, 1993.
 135 newtype ZKP = ZKP BS.ByteString
 136
 137 -- ** Type 'Challenge'
 138 type Challenge = E
 139
 140 -- ** Type 'Oracle'
 141 -- An 'Oracle' returns the 'Challenge' of the 'Commitment's
 142 -- by 'hash'ing them (eventually with other 'Commitment's).
 143 --
 144 -- Used in 'prove' it enables a Fiat-Shamir transformation
 145 -- of an /interactive zero-knowledge/ (IZK) proof
 146 -- into a /non-interactive zero-knowledge/ (NIZK) proof.
 147 -- That is to say that the verifier does not have
 148 -- to send a 'Challenge' to the prover.
 149 -- Indeed, the prover now handles the 'Challenge'
 150 -- which becomes a (collision resistant) 'hash'
 151 -- of the prover's commitments (and statements to be a stronger proof).
 152 type Oracle list q = list (Commitment q) -> Challenge q
 153
 154 -- | @('prove' sec commitBases oracle)@
 155 -- returns a 'Proof' that @sec@ is known
 156 -- (by proving the knowledge of its discrete logarithm).
 157 --
 158 -- The 'Oracle' is given 'Commitment's equal to the 'commitBases'
 159 -- raised to the power of the secret nonce of the 'Proof',
 160 -- as those are the 'Commitment's that the verifier will obtain
 161 -- when composing the 'proof_challenge' and 'proof_response' together
 162 -- (with 'commit').
 163 --
 164 -- WARNING: for 'prove' to be a so-called /strong Fiat-Shamir transformation/ (not a weak):
 165 -- the statement must be included in the 'hash' (along with the commitments).
 166 --
 167 -- NOTE: a 'random' @nonce@ is used to ensure each 'prove'
 168 -- does not reveal any information regarding the secret @sec@,
 169 -- because two 'Proof's using the same 'Commitment'
 170 -- can be used to deduce @sec@ (using the special-soundness).
 171 prove ::
 172  Monad m => RandomGen r => SubGroup q => Functor list =>
 173  E q -> list (G q) -> Oracle list q -> S.StateT r m (Proof q)
 174 prove sec commitBases oracle = do
 175         nonce <- random
 176         let commitments = (^ nonce) <$> commitBases
 177         let proof_challenge = oracle commitments
 178         return Proof
 179          { proof_challenge
 180          , proof_response = nonce - sec*proof_challenge
 181          }
 182
 183 -- | @('fakeProof')@ returns a 'Proof'
 184 -- whose 'proof_challenge' and 'proof_response' are uniformly chosen at random,
 185 -- instead of @('proof_challenge' '==' 'hash' statement commitments)@
 186 -- and @('proof_response' '==' nonce '+' sec '*' 'proof_challenge')@
 187 -- as a 'Proof' returned by 'prove'.
 188 --
 189 -- Used in 'proveEncryption' to fill the returned 'DisjProof'
 190 -- with fake 'Proof's for all 'Disjunction's but the encrypted one.
 191 fakeProof :: Monad m => RandomGen r => SubGroup q => S.StateT r m (Proof q)
 192 fakeProof = do
 193         proof_challenge <- random
 194         proof_response  <- random
 195         return Proof{..}
 196
 197 -- ** Type 'Commitment'
 198 -- | A commitment from the prover to the verifier.
 199 -- It's a power of 'groupGen' chosen randomly by the prover
 200 -- when making a 'Proof' with 'prove'.
 201 type Commitment = G
 202
 203 -- | @('commit' proof base basePowSec)@ returns a 'Commitment'
 204 -- from the given 'Proof' with the knowledge of the verifier.
 205 commit :: SubGroup q => Proof q -> G q -> G q -> Commitment q
 206 commit Proof{..} base basePowSec =
 207         base^proof_response *
 208         basePowSec^proof_challenge
 209   -- NOTE: Contrary to some textbook presentations,
 210   -- @('*')@ is used instead of @('/')@ to avoid the performance cost
 211   -- of a modular exponentiation @('^' ('groupOrder' '-' 'one'))@,
 212   -- this is compensated by using @('-')@ instead of @('+')@ in 'prove'.
 213 {-# INLINE commit #-}
 214
 215 -- * Type 'Disjunction'
 216 -- | A 'Disjunction' is an 'inv'ersed @('groupGen' '^'opinion)@
 217 -- it's used in 'proveEncryption' to generate a 'Proof'
 218 -- that an 'encryption_vault' contains a given @('groupGen' '^'opinion)@,
 219 type Disjunction = G
 220
 221 booleanDisjunctions :: SubGroup q => [Disjunction q]
 222 booleanDisjunctions = List.take 2 groupGenInverses
 223
 224 intervalDisjunctions :: SubGroup q => Opinion q -> Opinion q -> [Disjunction q]
 225 intervalDisjunctions mini maxi =
 226         List.genericTake (fromMaybe 0 $ (nat maxi + 1)`minusNaturalMaybe`nat mini) $
 227         List.genericDrop (nat mini) $
 228         groupGenInverses
 229
 230 -- ** Type 'Opinion'
 231 -- | Index of a 'Disjunction' within a list of them.
 232 -- It is encrypted as an 'E'xponent by 'encrypt'.
 233 type Opinion = E
 234
 235 -- ** Type 'DisjProof'
 236 -- | A list of 'Proof's to prove that the 'Opinion' within an 'Encryption'
 237 -- is indexing a 'Disjunction' within a list of them,
 238 -- without revealing which 'Opinion' it is.
 239 newtype DisjProof q = DisjProof [Proof q]
 240  deriving (Eq,Show,Generic,NFData)
 241
 242 -- | @('proveEncryption' elecPubKey voterZKP (prevDisjs,nextDisjs) (encNonce,enc))@
 243 -- returns a 'DisjProof' that 'enc' 'encrypt's
 244 -- the 'Disjunction' 'd' between 'prevDisjs' and 'nextDisjs'.
 245 --
 246 -- The prover proves that it knows an 'encNonce', such that:
 247 -- @(enc '==' Encryption{encryption_nonce='groupGen' '^'encNonce, encryption_vault=elecPubKey'^'encNonce '*' groupGen'^'d})@
 248 --
 249 -- A /NIZK Disjunctive Chaum Pedersen Logarithm Equality/ is used.
 250 --
 251 -- DOC: Pierrick Gaudry. <https://hal.inria.fr/hal-01576379 Some ZK security proofs for Belenios>, 2017.
 252 proveEncryption ::
 253  Monad m => RandomGen r => SubGroup q =>
 254  PublicKey q -> ZKP ->
 255  ([Disjunction q],[Disjunction q]) ->
 256  (EncryptionNonce q, Encryption q) ->
 257  S.StateT r m (DisjProof q)
 258 proveEncryption elecPubKey voterZKP (prevDisjs,nextDisjs) (encNonce,enc) = do
 259         -- Fake proofs for all 'Disjunction's except the genuine one.
 260         prevFakeProofs <- replicateM (List.length prevDisjs) fakeProof
 261         nextFakeProofs <- replicateM (List.length nextDisjs) fakeProof
 262         let fakeChallengeSum =
 263                 sum (proof_challenge <$> prevFakeProofs) +
 264                 sum (proof_challenge <$> nextFakeProofs)
 265         let statement = encryptionStatement voterZKP enc
 266         genuineProof <- prove encNonce [groupGen, elecPubKey] $ \genuineCommitments ->
 267                 let validCommitments = List.zipWith (encryptionCommitments elecPubKey enc) in
 268                 let prevCommitments = validCommitments prevDisjs prevFakeProofs in
 269                 let nextCommitments = validCommitments nextDisjs nextFakeProofs in
 270                 let commitments = join prevCommitments <> genuineCommitments <> join nextCommitments in
 271                 let challenge = hash statement commitments in
 272                 let genuineChallenge = challenge - fakeChallengeSum in
 273                 genuineChallenge
 274                 -- NOTE: here by construction (genuineChallenge == challenge - fakeChallengeSum)
 275                 -- thus (sum (proof_challenge <$> proofs) == challenge)
 276                 -- as checked in 'verifyEncryption'.
 277         let proofs = prevFakeProofs <> (genuineProof : nextFakeProofs)
 278         return (DisjProof proofs)
 279
 280 verifyEncryption ::
 281  Monad m => SubGroup q =>
 282  PublicKey q -> ZKP ->
 283  [Disjunction q] -> (Encryption q, DisjProof q) ->
 284  ExceptT ErrorVerifyEncryption m Bool
 285 verifyEncryption elecPubKey voterZKP disjs (enc, DisjProof proofs) =
 286         case isoZipWith (encryptionCommitments elecPubKey enc) disjs proofs of
 287          Nothing ->
 288                 throwE $ ErrorVerifyEncryption_InvalidProofLength
 289                  (fromIntegral $ List.length proofs)
 290                  (fromIntegral $ List.length disjs)
 291          Just commitments ->
 292                 return $ challengeSum ==
 293                         hash (encryptionStatement voterZKP enc) (join commitments)
 294         where
 295         challengeSum = sum (proof_challenge <$> proofs)
 296
 297 -- ** Hashing
 298 encryptionStatement :: SubGroup q => ZKP -> Encryption q -> BS.ByteString
 299 encryptionStatement (ZKP voterZKP) Encryption{..} =
 300         "prove|"<>voterZKP<>"|"
 301          <> bytesNat encryption_nonce<>","
 302          <> bytesNat encryption_vault<>"|"
 303
 304 -- | @('encryptionCommitments' elecPubKey enc disj proof)@
 305 -- returns the 'Commitment's with only the knowledge of the verifier.
 306 --
 307 -- For the prover the 'Proof' comes from @fakeProof@,
 308 -- and for the verifier the 'Proof' comes from the prover.
 309 encryptionCommitments ::
 310  SubGroup q =>
 311  PublicKey q -> Encryption q ->
 312  Disjunction q -> Proof q -> [G q]
 313 encryptionCommitments elecPubKey Encryption{..} disj proof =
 314         [ commit proof groupGen encryption_nonce
 315           -- == groupGen ^ nonce if 'Proof' comes from 'prove'.
 316           -- base==groupGen, basePowSec==groupGen^encNonce.
 317         , commit proof elecPubKey (encryption_vault*disj)
 318           -- == elecPubKey ^ nonce if 'Proof' comes from 'prove'
 319           -- and 'encryption_vault' encrypts (- logBase groupGen disj).
 320           -- base==elecPubKey, basePowSec==elecPubKey^encNonce.
 321         ]
 322
 323 -- ** Type 'ErrorVerifyEncryption'
 324 -- | Error raised by 'verifyEncryption'.
 325 data ErrorVerifyEncryption
 326  =   ErrorVerifyEncryption_InvalidProofLength Natural Natural
 327      -- ^ When the number of proofs is different than
 328      -- the number of 'Disjunction's.
 329  deriving (Eq,Show)
 330
 331 -- * Type 'Question'
 332 data Question q = Question
 333  { question_text    :: Text
 334  , question_choices :: [Text]
 335  , question_mini    :: Opinion q
 336  , question_maxi    :: Opinion q
 337  -- , question_blank :: Maybe Bool
 338  } deriving (Eq,Show,Generic,NFData)
 339
 340 -- * Type 'Answer'
 341 data Answer q = Answer
 342  { answer_opinions :: [(Encryption q, DisjProof q)]
 343    -- ^ Encrypted 'Opinion' for each 'question_choices'
 344    -- with a 'DisjProof' that they belong to [0,1].
 345  , answer_sumProof :: DisjProof q
 346    -- ^ Proofs that the sum of the 'Opinon's encrypted in 'answer_opinions'
 347    -- is an element of @[mini..maxi]@.
 348  -- , answer_blankProof ::
 349  } deriving (Eq,Show,Generic,NFData)
 350
 351 -- | @('encryptAnswer' elecPubKey zkp quest opinions)@
 352 -- returns an 'Answer' validable by 'verifyAnswer',
 353 -- unless an 'ErrorAnswer' is returned.
 354 encryptAnswer ::
 355  Monad m => RandomGen r => SubGroup q =>
 356  PublicKey q -> ZKP ->
 357  Question q -> [Bool] ->
 358  S.StateT r (ExceptT ErrorAnswer m) (Answer q)
 359 encryptAnswer elecPubKey zkp Question{..} opinionByChoice
 360  | not (question_mini <= opinionsSum && opinionsSum <= question_maxi) =
 361         lift $ throwE $
 362                 ErrorAnswer_WrongSumOfOpinions
 363                  (nat opinionsSum)
 364                  (nat question_mini)
 365                  (nat question_maxi)
 366  | List.length opinions /= List.length question_choices =
 367         lift $ throwE $
 368                 ErrorAnswer_WrongNumberOfOpinions
 369                  (fromIntegral $ List.length opinions)
 370                  (fromIntegral $ List.length question_choices)
 371  | otherwise = do
 372         encryptions <- encrypt elecPubKey `mapM` opinions
 373         individualProofs <- zipWithM
 374          (\opinion -> proveEncryption elecPubKey zkp $
 375                 if opinion
 376                 then ([booleanDisjunctions List.!!0],[])
 377                 else ([],[booleanDisjunctions List.!!1]))
 378          opinionByChoice encryptions
 379         sumProof <- proveEncryption elecPubKey zkp
 380          (List.tail <$> List.genericSplitAt
 381                  (nat (opinionsSum - question_mini))
 382                  (intervalDisjunctions question_mini question_maxi))
 383          ( sum (fst <$> encryptions) -- NOTE: sum the 'encNonce's
 384          , sum (snd <$> encryptions) -- NOTE: sum the 'Encryption's
 385          )
 386         return $ Answer
 387          { answer_opinions = List.zip
 388                  (snd <$> encryptions) -- NOTE: drop encNonce
 389                  individualProofs
 390          , answer_sumProof = sumProof
 391          }
 392  where
 393         opinionsSum = sum opinions
 394         opinions = (\o -> if o then one else zero) <$> opinionByChoice
 395
 396 verifyAnswer ::
 397  SubGroup q =>
 398  PublicKey q -> ZKP ->
 399  Question q -> Answer q -> Bool
 400 verifyAnswer elecPubKey zkp Question{..} Answer{..}
 401  | List.length question_choices /= List.length answer_opinions = False
 402  | otherwise = either (const False) id $ runExcept $ do
 403         validOpinions <-
 404                 verifyEncryption elecPubKey zkp booleanDisjunctions
 405                  `traverse` answer_opinions
 406         validSum <- verifyEncryption elecPubKey zkp
 407          (intervalDisjunctions question_mini question_maxi)
 408          ( sum (fst <$> answer_opinions)
 409          , answer_sumProof )
 410         return (and validOpinions && validSum)
 411
 412 -- ** Type 'ErrorAnswer'
 413 -- | Error raised by 'encryptAnswer'.
 414 data ErrorAnswer
 415  =   ErrorAnswer_WrongNumberOfOpinions Natural Natural
 416      -- ^ When the number of opinions is different than
 417      -- the number of choices ('question_choices').
 418  |   ErrorAnswer_WrongSumOfOpinions Natural Natural Natural
 419      -- ^ When the sum of opinions is not within the bounds
 420      -- of 'question_mini' and 'question_maxi'.
 421  deriving (Eq,Show,Generic,NFData)
 422
 423 -- * Type 'Election'
 424 data Election q = Election
 425  { election_name        :: Text
 426  , election_description :: Text
 427  , election_publicKey   :: PublicKey q
 428  , election_questions   :: [Question q]
 429  , election_uuid        :: UUID
 430  , election_hash        :: Hash -- TODO: serialize to JSON to calculate this
 431  } deriving (Eq,Show,Generic,NFData)
 432
 433 -- ** Type 'Hash'
 434 newtype Hash = Hash Text
 435  deriving (Eq,Ord,Show,Generic,NFData)
 436
 437 -- * Type 'Ballot'
 438 data Ballot q = Ballot
 439  { ballot_answers       :: [Answer q]
 440  , ballot_signature     :: Maybe (Signature q)
 441  , ballot_election_uuid :: UUID
 442  , ballot_election_hash :: Hash
 443  } deriving (Generic,NFData)
 444
 445 -- | @('encryptBallot' elec ('Just' ballotSecKey) opinionsByQuest)@
 446 -- returns a 'Ballot' signed by 'secKey' (the voter's secret key)
 447 -- where 'opinionsByQuest' is a list of 'Opinion's
 448 -- on each 'question_choices' of each 'election_questions'.
 449 encryptBallot ::
 450  Monad m => RandomGen r => SubGroup q =>
 451  Election q -> Maybe (SecretKey q) -> [[Bool]] ->
 452  S.StateT r (ExceptT ErrorBallot m) (Ballot q)
 453 encryptBallot Election{..} ballotSecKeyMay opinionsByQuest
 454  | List.length election_questions /= List.length opinionsByQuest =
 455         lift $ throwE $
 456                 ErrorBallot_WrongNumberOfAnswers
 457                  (fromIntegral $ List.length opinionsByQuest)
 458                  (fromIntegral $ List.length election_questions)
 459  | otherwise = do
 460         let (voterKeys, voterZKP) =
 461                 case ballotSecKeyMay of
 462                  Nothing -> (Nothing, ZKP "")
 463                  Just ballotSecKey ->
 464                         ( Just (ballotSecKey, ballotPubKey)
 465                         , ZKP (bytesNat ballotPubKey) )
 466                         where ballotPubKey = publicKey ballotSecKey
 467         ballot_answers <-
 468                 S.mapStateT (withExceptT ErrorBallot_Answer) $
 469                         zipWithM (encryptAnswer election_publicKey voterZKP)
 470                          election_questions opinionsByQuest
 471         ballot_signature <- case voterKeys of
 472          Nothing -> return Nothing
 473          Just (ballotSecKey, signature_publicKey) -> do
 474                 signature_proof <-
 475                         prove ballotSecKey (Identity groupGen) $
 476                          \(Identity commitment) ->
 477                                 hash
 478                                  -- NOTE: the order is unusual, the commitments are first
 479                                  -- then comes the statement. Best guess is that
 480                                  -- this is easier to code due to their respective types.
 481                                  (signatureCommitments voterZKP commitment)
 482                                  (signatureStatement ballot_answers)
 483                 return $ Just Signature{..}
 484         return Ballot
 485          { ballot_answers
 486          , ballot_election_hash = election_hash
 487          , ballot_election_uuid = election_uuid
 488          , ballot_signature
 489          }
 490
 491 verifyBallot :: SubGroup q => Election q -> Ballot q -> Bool
 492 verifyBallot Election{..} Ballot{..} =
 493         ballot_election_uuid == election_uuid &&
 494         ballot_election_hash == election_hash &&
 495         List.length election_questions == List.length ballot_answers &&
 496         let (isValidSign, zkpSign) =
 497                 case ballot_signature of
 498                  Nothing -> (True, ZKP "")
 499                  Just Signature{..} ->
 500                         let zkp = ZKP (bytesNat signature_publicKey) in
 501                         (, zkp) $
 502                                 proof_challenge signature_proof == hash
 503                                  (signatureCommitments zkp (commit signature_proof groupGen signature_publicKey))
 504                                  (signatureStatement ballot_answers)
 505         in
 506         and $ isValidSign :
 507                 List.zipWith (verifyAnswer election_publicKey zkpSign)
 508                  election_questions ballot_answers
 509
 510 -- ** Type 'Signature'
 511 -- | Schnorr-like signature.
 512 --
 513 -- Used by each voter to sign his/her encrypted 'Ballot'
 514 -- using his/her 'Credential',
 515 -- in order to avoid ballot stuffing.
 516 data Signature q = Signature
 517  { signature_publicKey :: PublicKey q
 518    -- ^ Verification key.
 519  , signature_proof     :: Proof q
 520  } deriving (Generic,NFData)
 521
 522 -- *** Hashing
 523
 524 -- | @('signatureStatement' answers)@
 525 -- returns the encrypted material to be signed:
 526 -- all the 'encryption_nonce's and 'encryption_vault's of the given @answers@.
 527 signatureStatement :: Foldable f => SubGroup q => f (Answer q) -> [G q]
 528 signatureStatement =
 529         foldMap $ \Answer{..} ->
 530                 (`foldMap` answer_opinions) $ \(Encryption{..}, _proof) ->
 531                         [encryption_nonce, encryption_vault]
 532
 533 -- | @('signatureCommitments' voterZKP commitment)@
 534 signatureCommitments :: SubGroup q => ZKP -> Commitment q -> BS.ByteString
 535 signatureCommitments (ZKP voterZKP) commitment =
 536         "sig|"<>voterZKP<>"|" -- NOTE: this is actually part of the statement
 537          <> bytesNat commitment<>"|"
 538
 539 -- ** Type 'ErrorBallot'
 540 -- | Error raised by 'encryptBallot'.
 541 data ErrorBallot
 542  =   ErrorBallot_WrongNumberOfAnswers Natural Natural
 543      -- ^ When the number of answers
 544      -- is different than the number of questions.
 545  |   ErrorBallot_Answer ErrorAnswer
 546      -- ^ When 'encryptAnswer' raised an 'ErrorAnswer'.
 547  deriving (Eq,Show,Generic,NFData)
 548
 549 -- * Type 'DecryptionShare'
 550 -- | A decryption share. It is computed by a trustee from his/her
 551 -- private key share and the encrypted tally,
 552 -- and contains a cryptographic 'Proof' that it didn't cheat.
 553 data DecryptionShare q = DecryptionShare
 554  { decryptionShare_factors :: [[DecryptionFactor q]]
 555    -- ^ 'DecryptionFactor' by voter, by 'Question'.
 556  , decryptionShare_proofs  :: [[Proof q]]
 557    -- ^ 'Proof's that 'decryptionShare_factors' were correctly computed.
 558  } deriving (Eq,Show,Generic,NFData)
 559
 560 -- BELENIOS: compute_factor
 561 -- @('proveDecryptionShare' trusteeSecKey encByQuestByBallot)@
 562 proveDecryptionShare ::
 563  Monad m => SubGroup q => RandomGen r =>
 564  SecretKey q -> [[Encryption q]] -> S.StateT r m (DecryptionShare q)
 565 proveDecryptionShare secKey encs = do
 566         res <- (proveDecryptionFactor secKey `mapM`) `mapM` encs
 567         return $ uncurry DecryptionShare $ List.unzip (List.unzip <$> res)
 568
 569 -- BELENIOS: eg_factor
 570 proveDecryptionFactor ::
 571  Monad m => SubGroup q => RandomGen r =>
 572  SecretKey q -> Encryption q -> S.StateT r m (DecryptionFactor q, Proof q)
 573 proveDecryptionFactor secKey Encryption{..} = do
 574         proof <- prove secKey [groupGen, encryption_nonce] (hash zkp)
 575         return (encryption_nonce^secKey, proof)
 576         where zkp = decryptionShareStatement (publicKey secKey)
 577
 578 decryptionShareStatement :: SubGroup q => PublicKey q -> BS.ByteString
 579 decryptionShareStatement pubKey =
 580         "decrypt|"<>bytesNat pubKey<>"|"
 581
 582 -- ** Type 'DecryptionFactor'
 583 type DecryptionFactor = G
 584
 585 -- ** Type 'ErrorDecryptionShare'
 586 data ErrorDecryptionShare
 587  =   ErrorDecryptionShare_Invalid
 588      -- ^ The number of 'DecryptionFactor's or
 589      -- the number of 'Proof's is not the same
 590      -- or not the expected number.
 591  |   ErrorDecryptionShare_Wrong
 592      -- ^ The 'Proof' of a 'DecryptionFactor' is wrong.
 593  deriving (Eq,Show,Generic,NFData)
 594
 595 -- BELENIOS: check_factor
 596 -- | @('verifyDecryptionShare' encByQuestByBallot pubKey decShare)@
 597 -- checks that 'decShare'
 598 -- (supposedly submitted by a trustee whose public key is 'pubKey')
 599 -- is valid with respect to the encrypted tally 'encByQuestByBallot'.
 600 verifyDecryptionShare ::
 601  Monad m => SubGroup q =>
 602  [[Encryption q]] ->
 603  PublicKey q -> DecryptionShare q -> ExceptT ErrorDecryptionShare m ()
 604 verifyDecryptionShare encByQuestByBallot pubKey DecryptionShare{..} =
 605         let zkp = decryptionShareStatement pubKey in
 606         isoZipWith3M_ (throwE ErrorDecryptionShare_Invalid)
 607          (isoZipWith3M_ (throwE ErrorDecryptionShare_Invalid) $
 608          \Encryption{..} decFactor proof ->
 609                 unless (proof_challenge proof == hash zkp
 610                  [ commit proof groupGen pubKey
 611                  , commit proof encryption_nonce decFactor
 612                  ]) $
 613                         throwE ErrorDecryptionShare_Wrong)
 614          encByQuestByBallot
 615          decryptionShare_factors
 616          decryptionShare_proofs
 617
 618 -- * Type 'Tally'
 619 data Tally q = Tally
 620  { tally_numBallots :: Natural
 621  , tally_encByQuestByBallot :: [[Encryption q]]
 622    -- ^ 'Encryption' by 'Question' by 'Ballot'.
 623  , tally_decShareByTrustee :: [DecryptionShare q]
 624    -- ^ 'DecryptionShare' by trustee.
 625  , tally_countByQuestByBallot :: [[Natural]]
 626  } deriving (Eq,Show,Generic,NFData)
 627
 628 -- ** Type 'DecryptionShareCombinator'
 629 type DecryptionShareCombinator q =
 630         [DecryptionShare q] -> Except ErrorDecryptionShare [[DecryptionFactor q]]
 631
 632 -- BELENIOS: compute_result
 633 proveTally ::
 634  Monad m => SubGroup q =>
 635  [[Encryption q]] -> [DecryptionShare q] ->
 636  DecryptionShareCombinator q ->
 637  Except ErrorDecryptionShare (Tally q)
 638 proveTally tally_encByQuestByBallot tally_decShareByTrustee decShareCombinator = do
 639         decFactorByQuestByBallot <- decShareCombinator tally_decShareByTrustee
 640         dec <- isoZipWithM err
 641          (\encByQuest decFactorByQuest ->
 642                 maybe err return $
 643                         isoZipWith (\Encryption{..} decFactor -> encryption_vault / decFactor)
 644                          encByQuest
 645                          decFactorByQuest
 646          )
 647          tally_encByQuestByBallot
 648          decFactorByQuestByBallot
 649         let tally_numBallots = fromIntegral $ List.length tally_encByQuestByBallot
 650         let logMap = Map.fromDistinctAscList $ List.zip groupGenPowers [0..tally_numBallots]
 651         let log x = maybe err return $ Map.lookup x logMap
 652         tally_countByQuestByBallot <- (log `mapM`)`mapM`dec
 653         return Tally{..}
 654         where err = throwE ErrorDecryptionShare_Invalid
 655
 656 verifyTally ::
 657  Monad m => SubGroup q =>
 658  DecryptionShareCombinator q -> Tally q ->
 659  Except ErrorDecryptionShare ()
 660 verifyTally decShareCombinator Tally{..} = do
 661         decFactorByQuestByBallot <- decShareCombinator tally_decShareByTrustee
 662         isoZipWith3M_ (throwE ErrorDecryptionShare_Invalid)
 663          (isoZipWith3M_ (throwE ErrorDecryptionShare_Invalid)
 664                  (\Encryption{..} decFactor count -> do
 665                         let dec = encryption_vault / decFactor
 666                         unless (dec == groupGen ^ fromNatural count) $
 667                                 throwE ErrorDecryptionShare_Wrong
 668                  )
 669          )
 670          tally_encByQuestByBallot
 671          decFactorByQuestByBallot
 672          tally_countByQuestByBallot