protocol: align Proof on Belenios' (slower) calculus

[majurity.git] / hjugement-protocol / src / Voting / Protocol / Election.hs

{-# LANGUAGE DeriveAnyClass #-}
{-# 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.Functor (Functor, (<$>))
import Data.Functor.Identity (Identity(..))
import Data.Maybe (Maybe(..), maybe, fromJust)
import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
import Data.Text (Text)
import Data.Traversable (Traversable(..))
import Data.Tuple (fst, snd)
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.ByteString.Lazy as BSL
import qualified Data.List as List

import Voting.Protocol.Utils
import Voting.Protocol.FFC
import Voting.Protocol.Credential

-- * Type 'Encryption'
-- | ElGamal-like encryption.
-- Its security relies on the /Discrete Logarithm problem/.
--
-- Because ('groupGen' '^'encNonce '^'secKey '==' 'groupGen' '^'secKey '^'encNonce),
-- knowing @secKey@, one can divide 'encryption_vault' by @('encryption_nonce' '^'secKey)@
-- to decipher @('groupGen' '^'clear)@, then the @clear@ text must be small to be decryptable,
-- because it is encrypted as a power of 'groupGen' (hence the "-like" in "ElGamal-like")
-- to enable the additive homomorphism.
--
-- NOTE: Since @('encryption_vault' '*' 'encryption_nonce' '==' 'encryption_nonce' '^' (secKey '+' clear))@,
-- then: @(logBase 'encryption_nonce' ('encryption_vault' '*' 'encryption_nonce') '==' secKey '+' clear)@.
data Encryption 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 c)
   -- ^ Encrypted 'clear' text,
   -- equal to @('pubKey' '^'encNone '*' 'groupGen' '^'clear)@
 } deriving (Eq,Show,Generic,NFData)
instance Reifies c FFC => ToJSON (Encryption c) where
        toJSON Encryption{..} =
                JSON.object
                 [ "alpha" .= encryption_nonce
                 , "beta"  .= encryption_vault
                 ]
        toEncoding Encryption{..} =
                JSON.pairs
                 (  "alpha" .= encryption_nonce
                 <> "beta"  .= encryption_vault
                 )
instance Reifies c FFC => FromJSON (Encryption c) where
        parseJSON = JSON.withObject "Encryption" $ \o -> do
                encryption_nonce <- o .: "alpha"
                encryption_vault <- o .: "beta"
                return Encryption{..}

-- | Additive homomorphism.
-- Using the fact that: @'groupGen' '^'x '*' 'groupGen' '^'y '==' 'groupGen' '^'(x'+'y)@.
instance Reifies c FFC => Additive (Encryption c) where
        zero = Encryption one one
        x+y = Encryption
         (encryption_nonce x * encryption_nonce y)
         (encryption_vault x * encryption_vault y)

-- *** Type 'EncryptionNonce'
type EncryptionNonce = E

-- | @('encrypt' pubKey clear)@ returns an ElGamal-like 'Encryption'.
--
-- WARNING: the secret encryption nonce (@encNonce@)
-- is returned alongside the 'Encryption'
-- in order to 'prove' the validity of the encrypted 'clear' text in 'proveEncryption',
-- but this secret @encNonce@ MUST be forgotten after that,
-- as it may be used to decipher the 'Encryption'
-- without the 'SecretKey' associated with 'pubKey'.
encrypt ::
 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'.
        return $ (encNonce,)
                Encryption
                 { encryption_nonce = groupGen^encNonce
                 , encryption_vault = pubKey  ^encNonce * groupGen^clear
                 }

