{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE OverloadedStrings #-}
module Voting.Protocol.Election where
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.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(..), fromMaybe)
import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
import Data.Text (Text)
import Data.Traversable (Traversable(..))
import Data.Tuple (fst, snd)
import GHC.Natural (minusNaturalMaybe)
import GHC.Generics (Generic)
import Numeric.Natural (Natural)
import Prelude (fromIntegral)
import Text.Show (Show(..))
import qualified Control.Monad.Trans.State.Strict as S
import qualified Data.ByteString as BS
import qualified Data.List as List
import Voting.Protocol.Utils
import Voting.Protocol.Arithmetic
import Voting.Protocol.Credential
data Encryption q = Encryption
{ encryption_nonce :: G q
, encryption_vault :: G q
} deriving (Eq,Show,Generic,NFData)
instance SubGroup q => Additive (Encryption q) where
zero = Encryption one one
x+y = Encryption
(encryption_nonce x * encryption_nonce y)
(encryption_vault x * encryption_vault y)
type EncryptionNonce = E
encrypt ::
Monad m => RandomGen r => SubGroup q =>
PublicKey q -> E q ->
S.StateT r m (EncryptionNonce q, Encryption q)
encrypt pubKey clear = do
encNonce <- random
return $ (encNonce,)
Encryption
{ encryption_nonce = groupGen^encNonce
, encryption_vault = pubKey ^encNonce * groupGen^clear
}
data Proof q = Proof
{ proof_challenge :: Challenge q
, proof_response :: E q
} deriving (Eq,Show,Generic,NFData)
newtype ZKP = ZKP BS.ByteString
type Challenge = E
type Oracle list q = list (Commitment q) -> Challenge q
prove ::
Monad m => RandomGen r => SubGroup q => Functor list =>
E q -> list (G q) -> Oracle list q -> S.StateT r m (Proof q)
prove sec commitBases oracle = do
nonce <- random
let commitments = (^ nonce) <$> commitBases
let proof_challenge = oracle commitments
return Proof
{ proof_challenge
, proof_response = nonce - sec*proof_challenge
}
fakeProof :: Monad m => RandomGen r => SubGroup q => S.StateT r m (Proof q)
fakeProof = do
proof_challenge <- random
proof_response <- random
return Proof{..}
type Commitment = G
commit :: SubGroup q => Proof q -> G q -> G q -> Commitment q
commit Proof{..} base basePowSec =
base^proof_response *
basePowSec^proof_challenge
{-# INLINE commit #-}
type Disjunction = G
booleanDisjunctions :: SubGroup q => [Disjunction q]
booleanDisjunctions = List.take 2 groupGenInverses
intervalDisjunctions :: SubGroup q => Opinion q -> Opinion q -> [Disjunction q]
intervalDisjunctions mini maxi =
List.genericTake (fromMaybe 0 $ (nat maxi + 1)`minusNaturalMaybe`nat mini) $
List.genericDrop (nat mini) $
groupGenInverses
type Opinion = E
newtype DisjProof q = DisjProof [Proof q]
deriving (Eq,Show,Generic)
deriving newtype NFData
proveEncryption ::
Monad m => RandomGen r => SubGroup q =>
PublicKey q -> ZKP ->
([Disjunction q],[Disjunction q]) ->
(EncryptionNonce q, Encryption q) ->
S.StateT r m (DisjProof q)
proveEncryption elecPubKey voterZKP (prevDisjs,nextDisjs) (encNonce,enc) = do
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
let proofs = prevFakeProofs <> (genuineProof : nextFakeProofs)
return (DisjProof proofs)
verifyEncryption ::
Monad m => SubGroup q =>
PublicKey q -> ZKP ->
[Disjunction q] -> (Encryption q, DisjProof q) ->
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)
encryptionStatement :: SubGroup q => ZKP -> Encryption q -> BS.ByteString
encryptionStatement (ZKP voterZKP) Encryption{..} =
"prove|"<>voterZKP<>"|"
<> bytesNat encryption_nonce<>","
<> bytesNat encryption_vault<>"|"
encryptionCommitments ::
SubGroup q =>
PublicKey q -> Encryption q ->
Disjunction q -> Proof q -> [G q]
encryptionCommitments elecPubKey Encryption{..} disj proof =
[ commit proof groupGen encryption_nonce
, commit proof elecPubKey (encryption_vault*disj)
]
data ErrorVerifyEncryption
= ErrorVerifyEncryption_InvalidProofLength Natural Natural
deriving (Eq,Show)
data Question q = Question
{ question_text :: Text
, question_choices :: [Text]
, question_mini :: Opinion q
, question_maxi :: Opinion q
} deriving (Eq,Show,Generic,NFData)
data Answer q = Answer
{ answer_opinions :: [(Encryption q, DisjProof q)]
, answer_sumProof :: DisjProof q
} deriving (Eq,Show,Generic,NFData)
encryptAnswer ::
Monad m => RandomGen r => SubGroup q =>
PublicKey q -> ZKP ->
Question q -> [Bool] ->
S.StateT r (ExceptT ErrorAnswer m) (Answer q)
encryptAnswer elecPubKey zkp Question{..} opinionByChoice
| not (question_mini <= opinionsSum && opinionsSum <= question_maxi) =
lift $ throwE $
ErrorAnswer_WrongSumOfOpinions
(nat opinionsSum)
(nat question_mini)
(nat 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 ([booleanDisjunctions List.!!0],[])
else ([],[booleanDisjunctions List.!!1]))
opinionByChoice encryptions
sumProof <- proveEncryption elecPubKey zkp
(List.tail <$> List.genericSplitAt
(nat (opinionsSum - question_mini))
(intervalDisjunctions question_mini question_maxi))
( sum (fst <$> encryptions)
, sum (snd <$> encryptions)
)
return $ Answer
{ answer_opinions = List.zip
(snd <$> encryptions)
individualProofs
, answer_sumProof = sumProof
}
where
opinionsSum = sum opinions
opinions = (\o -> if o then one else zero) <$> opinionByChoice
verifyAnswer ::
SubGroup q =>
PublicKey q -> ZKP ->
Question q -> Answer q -> 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)
data ErrorAnswer
= ErrorAnswer_WrongNumberOfOpinions Natural Natural
| ErrorAnswer_WrongSumOfOpinions Natural Natural Natural
deriving (Eq,Show,Generic,NFData)
data Election q = Election
{ election_name :: Text
, election_description :: Text
, election_PublicKey :: PublicKey q
, election_questions :: [Question q]
, election_uuid :: UUID
, election_hash :: Hash
} deriving (Eq,Show,Generic,NFData)
newtype Hash = Hash Text
deriving (Eq,Ord,Show,Generic)
deriving newtype NFData
data Ballot q = Ballot
{ ballot_answers :: [Answer q]
, ballot_signature :: Maybe (Signature q)
, ballot_election_uuid :: UUID
, ballot_election_hash :: Hash
} deriving (Generic,NFData)
encryptBallot ::
Monad m => RandomGen r => SubGroup q =>
Election q -> Maybe (SecretKey q) -> [[Bool]] ->
S.StateT r (ExceptT ErrorBallot m) (Ballot q)
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 election_PublicKey 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
(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 :: SubGroup q => Election q -> Ballot q -> Bool
verifyBallot Election{..} Ballot{..} =
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 election_PublicKey zkpSign)
election_questions ballot_answers
data Signature q = Signature
{ signature_publicKey :: PublicKey q
, signature_proof :: Proof q
} deriving (Generic,NFData)
signatureStatement :: Foldable f => SubGroup q => f (Answer q) -> [G q]
signatureStatement =
foldMap $ \Answer{..} ->
(`foldMap` answer_opinions) $ \(Encryption{..}, _proof) ->
[encryption_nonce, encryption_vault]
signatureCommitments :: SubGroup q => ZKP -> Commitment q -> BS.ByteString
signatureCommitments (ZKP voterZKP) commitment =
"sig|"<>voterZKP<>"|"
<> bytesNat commitment<>"|"
data ErrorBallot
= ErrorBallot_WrongNumberOfAnswers Natural Natural
| ErrorBallot_Answer ErrorAnswer
| ErrorBallot_Wrong
deriving (Eq,Show,Generic,NFData)