{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
module Protocol.Election where
import Control.Monad (Monad(..), mapM, zipWithM)
import Control.Monad.Morph (MFunctor(..))
import Control.Monad.Trans.Class (MonadTrans(..))
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.String (IsString(..))
import Data.Text (Text)
import Data.Traversable (Traversable(..))
import Data.Tuple (fst, snd)
import GHC.Natural (minusNaturalMaybe)
import Numeric.Natural (Natural)
import Prelude (error, fromIntegral)
import Text.Show (Show(..))
import qualified Control.Monad.Trans.Except as Exn
import qualified Control.Monad.Trans.State.Strict as S
import qualified Data.ByteString as BS
import qualified Data.List as List
import Protocol.Arithmetic
import Protocol.Credential
data Encryption q = Encryption
{ encryption_nonce :: G q
, encryption_vault :: G q
} deriving (Eq,Show)
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)
type Challenge = E
type Oracle list q = list (Commitment q) -> Challenge q
prove ::
Monad m => RandomGen r => SubGroup q => Functor list =>
E q -> list (Commitment q) -> Oracle list q -> S.StateT r m (Proof q)
prove sec commitments oracle = do
nonce <- random
let proof_challenge = oracle $ (^ nonce) <$> commitments
return Proof
{ proof_challenge
, proof_response = nonce - sec*proof_challenge
}
type Commitment = G
commit :: SubGroup q => Proof q -> G q -> G q -> Commitment q
commit Proof{..} x y = x^proof_response * y^proof_challenge
{-# INLINE commit #-}
type Opinion = E
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 $ (natE maxi + 1)`minusNaturalMaybe`natE mini) $
List.genericDrop (natE mini) $
groupGenInverses
newtype DisjProof q = DisjProof [Proof q]
deriving (Eq,Show)
proveEncryption ::
forall m r q.
Monad m => RandomGen r => SubGroup q =>
PublicKey q -> ZKP ->
[Disjunction q] -> Opinion q ->
(EncryptionNonce q, Encryption q) ->
S.StateT r (Exn.ExceptT ErrorProove m) (DisjProof q)
proveEncryption pubKey zkp disjs opinion (encNonce, enc)
| (prevDisjs, _indexedDisj:nextDisjs) <-
List.genericSplitAt (natE opinion) disjs = do
prevFakes <- fakeProof `mapM` prevDisjs
nextFakes <- fakeProof `mapM` nextDisjs
let prevProofs = fst <$> prevFakes
let nextProofs = fst <$> nextFakes
let challengeSum =
sum (proof_challenge <$> prevProofs) +
sum (proof_challenge <$> nextProofs)
correctProof <- prove encNonce [groupGen, pubKey] $
\correctCommitments ->
let commitments =
foldMap snd prevFakes <>
correctCommitments <>
foldMap snd nextFakes in
hash (encryptionStatement zkp enc) commitments - challengeSum
return $ DisjProof $ prevProofs <> (correctProof : nextProofs)
| otherwise = lift $ Exn.throwE $
ErrorProove_InvalidOpinion
(fromIntegral $ List.length disjs)
(natE opinion)
where
fakeProof :: Disjunction q -> S.StateT r (Exn.ExceptT ErrorProove m) (Proof q, [Commitment q])
fakeProof disj = do
proof_challenge <- random
proof_response <- random
let proof = Proof{..}
return (proof, encryptionCommitments pubKey enc (disj, proof))
verifyEncryption ::
Monad m =>
SubGroup q =>
PublicKey q -> ZKP ->
[Disjunction q] ->
(Encryption q, DisjProof q) ->
Exn.ExceptT ErrorValidateEncryption m Bool
verifyEncryption pubKey zkp disjs (enc, DisjProof proofs)
| List.length proofs /= List.length disjs =
Exn.throwE $ ErrorValidateEncryption_InvalidProofLength
(fromIntegral $ List.length proofs)
(fromIntegral $ List.length disjs)
| otherwise = return $ challengeSum == hash (encryptionStatement zkp enc) commitments
where
challengeSum = sum (proof_challenge <$> proofs)
commitments = foldMap (encryptionCommitments pubKey enc) (List.zip disjs proofs)
encryptionStatement :: SubGroup q => ZKP -> Encryption q -> BS.ByteString
encryptionStatement (ZKP zkp) Encryption{..} =
"prove|"<>zkp<>"|"<>
fromString (show (natG encryption_nonce))<>","<>
fromString (show (natG encryption_vault))<>"|"
encryptionCommitments ::
SubGroup q =>
PublicKey q -> Encryption q ->
(Disjunction q, Proof q) -> [G q]
encryptionCommitments pubKey Encryption{..} (disj, proof) =
[ commit proof groupGen encryption_nonce
, commit proof pubKey (encryption_vault*disj)
]
newtype ZKP = ZKP BS.ByteString
data ErrorProove
= ErrorProove_InvalidOpinion Natural Natural
deriving (Eq,Show)
data ErrorValidateEncryption
= ErrorValidateEncryption_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)
data Answer q = Answer
{ answer_opinions :: [(Encryption q, DisjProof q)]
, answer_sumProof :: DisjProof q
} deriving (Eq,Show)
data ErrorAnswer
= ErrorAnswer_WrongNumberOfOpinions Natural Natural
| ErrorAnswer_WrongSumOfOpinions Natural Natural Natural
deriving (Eq,Show)
encryptAnswer ::
Monad m => RandomGen r => SubGroup q =>
PublicKey q -> ZKP ->
Question q -> [Bool] ->
S.StateT r (Exn.ExceptT ErrorAnswer m) (Answer q)
encryptAnswer pubKey zkp Question{..} opinionsBools
| not (question_mini <= opinionsSum && opinionsSum <= question_maxi) =
lift $ Exn.throwE $
ErrorAnswer_WrongSumOfOpinions
(natE opinionsSum)
(natE question_mini)
(natE question_maxi)
| List.length opinions /= List.length question_choices =
lift $ Exn.throwE $
ErrorAnswer_WrongNumberOfOpinions
(fromIntegral $ List.length opinions)
(fromIntegral $ List.length question_choices)
| otherwise = do
encryptions <- encrypt pubKey `mapM` opinions
hoist (Exn.withExceptT (\case
ErrorProove_InvalidOpinion{} -> error "encryptAnswer: impossible happened"
)) $ do
individualProofs <- zipWithM
(proveEncryption pubKey zkp booleanDisjunctions)
opinions encryptions
sumProof <- proveEncryption pubKey zkp
(intervalDisjunctions question_mini question_maxi)
(opinionsSum - question_mini)
( 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) <$> opinionsBools
verifyAnswer ::
SubGroup q =>
PublicKey q -> ZKP ->
Question q -> Answer q -> Bool
verifyAnswer pubKey zkp Question{..} Answer{..}
| List.length question_choices /= List.length answer_opinions = False
| otherwise = either (const False) id $ Exn.runExcept $ do
validOpinions <-
verifyEncryption pubKey zkp booleanDisjunctions
`traverse` answer_opinions
validSum <- verifyEncryption pubKey zkp
(intervalDisjunctions question_mini question_maxi)
( sum (fst <$> answer_opinions)
, answer_sumProof )
return (and validOpinions && validSum)
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)
newtype Hash = Hash Text
deriving (Eq,Ord,Show)
data Ballot q = Ballot
{ ballot_answers :: [Answer q]
, ballot_signature :: Maybe (Signature q)
, ballot_election_uuid :: UUID
, ballot_election_hash :: Hash
}
encryptBallot ::
Monad m => RandomGen r => SubGroup q =>
Election q -> Maybe (SecretKey q) -> [[Bool]] ->
S.StateT r (Exn.ExceptT ErrorBallot m) (Ballot q)
encryptBallot Election{..} secKeyMay opinionsByQuest
| List.length election_questions /= List.length opinionsByQuest =
lift $ Exn.throwE $
ErrorBallot_WrongNumberOfAnswers
(fromIntegral $ List.length opinionsByQuest)
(fromIntegral $ List.length election_questions)
| otherwise = do
let (keysMay, zkp) =
case secKeyMay of
Nothing -> (Nothing, ZKP "")
Just secKey ->
( Just (secKey, pubKey)
, ZKP (fromString (show (natG pubKey))) )
where pubKey = groupGen ^ secKey
ballot_answers <-
hoist (Exn.withExceptT ErrorBallot_Answer) $
zipWithM (encryptAnswer election_publicKey zkp)
election_questions opinionsByQuest
ballot_signature <- case keysMay of
Nothing -> return Nothing
Just (secKey, signature_publicKey) -> do
signature_proof <-
prove secKey (Identity groupGen) $
\(Identity commitment) ->
hash
(signatureCommitments zkp 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 (fromString (show (natG 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
}
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 zkp) commitment =
"sig|"<>zkp<>"|"<>fromString (show (natG commitment))<>"|"
data ErrorBallot
= ErrorBallot_WrongNumberOfAnswers Natural Natural
| ErrorBallot_Answer ErrorAnswer
deriving (Eq,Show)