-- * Type 'Proof'
-- | Non-Interactive Zero-Knowledge 'Proof'
-- of knowledge of a discrete logarithm:
-- @(secret == logBase base (base^secret))@.
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.
   -- Actually, 'proof_challenge' is not sent to the prover,
   -- but derived from the prover's 'Commitment's and statements
   -- with a collision resistant 'hash'.
   -- Hence the prover cannot chose the 'proof_challenge' to his/her liking.
 , proof_response :: E c
   -- ^ A discrete logarithm sent by the prover to the verifier,
   -- as a response to 'proof_challenge'.
   --
   -- If the verifier observes that @('proof_challenge' '==' 'hash' statement [commitment])@, where:
   --
   -- * @statement@ is a serialization of a tag, @base@ and @basePowSec@,
   -- * @commitment '==' 'commit' proof base basePowSec '=='
   --   base '^' 'proof_response' '*' basePowSec '^' 'proof_challenge'@,
   -- * and @basePowSec '==' base'^'sec@,
   --
   -- then, with overwhelming probability (due to the 'hash' function),
   -- the prover was not able to choose 'proof_challenge'
   -- yet was able to compute a 'proof_response' such that
   -- (@commitment '==' base '^' 'proof_response' '*' basePowSec '^' 'proof_challenge'@),
   -- that is to say: @('proof_response' '==' logBase base 'commitment' '-' sec '*' 'proof_challenge')@,
   -- therefore the prover knows 'sec'.
   --
   -- The prover choses 'commitment' to be a random power of @base@,
   -- to ensure that each 'prove' does not reveal any information
   -- about its secret.
 } deriving (Eq,Show,Generic,NFData)
instance ToJSON (Proof c) where
        toJSON Proof{..} =
                JSON.object
                 [ "challenge" .= proof_challenge
                 , "response"  .= proof_response
                 ]
        toEncoding Proof{..} =
                JSON.pairs
                 (  "challenge" .= proof_challenge
                 <> "response"  .= proof_response
                 )
instance Reifies c FFC => FromJSON (Proof c) where
        parseJSON = JSON.withObject "TrusteePublicKey" $ \o -> do
                proof_challenge <- o .: "challenge"
                proof_response  <- o .: "response"
                return Proof{..}

-- ** Type 'ZKP'
-- | Zero-knowledge proof.
--
-- A protocol is /zero-knowledge/ if the verifier
-- learns nothing from the protocol except that the prover
-- knows the secret.
--
-- DOC: Mihir Bellare and Phillip Rogaway. Random oracles are practical:
--      A paradigm for designing efficient protocols. In ACM-CCS’93, 1993.
newtype ZKP = ZKP BS.ByteString

-- ** Type 'Challenge'
type Challenge = E

-- ** Type 'Oracle'
-- An 'Oracle' returns the 'Challenge' of the 'Commitment's
-- by 'hash'ing them (eventually with other 'Commitment's).
--
-- Used in 'prove' it enables a Fiat-Shamir transformation
-- of an /interactive zero-knowledge/ (IZK) proof
-- into a /non-interactive zero-knowledge/ (NIZK) proof.
-- That is to say that the verifier does not have
-- to send a 'Challenge' to the prover.
-- Indeed, the prover now handles the 'Challenge'
-- which becomes a (collision resistant) 'hash'
-- of the prover's commitments (and statements to be a stronger proof).
type Oracle list c = list (Commitment c) -> Challenge c

-- | @('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 '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
-- (with 'commit').
--
-- WARNING: for 'prove' to be a so-called /strong Fiat-Shamir transformation/ (not a weak):
-- the statement must be included in the 'hash' (along with the commitments).
--
-- NOTE: a 'random' @nonce@ is used to ensure each 'prove'
-- does not reveal any information regarding the secret @sec@,
-- because two 'Proof's using the same 'Commitment'
-- can be used to deduce @sec@ (using the special-soundness).
prove ::
 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) <$> commitmentBases
        let proof_challenge = oracle commitments
        return Proof
         { proof_challenge
         , proof_response = nonce + sec*proof_challenge
           -- TODO: switch (+) to (-) when 'commit' will switch (/) to (*).
         }

-- | @('fakeProof')@ returns a 'Proof'
-- whose 'proof_challenge' and 'proof_response' are uniformly chosen at random,
-- instead of @('proof_challenge' '==' 'hash' statement commitments)@
-- and @('proof_response' '==' nonce '+' sec '*' 'proof_challenge')@
-- as a 'Proof' returned by 'prove'.
--
-- Used in 'proveEncryption' to fill the returned 'DisjProof'
-- with fake 'Proof's for all 'Disjunction's but the encrypted one.
fakeProof ::
 Reifies c FFC =>
 Monad m =>
 RandomGen r => S.StateT r m (Proof c)
