{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE UndecidableInstances #-}
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(..), fromJust)
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.List as List
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TL
import Voting.Protocol.Utils
import Voting.Protocol.FFC
import Voting.Protocol.Credential
data Encryption c = Encryption
{ encryption_nonce :: !(G c)
, encryption_vault :: !(G c)
} deriving (Eq,Show,Generic,NFData)
deriving instance Reifies c FFC => ToJSON (Encryption c)
deriving instance Reifies c FFC => FromJSON (Encryption c)
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 = E
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
return $ (encNonce,)
Encryption
{ encryption_nonce = groupGen^encNonce
, encryption_vault = pubKey ^encNonce * groupGen^clear
}
data Proof c = Proof
{ proof_challenge :: Challenge c
, proof_response :: E c
} deriving (Eq,Show,Generic,NFData)
deriving instance Reifies c FFC => ToJSON (Proof c)
deriving instance Reifies c FFC => FromJSON (Proof c)
newtype ZKP = ZKP BS.ByteString
type Challenge = E
type Oracle list c = list (Commitment c) -> Challenge c
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
}
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 = G
commit :: Reifies c FFC => Proof c -> G c -> G c -> Commitment c
commit Proof{..} base basePowSec =
base^proof_response *
basePowSec^proof_challenge
{-# INLINE commit #-}
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 = E
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 ::
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
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 ::
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)
encryptionStatement :: Reifies c FFC => ZKP -> Encryption c -> BS.ByteString
encryptionStatement (ZKP voterZKP) Encryption{..} =
"prove|"<>voterZKP<>"|"
<> bytesNat encryption_nonce<>","
<> bytesNat encryption_vault<>"|"
encryptionCommitments ::
Reifies c FFC =>
PublicKey c -> Encryption c ->
Disjunction c -> Proof c -> [G c]
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 = Question
{ question_text :: !Text
, question_choices :: ![Text]
, question_mini :: !Natural
, question_maxi :: !Natural
} deriving (Eq,Show,Generic,NFData,ToJSON,FromJSON)
data Answer c = Answer
{ answer_opinions :: ![(Encryption c, DisjProof c)]
, answer_sumProof :: !(DisjProof c)
} deriving (Eq,Show,Generic,NFData)
deriving instance Reifies c FFC => ToJSON (Answer c)
deriving instance Reifies c FFC => FromJSON (Answer c)
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)
, sum (snd <$> encryptions)
)
return $ Answer
{ answer_opinions = List.zip
(snd <$> encryptions)
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)
data ErrorAnswer
= ErrorAnswer_WrongNumberOfOpinions Natural Natural
| ErrorAnswer_WrongSumOfOpinions Natural Natural Natural
deriving (Eq,Show,Generic,NFData)
data Election c = Election
{ election_name :: !Text
, election_description :: !Text
, election_crypto :: !(ElectionCrypto c)
, election_questions :: ![Question]
, election_uuid :: !UUID
, election_hash :: !Hash
} deriving (Eq,Show,Generic,NFData)
instance ToJSON (Election c) where
toJSON Election{..} =
JSON.object
[ "name" .= election_name
, "description" .= election_description
, "public_key" .= election_crypto
, "questions" .= election_questions
, "uuid" .= election_uuid
]
toEncoding Election{..} =
JSON.pairs
( "name" .= election_name
<> "description" .= election_description
<> "public_key" .= election_crypto
<> "questions" .= election_questions
<> "uuid" .= election_uuid
)
instance FromJSON (Election c) where
parseJSON = JSON.withObject "Election" $ \o -> Election
<$> o .: "name"
<*> o .: "description"
<*> o .: "public_key"
<*> o .: "questions"
<*> o .: "uuid"
<*> pure (hashJSON (JSON.Object o))
data ElectionCrypto c =
ElectionCrypto_FFC
{ electionCrypto_FFC_params :: !FFC
, electionCrypto_FFC_PublicKey :: !(PublicKey c)
} deriving (Eq,Show,Generic,NFData)
reifyElection :: Election () -> (forall c. Reifies c FFC => Election c -> k) -> k
reifyElection Election{..} k =
case election_crypto of
ElectionCrypto_FFC ffc (G (F pubKey)) ->
reify ffc $ \(_::Proxy c) -> k @c
Election{election_crypto = ElectionCrypto_FFC ffc (G (F pubKey)), ..}
instance ToJSON (ElectionCrypto c) where
toJSON (ElectionCrypto_FFC ffc pubKey) =
JSON.object
[ "group" .= ffc
, "y" .= nat pubKey
]
toEncoding (ElectionCrypto_FFC ffc pubKey) =
JSON.pairs
( "group" .= ffc
<> "y" .= nat pubKey
)
instance FromJSON (ElectionCrypto c) where
parseJSON = JSON.withObject "ElectionCrypto" $ \o -> do
ffc <- o .: "group"
pubKey <- reify ffc $ \(_::Proxy s) -> nat <$> ((.:) @(PublicKey s) o "y")
return $ ElectionCrypto_FFC ffc (G (F pubKey))
newtype Hash = Hash Text
deriving (Eq,Ord,Show,Generic)
deriving anyclass (ToJSON,FromJSON)
deriving newtype NFData
hashJSON :: ToJSON a => a -> Hash
hashJSON = Hash . TL.toStrict . TL.decodeUtf8 . BSL64.encode . JSON.encode
hashElection :: Election c -> Election c
hashElection elec = elec{election_hash=hashJSON elec}
data Ballot c = Ballot
{ ballot_answers :: ![Answer c]
, ballot_signature :: !(Maybe (Signature c))
, ballot_election_uuid :: !UUID
, ballot_election_hash :: !Hash
} deriving (Generic,NFData)
deriving instance Reifies c FFC => ToJSON (Ballot c)
deriving instance Reifies c FFC => FromJSON (Ballot c)
encryptBallot ::
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
(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
data Signature c = Signature
{ signature_publicKey :: !(PublicKey c)
, signature_proof :: !(Proof c)
} deriving (Generic,NFData)
deriving instance Reifies c FFC => ToJSON (Signature c)
deriving instance Reifies c FFC => FromJSON (Signature c)
signatureStatement :: Reifies c FFC => Foldable f => f (Answer c) -> [G c]
signatureStatement =
foldMap $ \Answer{..} ->
(`foldMap` answer_opinions) $ \(Encryption{..}, _proof) ->
[encryption_nonce, encryption_vault]
signatureCommitments :: ZKP -> Commitment c -> 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)