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

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