fakeProof = do
        proof_challenge <- random
        proof_response  <- random
        return Proof{..}

-- ** Type 'Commitment'
-- | A commitment from the prover to the verifier.
-- It's a power of 'groupGen' chosen randomly by the prover
-- when making a 'Proof' with 'prove'.
type Commitment = G

-- | @('commit' proof base basePowSec)@ returns a 'Commitment'
-- from the given 'Proof' with the knowledge of the verifier.
commit :: Reifies c FFC => Proof c -> G c -> G c -> Commitment c
commit Proof{..} base basePowSec =
        base^proof_response /
        basePowSec^proof_challenge
  -- TODO: contrary to some textbook presentations,
  -- @('*')@ should be used instead of @('/')@ to avoid the performance cost
  -- of a modular exponentiation @('^' ('groupOrder' '-' 'one'))@,
  -- this would be compensated by using @('-')@ instead of @('+')@ in 'prove'.
{-# INLINE commit #-}

-- * Type 'Disjunction'
-- | A 'Disjunction' is an 'inv'ersed @('groupGen' '^'opinion)@
-- it's used in 'proveEncryption' to generate a 'Proof'
-- that an 'encryption_vault' contains a given @('groupGen' '^'opinion)@,
type Disjunction = G

booleanDisjunctions :: Reifies c FFC => [Disjunction c]
booleanDisjunctions = List.take 2 groupGenInverses

intervalDisjunctions :: Reifies c FFC => Natural -> Natural -> [Disjunction c]
intervalDisjunctions mini maxi =
        List.genericTake (fromJust $ (nat maxi + 1)`minusNaturalMaybe`nat mini) $
        List.genericDrop (nat mini) $
        groupGenInverses

-- ** Type 'Opinion'
-- | Index of a 'Disjunction' within a list of them.
-- It is encrypted as an 'E'xponent by 'encrypt'.
type Opinion = E

-- ** Type 'DisjProof'
-- | A list of 'Proof's to prove that the 'Opinion' within an 'Encryption'
-- is indexing a 'Disjunction' within a list of them,
-- without revealing which 'Opinion' it is.
newtype DisjProof 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
-- the 'Disjunction' 'd' between 'prevDisjs' and 'nextDisjs'.
--
-- The prover proves that it knows an 'encNonce', such that:
-- @(enc '==' Encryption{encryption_nonce='groupGen' '^'encNonce, encryption_vault=elecPubKey'^'encNonce '*' groupGen'^'d})@
--
-- A /NIZK Disjunctive Chaum Pedersen Logarithm Equality/ is used.
--
-- DOC: Pierrick Gaudry. <https://hal.inria.fr/hal-01576379 Some ZK security proofs for Belenios>, 2017.
proveEncryption ::
 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
        nextFakeProofs <- replicateM (List.length nextDisjs) fakeProof
        let fakeChallengeSum =
                sum (proof_challenge <$> prevFakeProofs) +
                sum (proof_challenge <$> nextFakeProofs)
        let statement = encryptionStatement voterZKP enc
        genuineProof <- prove encNonce [groupGen, elecPubKey] $ \genuineCommitments ->
                let validCommitments = List.zipWith (encryptionCommitments elecPubKey enc) in
                let prevCommitments = validCommitments prevDisjs prevFakeProofs in
                let nextCommitments = validCommitments nextDisjs nextFakeProofs in
                let commitments = join prevCommitments <> genuineCommitments <> join nextCommitments in
                let challenge = hash statement commitments in
                let genuineChallenge = challenge - fakeChallengeSum in
                genuineChallenge
                -- NOTE: here by construction (genuineChallenge == challenge - fakeChallengeSum)
                -- thus (sum (proof_challenge <$> proofs) == challenge)
                -- as checked in 'verifyEncryption'.
        let proofs = prevFakeProofs <> (genuineProof : nextFakeProofs)
        return (DisjProof proofs)

verifyEncryption ::
 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
         Nothing ->
                throwE $ ErrorVerifyEncryption_InvalidProofLength
                 (fromIntegral $ List.length proofs)
                 (fromIntegral $ List.length disjs)
         Just commitments ->
                return $ challengeSum ==
                        hash (encryptionStatement voterZKP enc) (join commitments)
        where
        challengeSum = sum (proof_challenge <$> proofs)

-- ** Hashing
encryptionStatement :: Reifies c FFC => ZKP -> Encryption c -> BS.ByteString
encryptionStatement (ZKP voterZKP) Encryption{..} =
        "prove|"<>voterZKP<>"|"
         <> bytesNat encryption_nonce<>","
         <> bytesNat encryption_vault<>"|"

-- | @('encryptionCommitments' elecPubKey enc disj proof)@
-- returns the 'Commitment's with only the knowledge of the verifier.
--
-- For the prover the 'Proof' comes from @fakeProof@,
-- and for the verifier the 'Proof' comes from the prover.
encryptionCommitments ::
 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'.
          -- base==groupGen, basePowSec==groupGen^encNonce.
        , commit proof elecPubKey (encryption_vault*disj)
          -- == elecPubKey ^ nonce if 'Proof' comes from 'prove'
          -- and 'encryption_vault' encrypts (- logBase groupGen disj).
          -- base==elecPubKey, basePowSec==elecPubKey^encNonce.
        ]

-- ** Type 'ErrorVerifyEncryption'
-- | Error raised by 'verifyEncryption'.
data ErrorVerifyEncryption
 =   ErrorVerifyEncryption_InvalidProofLength Natural Natural
     -- ^ When the number of proofs is different than
     -- the number of 'Disjunction's.
 deriving (Eq,Show)

-- * Type 'Question'
data Question = Question
 { question_text    :: !Text
 , question_choices :: ![Text]
 , question_mini    :: !Natural
 , question_maxi    :: !Natural
 -- , question_blank :: Maybe Bool
 } deriving (Eq,Show,Generic,NFData)
instance ToJSON Question where
        toJSON Question{..} =
                JSON.object
                 [ "question" .= question_text
                 , "answers"  .= question_choices
                 , "min"      .= question_mini
                 , "max"      .= question_maxi
                 ]
        toEncoding Question{..} =
                JSON.pairs
                 (  "question" .= question_text
                 <> "answers"  .= question_choices
                 <> "min"      .= question_mini
                 <> "max"      .= question_maxi
                 )
instance FromJSON Question where
        parseJSON = JSON.withObject "Question" $ \o -> do
                question_text    <- o .: "question"
                question_choices <- o .: "answers"
                question_mini    <- o .: "min"
                question_maxi    <- o .: "max"
                return Question{..}

-- * Type 'Answer'
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 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)
instance Reifies c FFC => ToJSON (Answer c) where
        toJSON Answer{..} =
                let (answer_choices, answer_individual_proofs) =
                        List.unzip answer_opinions in
                JSON.object
                 [ "choices"           .= answer_choices
                 , "individual_proofs" .= answer_individual_proofs
                 , "overall_proof"     .= answer_sumProof
                 ]
        toEncoding Answer{..} =
                let (answer_choices, answer_individual_proofs) =
                        List.unzip answer_opinions in
                JSON.pairs
                 (  "choices"           .= answer_choices
                 <> "individual_proofs" .= answer_individual_proofs
                 <> "overall_proof"     .= answer_sumProof
                 )
instance Reifies c FFC => FromJSON (Answer c) where
        parseJSON = JSON.withObject "Answer" $ \o -> do
                answer_choices <- o .: "choices"
                answer_individual_proofs <- o .: "individual_proofs"
                let answer_opinions = List.zip answer_choices answer_individual_proofs
                answer_sumProof <- o .: "overall_proof"
                return Answer{..}

-- | @('encryptAnswer' elecPubKey zkp quest opinions)@
-- returns an 'Answer' validable by 'verifyAnswer',
-- unless an 'ErrorAnswer' is returned.
encryptAnswer ::
 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 opinionsSum question_mini question_maxi
 | List.length opinions /= List.length question_choices =
        lift $ throwE $
                ErrorAnswer_WrongNumberOfOpinions
                 (fromIntegral $ List.length opinions)
                 (fromIntegral $ List.length question_choices)
 | otherwise = do
        encryptions <- encrypt elecPubKey `mapM` opinions
        individualProofs <- zipWithM
         (\opinion -> proveEncryption elecPubKey zkp $
                if opinion
                then (List.init booleanDisjunctions,[])
                else ([],List.tail booleanDisjunctions))
         opinionByChoice encryptions
        sumProof <- proveEncryption elecPubKey zkp
         (List.tail <$> List.genericSplitAt
                 (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
         )
        return $ Answer
         { answer_opinions = List.zip
                 (snd <$> encryptions) -- NOTE: drop encNonce
                 individualProofs
         , answer_sumProof = sumProof
         }
 where
        opinionsSum = sum $ nat <$> opinions
        opinions = (\o -> if o then one else zero) <$> opinionByChoice

verifyAnswer ::
 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
        validOpinions <-
                verifyEncryption elecPubKey zkp booleanDisjunctions
                 `traverse` answer_opinions
        validSum <- verifyEncryption elecPubKey zkp
         (intervalDisjunctions question_mini question_maxi)
         ( sum (fst <$> answer_opinions)
         , answer_sumProof )
        return (and validOpinions && validSum)

-- ** Type 'ErrorAnswer'
-- | Error raised by 'encryptAnswer'.
data ErrorAnswer
 =   ErrorAnswer_WrongNumberOfOpinions Natural Natural
     -- ^ When the number of opinions is different than
     -- the number of choices ('question_choices').
 |   ErrorAnswer_WrongSumOfOpinions Natural Natural Natural
     -- ^ When the sum of opinions is not within the bounds
     -- of 'question_mini' and 'question_maxi'.
 deriving (Eq,Show,Generic,NFData)

-- * Type 'Election'
data Election 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 ()) 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"     .= pubKey
                 ]
        toEncoding (ElectionCrypto_FFC ffc pubKey) =
                JSON.pairs
                 (  "group" .= ffc
                 <> "y"     .= pubKey
                 )
instance FromJSON (ElectionCrypto ()) where
        parseJSON = JSON.withObject "ElectionCrypto" $ \o -> do
                ffc <- o .: "group"
                pubKey <- reify ffc $ \(_::Proxy s) -> nat <$> ((.:) @(PublicKey s) o "y")
                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 . hexHash . BSL.toStrict . BSL64.encode . JSON.encode

hashElection :: Election c -> Election c
hashElection elec = elec{election_hash=hashJSON elec}

-- * Type 'Ballot'
data Ballot c = Ballot
 { ballot_answers       :: ![Answer c]
 , ballot_signature     :: !(Maybe (Signature c))
 , ballot_election_uuid :: !UUID
 , ballot_election_hash :: !Hash
 } deriving (Generic,NFData)
instance Reifies c FFC => ToJSON (Ballot c) where
        toJSON Ballot{..} =
                JSON.object $
                 [ "answers"       .= ballot_answers
                 , "election_uuid" .= ballot_election_uuid
                 , "election_hash" .= ballot_election_hash
                 ] <>
                 maybe [] (\sig -> [ "signature" .= sig ]) ballot_signature
        toEncoding Ballot{..} =
                JSON.pairs $
                 (  "answers"       .= ballot_answers
                 <> "election_uuid" .= ballot_election_uuid
                 <> "election_hash" .= ballot_election_hash
                 ) <>
                 maybe mempty (\sig -> "signature" .= sig) ballot_signature
instance Reifies c FFC => FromJSON (Ballot c) where
        parseJSON = JSON.withObject "Ballot" $ \o -> do
                ballot_answers       <- o .: "answers"
                ballot_signature     <- o .:? "signature"
                ballot_election_uuid <- o .: "election_uuid"
                ballot_election_hash <- o .: "election_hash"
                return Ballot{..}

-- | @('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 ::
 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 $
                ErrorBallot_WrongNumberOfAnswers
                 (fromIntegral $ List.length opinionsByQuest)
                 (fromIntegral $ List.length election_questions)
 | otherwise = do
        let (voterKeys, voterZKP) =
                case ballotSecKeyMay of
                 Nothing -> (Nothing, ZKP "")
                 Just ballotSecKey ->
                        ( Just (ballotSecKey, ballotPubKey)
                        , ZKP (bytesNat ballotPubKey) )
                        where ballotPubKey = publicKey ballotSecKey
        ballot_answers <-
                S.mapStateT (withExceptT ErrorBallot_Answer) $
                        zipWithM (encryptAnswer (electionCrypto_FFC_PublicKey election_crypto) voterZKP)
                         election_questions opinionsByQuest
        ballot_signature <- case voterKeys of
         Nothing -> return Nothing
         Just (ballotSecKey, signature_publicKey) -> do
                signature_proof <-
                        prove ballotSecKey (Identity groupGen) $
                         \(Identity commitment) ->
                                hash
                                 -- NOTE: the order is unusual, the commitments are first
                                 -- then comes the statement. Best guess is that
                                 -- this is easier to code due to their respective types.
                                 (signatureCommitments voterZKP commitment)
                                 (signatureStatement ballot_answers)
                return $ Just Signature{..}
        return Ballot
         { ballot_answers
         , ballot_election_hash = election_hash
         , ballot_election_uuid = election_uuid
         , ballot_signature
         }

verifyBallot :: 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 &&
        let (isValidSign, zkpSign) =
                case ballot_signature of
                 Nothing -> (True, ZKP "")
                 Just Signature{..} ->
                        let zkp = ZKP (bytesNat signature_publicKey) in
                        (, zkp) $
                                proof_challenge signature_proof == hash
                                 (signatureCommitments zkp (commit signature_proof groupGen signature_publicKey))
                                 (signatureStatement ballot_answers)
        in
        and $ isValidSign :
                List.zipWith (verifyAnswer elecPubKey zkpSign)
                 election_questions ballot_answers

-- ** Type 'Signature'
-- | Schnorr-like signature.
--
-- Used by each voter to sign his/her encrypted 'Ballot'
-- using his/her 'Credential',
-- in order to avoid ballot stuffing.
data Signature c = Signature
 { signature_publicKey :: !(PublicKey c)
   -- ^ Verification key.
 , signature_proof     :: !(Proof c)
 } deriving (Generic,NFData)
instance Reifies c FFC => ToJSON (Signature c) where
        toJSON (Signature pubKey Proof{..}) =
                JSON.object
                 [ "public_key" .= pubKey
                 , "challenge"  .= proof_challenge
                 , "response"   .= proof_response
                 ]
        toEncoding (Signature pubKey Proof{..}) =
                JSON.pairs
                 (  "public_key" .= pubKey
                 <> "challenge"  .= proof_challenge
                 <> "response"   .= proof_response
                 )
instance Reifies c FFC => FromJSON (Signature c) where
        parseJSON = JSON.withObject "Signature" $ \o -> do
                signature_publicKey <- o .: "public_key"
                proof_challenge     <- o .: "challenge"
                proof_response      <- o .: "response"
                let signature_proof = Proof{..}
                return Signature{..}

-- *** Hashing

-- | @('signatureStatement' answers)@
-- returns the encrypted material to be signed:
-- all the 'encryption_nonce's and 'encryption_vault's of the given @answers@.
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 :: ZKP -> Commitment c -> BS.ByteString
signatureCommitments (ZKP voterZKP) commitment =
        "sig|"<>voterZKP<>"|" -- NOTE: this is actually part of the statement
         <> bytesNat commitment<>"|"

-- ** Type 'ErrorBallot'
-- | Error raised by 'encryptBallot'.
data ErrorBallot
 =   ErrorBallot_WrongNumberOfAnswers Natural Natural
     -- ^ When the number of answers
     -- is different than the number of questions.
 |   ErrorBallot_Answer ErrorAnswer
     -- ^ When 'encryptAnswer' raised an 'ErrorAnswer'.
 |   ErrorBallot_Wrong
     -- ^ TODO: to be more precise.
 deriving (Eq,Show,Generic,NFData)