From 4891de0f870da262133c88501451323d9ca93d7a Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Mon, 5 Aug 2019 18:01:44 +0000 Subject: [PATCH 01/16] protocol: align {To,From}JSON on Belenios' schemas. --- hjugement-protocol/hjugement-protocol.cabal | 2 +- .../src/Voting/Protocol/Election.hs | 92 +++++++++++++++++-- .../src/Voting/Protocol/Tally.hs | 24 ++++- 3 files changed, 106 insertions(+), 12 deletions(-) diff --git a/hjugement-protocol/hjugement-protocol.cabal b/hjugement-protocol/hjugement-protocol.cabal index cd472c8..3c748f8 100644 --- a/hjugement-protocol/hjugement-protocol.cabal +++ b/hjugement-protocol/hjugement-protocol.cabal @@ -2,7 +2,7 @@ name: hjugement-protocol -- PVP: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.0.5.20190722 +version: 0.0.6.20190804 category: Politic synopsis: A cryptographic protocol for the Majority Judgment. description: diff --git a/hjugement-protocol/src/Voting/Protocol/Election.hs b/hjugement-protocol/src/Voting/Protocol/Election.hs index 0649c92..a31c43b 100644 --- a/hjugement-protocol/src/Voting/Protocol/Election.hs +++ b/hjugement-protocol/src/Voting/Protocol/Election.hs @@ -19,7 +19,8 @@ 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.Maybe (Maybe(..), maybe, fromJust) +import Data.Monoid (Monoid(..)) import Data.Ord (Ord(..)) import Data.Semigroup (Semigroup(..)) import Data.Text (Text) @@ -34,9 +35,8 @@ 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 qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Encoding as TL import Voting.Protocol.Utils import Voting.Protocol.FFC @@ -62,7 +62,17 @@ data Encryption c = Encryption -- ^ Encrypted 'clear' text, -- equal to @('pubKey' '^'encNone '*' 'groupGen' '^'clear)@ } deriving (Eq,Show,Generic,NFData) -deriving instance Reifies c FFC => ToJSON (Encryption c) +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" @@ -374,7 +384,29 @@ data Question = Question , question_mini :: !Natural , question_maxi :: !Natural -- , question_blank :: Maybe Bool - } deriving (Eq,Show,Generic,NFData,ToJSON,FromJSON) + } 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 @@ -386,7 +418,23 @@ data Answer c = Answer -- is an element of @[mini..maxi]@. -- , answer_blankProof :: } deriving (Eq,Show,Generic,NFData) -deriving instance Reifies c FFC => ToJSON (Answer c) +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" @@ -540,7 +588,7 @@ newtype Hash = Hash Text deriving newtype NFData hashJSON :: ToJSON a => a -> Hash -hashJSON = Hash . TL.toStrict . TL.decodeUtf8 . BSL64.encode . JSON.encode +hashJSON = Hash . hexHash . BSL.toStrict . BSL64.encode . JSON.encode hashElection :: Election c -> Election c hashElection elec = elec{election_hash=hashJSON elec} @@ -552,7 +600,21 @@ data Ballot c = Ballot , ballot_election_uuid :: !UUID , ballot_election_hash :: !Hash } deriving (Generic,NFData) -deriving instance Reifies c FFC => ToJSON (Ballot c) +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" @@ -640,7 +702,19 @@ data Signature c = Signature -- ^ Verification key. , signature_proof :: !(Proof c) } deriving (Generic,NFData) -deriving instance Reifies c FFC => ToJSON (Signature c) +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" diff --git a/hjugement-protocol/src/Voting/Protocol/Tally.hs b/hjugement-protocol/src/Voting/Protocol/Tally.hs index eef4515..5113155 100644 --- a/hjugement-protocol/src/Voting/Protocol/Tally.hs +++ b/hjugement-protocol/src/Voting/Protocol/Tally.hs @@ -47,8 +47,28 @@ data Tally c = Tally , tally_countByChoiceByQuest :: ![[Natural]] -- ^ The decrypted count of supportive 'Opinion's, by choice by 'Question'. } deriving (Eq,Show,Generic,NFData) -deriving instance Reifies c FFC => ToJSON (Tally c) -deriving instance Reifies c FFC => FromJSON (Tally c) +instance Reifies c FFC => ToJSON (Tally c) where + toJSON Tally{..} = + JSON.object + [ "num_tallied" .= tally_countMax + , "encrypted_tally" .= tally_encByChoiceByQuest + , "partial_decryptions" .= tally_decShareByTrustee + , "result" .= tally_countByChoiceByQuest + ] + toEncoding Tally{..} = + JSON.pairs + ( "num_tallied" .= tally_countMax + <> "encrypted_tally" .= tally_encByChoiceByQuest + <> "partial_decryptions" .= tally_decShareByTrustee + <> "result" .= tally_countByChoiceByQuest + ) +instance Reifies c FFC => FromJSON (Tally c) where + parseJSON = JSON.withObject "Tally" $ \o -> do + tally_countMax <- o .: "num_tallied" + tally_encByChoiceByQuest <- o .: "encrypted_tally" + tally_decShareByTrustee <- o .: "partial_decryptions" + tally_countByChoiceByQuest <- o .: "result" + return Tally{..} -- ** Type 'EncryptedTally' -- | 'Encryption' by choice by 'Question'. -- 2.44.1 From 937b8cba3f9f259b9d1c1f00157784a24556500b Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Mon, 5 Aug 2019 18:05:14 +0000 Subject: [PATCH 02/16] protocol: align Proof on Belenios' (slower) calculus --- hjugement-protocol/src/Voting/Protocol/Election.hs | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/hjugement-protocol/src/Voting/Protocol/Election.hs b/hjugement-protocol/src/Voting/Protocol/Election.hs index a31c43b..39ad160 100644 --- a/hjugement-protocol/src/Voting/Protocol/Election.hs +++ b/hjugement-protocol/src/Voting/Protocol/Election.hs @@ -219,7 +219,8 @@ prove sec commitmentBases oracle = do let proof_challenge = oracle commitments return Proof { proof_challenge - , proof_response = nonce - sec*proof_challenge + , proof_response = nonce + sec*proof_challenge + -- TODO: switch (+) to (-) when 'commit' will switch (/) to (*). } -- | @('fakeProof')@ returns a 'Proof' @@ -249,12 +250,12 @@ type Commitment = G -- 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 * + base^proof_response / basePowSec^proof_challenge - -- NOTE: Contrary to some textbook presentations, - -- @('*')@ is used instead of @('/')@ to avoid the performance cost + -- TODO: contrary to some textbook presentations, + -- @('*')@ should be used instead of @('/')@ to avoid the performance cost -- of a modular exponentiation @('^' ('groupOrder' '-' 'one'))@, - -- this is compensated by using @('-')@ instead of @('+')@ in 'prove'. + -- this would be compensated by using @('-')@ instead of @('+')@ in 'prove'. {-# INLINE commit #-} -- * Type 'Disjunction' -- 2.44.1 From 3362d31508a12a52169e22bdf5a41f53c21a9c07 Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Mon, 5 Aug 2019 18:08:31 +0000 Subject: [PATCH 03/16] protocol: add verification of trustees' public key --- hjugement-cli/hjugement-cli.cabal | 6 +++--- hjugement-cli/src/Hjugement/CLI/Administrator.hs | 4 ++++ 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/hjugement-cli/hjugement-cli.cabal b/hjugement-cli/hjugement-cli.cabal index 8b329f2..6ad5f2a 100644 --- a/hjugement-cli/hjugement-cli.cabal +++ b/hjugement-cli/hjugement-cli.cabal @@ -73,8 +73,8 @@ Executable hjugement -fno-warn-tabs -- -fhide-source-paths build-depends: - hjugement >= 2.0 - , hjugement-protocol >= 0.0.1 + hjugement >= 2.0.2 + , hjugement-protocol >= 0.0.6 , aeson >= 1.3 , base >= 4.6 && < 5 , base64-bytestring >= 1.0 @@ -97,7 +97,7 @@ Executable hjugement , pipes-text >= 0.0.2.5 , random >= 1.1 , reflection >= 2.1 - , symantic-cli >= 2.4 + , symantic-cli >= 2.4.1 , symantic-document >= 1.5 , terminal-size >= 0.3 , text >= 1.2 diff --git a/hjugement-cli/src/Hjugement/CLI/Administrator.hs b/hjugement-cli/src/Hjugement/CLI/Administrator.hs index 94a11a8..1def170 100644 --- a/hjugement-cli/src/Hjugement/CLI/Administrator.hs +++ b/hjugement-cli/src/Hjugement/CLI/Administrator.hs @@ -157,6 +157,10 @@ run_administrator_election let trusteeKeysPath = global_dir FP. "public_keys.jsons" trusteeKeys :: [VP.TrusteePublicKey c] <- runPipeWithError $ Pip.toListM' $ readJSON trusteeKeysPath + forM_ trusteeKeys $ \trusteeKey -> + case runExcept $ VP.verifyIndispensableTrusteePublicKey trusteeKey of + Left err -> outputError $ Doc.from (show err) + Right () -> return () let grades = List.nub administratorElection_grades unless (List.length grades > 1) $ outputError $ "at least two distinct grades are needed" -- 2.44.1 From 32f96a602e8a8c57ab8148944c491aeaadf5a8be Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Mon, 5 Aug 2019 18:11:04 +0000 Subject: [PATCH 04/16] protocol: join JSON stanzas with newlines to avoid a bug in belenios-tool MIME-Version: 1.0 Content-Type: text/plain; charset=utf8 Content-Transfer-Encoding: 8bit For instance, without newlines in public_keys.jsons, belenios-tool would only consider the first trustee's public key and silently drop the others… --- hjugement-cli/src/Hjugement/CLI/Utils.hs | 2 +- hjugement-cli/src/Hjugement/CLI/Voter.hs | 7 ++++--- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/hjugement-cli/src/Hjugement/CLI/Utils.hs b/hjugement-cli/src/Hjugement/CLI/Utils.hs index f68cd1a..e838f70 100644 --- a/hjugement-cli/src/Hjugement/CLI/Utils.hs +++ b/hjugement-cli/src/Hjugement/CLI/Utils.hs @@ -188,7 +188,7 @@ writeJSON fileMode filePath = Pip.bracket open close $ \h -> Pip.for Pip.cat $ \a -> Pip.liftIO $ do - BSL8.hPutStr h $ JSON.encode a + BSL8.hPutStrLn h $ JSON.encode a where open = Pip.liftIO $ do IO.createDirectoryIfMissing True $ FP.takeDirectory filePath diff --git a/hjugement-cli/src/Hjugement/CLI/Voter.hs b/hjugement-cli/src/Hjugement/CLI/Voter.hs index dfb17cd..1d38668 100644 --- a/hjugement-cli/src/Hjugement/CLI/Voter.hs +++ b/hjugement-cli/src/Hjugement/CLI/Voter.hs @@ -41,6 +41,7 @@ import qualified Data.ByteArray as ByteArray import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8 import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Lazy.Char8 as BSL8 import qualified Data.List as List import qualified Data.Text as Text import qualified Data.Text.Encoding as Text @@ -53,11 +54,11 @@ import qualified Data.Time as Time import qualified Lens.Family as Lens import qualified Lens.Family.State.Strict as Lens import qualified Pipes as Pip +import qualified Pipes.Aeson as PipJSON (DecodingError(..)) +import qualified Pipes.Aeson.Unchecked as PipJSON import qualified Pipes.ByteString as PipBS import qualified Pipes.Group as Pip import qualified Pipes.Prelude as Pip -import qualified Pipes.Aeson as PipJSON (DecodingError(..)) -import qualified Pipes.Aeson.Unchecked as PipJSON import qualified Pipes.Safe as Pip import qualified Pipes.Safe.Prelude as Pip import qualified Pipes.Text as PipText @@ -148,4 +149,4 @@ run_voter_vote VP.encryptBallot elec (Just secKey) votes of Left err -> (outputError $ Doc.from (show err), gen) Right (ballot, gen') -> (return ballot, gen') - Pip.liftIO $ BSL.putStrLn $ JSON.encode ballot + Pip.liftIO $ BSL8.putStrLn $ JSON.encode ballot -- 2.44.1 From d93dcc9c8616b722e7e6d3d94ee6077bf9f011f6 Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Wed, 14 Aug 2019 13:42:31 +0000 Subject: [PATCH 05/16] protocol: add command voter verify --- hjugement-cli/hjugement-cli.cabal | 2 +- .../src/Hjugement/CLI/Administrator.hs | 60 ++++++-- hjugement-cli/src/Hjugement/CLI/Registrar.hs | 23 +-- hjugement-cli/src/Hjugement/CLI/Trustee.hs | 35 ++--- hjugement-cli/src/Hjugement/CLI/Utils.hs | 133 +++++++++++++----- hjugement-cli/src/Hjugement/CLI/Voter.hs | 94 +++++++++++-- 6 files changed, 265 insertions(+), 82 deletions(-) diff --git a/hjugement-cli/hjugement-cli.cabal b/hjugement-cli/hjugement-cli.cabal index 6ad5f2a..3f1e1b3 100644 --- a/hjugement-cli/hjugement-cli.cabal +++ b/hjugement-cli/hjugement-cli.cabal @@ -97,7 +97,7 @@ Executable hjugement , pipes-text >= 0.0.2.5 , random >= 1.1 , reflection >= 2.1 - , symantic-cli >= 2.4.1 + , symantic-cli >= 2.4.2 , symantic-document >= 1.5 , terminal-size >= 0.3 , text >= 1.2 diff --git a/hjugement-cli/src/Hjugement/CLI/Administrator.hs b/hjugement-cli/src/Hjugement/CLI/Administrator.hs index 1def170..6346d32 100644 --- a/hjugement-cli/src/Hjugement/CLI/Administrator.hs +++ b/hjugement-cli/src/Hjugement/CLI/Administrator.hs @@ -7,6 +7,7 @@ module Hjugement.CLI.Administrator where import Control.Applicative (Applicative(..), Alternative(..)) import Control.Monad (Monad(..), forM, forM_, join, unless, void) import Control.Monad.Trans.Class (MonadTrans(..)) +import Control.Monad.Trans.Except (runExcept) import Control.Monad.Trans.Maybe (MaybeT(..)) import Control.Monad.Trans.State.Strict (runState, runStateT) import Data.Bits (setBit) @@ -80,9 +81,11 @@ api_administrator = `helps` command "administrator" $ api_administrator_election + api_administrator_tally api_help False run_administrator globParams = run_administrator_election globParams + :!: run_administrator_tally globParams :!: run_help api_administrator -- ** election @@ -143,34 +146,34 @@ api_administrator_election = var @Text "STRING" run_administrator_election - Global_Params{..} - o@AdministratorElection_Params{..} + glob@Global_Params{..} + AdministratorElection_Params{..} quests = - VP.reify administratorElection_crypto $ \(crypto::Proxy c) -> runMaybeT $ do + VP.reify administratorElection_crypto $ \(_crypto::Proxy c) -> runMaybeT $ do election_uuid <- case administratorElection_uuid of Nothing -> Pip.liftIO $ Rand.getStdRandom $ runState $ VP.randomUUID Just u -> case VP.readUUID u of - Left err -> outputError $ Doc.from (show err) + Left err -> outputError glob $ Doc.from (show err) Right uuid -> return uuid let trusteeKeysPath = global_dir FP. "public_keys.jsons" - trusteeKeys :: [VP.TrusteePublicKey c] <- runPipeWithError $ - Pip.toListM' $ readJSON trusteeKeysPath + trusteeKeys :: [VP.TrusteePublicKey c] <- runPipeWithError glob $ + Pip.toListM' $ readJSON glob trusteeKeysPath forM_ trusteeKeys $ \trusteeKey -> case runExcept $ VP.verifyIndispensableTrusteePublicKey trusteeKey of - Left err -> outputError $ Doc.from (show err) + Left err -> outputError glob $ Doc.from (show err) Right () -> return () let grades = List.nub administratorElection_grades unless (List.length grades > 1) $ - outputError $ "at least two distinct grades are needed" + outputError glob $ "at least two distinct grades are needed" unless (List.length grades == List.length administratorElection_grades) $ - outputError $ "indistinct grades: " <> + outputError glob $ "indistinct grades: " <> Doc.from (Text.intercalate ", " $ List.nub $ administratorElection_grades List.\\ grades) let defaultGrade = fromMaybe (grades List.!!0) administratorElection_defaultGrade -- FIXME: put defaultGrade into election.json - saveJSON (global_dir FP. "election.json") $ + saveJSON glob (global_dir FP. "election.json") $ VP.hashElection VP.Election { VP.election_name = administratorElection_name , VP.election_description = administratorElection_description @@ -187,4 +190,39 @@ run_administrator_election , VP.election_uuid , VP.election_hash = VP.hashJSON JSON.Null } - outputInfo $ "Created election with "<>Doc.from (show election_uuid) + outputInfo glob $ "created election with "<>Doc.from (show election_uuid) + +-- ** tally +api_administrator_tally = + "Tally an election using the decryption shares gathered from trustees\ + \ in "<>fileRef "partial_decryptions.jsons"<>".\ + \ The result is saved in "<>fileRef "result.json"<>".\n\ + \ It contains the decryption shares,\ + \ so "<>fileRef "partial_decryptions.jsons"<>" can be discarded afterwards." + `helps` + command "tally" $ + response @(Maybe ()) + +run_administrator_tally + glob@Global_Params{..} = runMaybeT $ do + rawElec <- loadJSON glob $ global_dir FP. "election.json" + VP.reifyElection rawElec $ \(_elec :: VP.Election c) -> do + keys <- runPipeWithError glob $ Pip.toListM' $ + readJSON glob $ global_dir FP. "public_keys.jsons" + decs <- runPipeWithError glob $ Pip.toListM' $ + readJSON glob $ global_dir FP. "partial_decryptions.jsons" + outputInfo glob $ "computing encrypted tally from ballots" + (encTally, numBallots) <- runPipeWithError glob $ + Pip.fold' + (flip VP.insertEncryptedTally) + VP.emptyEncryptedTally id $ + readJSON glob $ global_dir FP. "ballots.jsons" + outputInfo glob $ "decrypting tally using trustees' decryption shares" + case runExcept $ VP.proveTally + (encTally :: VP.EncryptedTally c, numBallots) decs + (VP.combineIndispensableDecryptionShares (VP.trustee_PublicKey <$> keys)) of + Left err -> outputError glob $ Doc.from (show err) + Right tally -> do + let resultPath = global_dir FP. "result.json" + saveJSON glob resultPath tally + outputInfo glob $ "tally generated in " <> Doc.from resultPath diff --git a/hjugement-cli/src/Hjugement/CLI/Registrar.hs b/hjugement-cli/src/Hjugement/CLI/Registrar.hs index 76d8aa0..9147a57 100644 --- a/hjugement-cli/src/Hjugement/CLI/Registrar.hs +++ b/hjugement-cli/src/Hjugement/CLI/Registrar.hs @@ -90,7 +90,10 @@ api_registrar_pubkey = command "pubkey" $ var "PRIVATE_CRED" <.> response @Natural -run_registrar_pubkey Global_Params{..} o@Registrar_Params{..} cred = +run_registrar_pubkey + Global_Params{..} + o@Registrar_Params{..} + cred = return $ VP.reify registrar_election_crypto $ \(_::Proxy c) -> VP.nat $ VP.publicKey $ @@ -122,18 +125,20 @@ api_registrar_credentials = var @IO.FilePath "FILE") <.> response @(Maybe ()) run_registrar_credentials - Global_Params{..} + glob@Global_Params{..} o@Registrar_Params{..} = run_count :!: run_file where - run_count count = + run_count count = do + outputInfo glob $ "generating credentials for "<>Doc.from count<>" voters" run_credentials $ let i0 = firstIdentity count in (Right <$>) $ Pip.each $ T.pack . show <$> [i0 .. (i0+count)`minusNatural`1] - run_file file = + run_file file = do + outputInfo glob $ "generating credentials for voters listed in "<>Doc.from file run_credentials $ let bytes = Pip.withFile file IO.ReadMode PipBS.fromHandle in let idents = @@ -141,11 +146,11 @@ run_registrar_credentials Lens.view (PipText.utf8 . PipText.eof) bytes in Pip.concats idents run_credentials identsProd = - VP.reify registrar_election_crypto $ \(crypto::Proxy c) -> runMaybeT $ do + VP.reify registrar_election_crypto $ \(_crypto::Proxy c) -> runMaybeT $ do now <- Pip.liftIO $ Time.getCurrentTime let timestamp = Time.formatTime Time.defaultTimeLocale "%s" now let baseFile = global_dir FP. timestamp - pubKeys <- runPipeWithError $ + pubKeys <- runPipeWithError glob $ ((left (\_p -> "UTF-8 decoding failed") <$>) <$>) $ Pip.toListM' $ identsProd @@ -157,7 +162,7 @@ run_registrar_credentials ) >-> Pip.tee ( Pip.map (\(ident, VP.Credential cred) -> [ident, " ", cred]) - >-> writeFileLn 0o400 (baseFile FP.<.>"privcreds") + >-> writeFileLn glob 0o400 (baseFile FP.<.>"privcreds") ) >-> Pip.mapM (\(ident, cred) -> let secKey = VP.credentialSecretKey @c registrar_election_uuid cred in @@ -167,7 +172,7 @@ run_registrar_credentials Pip.map (\(ident, pubKey) -> [ident, " ", VP.hexHash $ VP.bytesNat pubKey] ) - >-> writeFileLn 0o444 (baseFile FP.<.>"hashcreds") + >-> writeFileLn glob 0o444 (baseFile FP.<.>"hashcreds") ) >-> Pip.map (\(_ident, pubKey) -> pubKey) runPipe $ @@ -177,7 +182,7 @@ run_registrar_credentials -- the voters' identity and public key. -- Unfortunately this requires to accumulates all the pubKey in memory. >-> Pip.map (\pubKey -> [T.pack (show (VP.nat pubKey))]) - >-> writeFileLn 0o444 (baseFile FP.<.>"pubcreds") + >-> writeFileLn glob 0o444 (baseFile FP.<.>"pubcreds") return () -- | @('firstIdentity' numIdentities)@ returns @(10'^'i0)@ such that diff --git a/hjugement-cli/src/Hjugement/CLI/Trustee.hs b/hjugement-cli/src/Hjugement/CLI/Trustee.hs index 4435efd..1b06635 100644 --- a/hjugement-cli/src/Hjugement/CLI/Trustee.hs +++ b/hjugement-cli/src/Hjugement/CLI/Trustee.hs @@ -109,9 +109,9 @@ api_trustee_generate = command "generate" $ response @() run_trustee_generate - Global_Params{..} + glob@Global_Params{..} o@Trustee_Params{..} = - VP.reify trustee_crypto $ \(crypto::Proxy c) -> do + VP.reify trustee_crypto $ \(_crypto::Proxy c) -> do keys@(secKey, pubKey) <- Pip.liftIO $ Rand.getStdRandom $ runState $ do secKey <- VP.randomSecretKey @c pubKey <- VP.proveIndispensableTrusteePublicKey secKey @@ -121,12 +121,13 @@ run_trustee_generate VP.hexHash $ VP.bytesNat $ VP.trustee_PublicKey pubKey runPipe $ do - Pip.each [pubIdent] >-> pipeInfo (\ident -> - "Generated trustee keypair "<>ident<> + Pip.each [pubIdent] >-> pipeInfo glob (\ident -> + Doc.from $ + "generated trustee keypair "<>ident<> " in "<>(global_dir FP. ident)<>".{privkey,pubkey}" ) >-> Pip.drain - Pip.each [secKey] >-> writeJSON 0o400 (global_dir FP. pubIdent FP.<.>"privkey") - Pip.each [pubKey] >-> writeJSON 0o444 (global_dir FP. pubIdent FP.<.>"pubkey") + Pip.each [secKey] >-> writeJSON glob 0o400 (global_dir FP. pubIdent FP.<.>"privkey") + Pip.each [pubKey] >-> writeJSON glob 0o444 (global_dir FP. pubIdent FP.<.>"pubkey") return () -- ** decrypt @@ -151,27 +152,27 @@ api_trustee_decrypt = requiredTag "privkey" (var "FILE") run_trustee_decrypt - Global_Params{..} + glob@Global_Params{..} o@Trustee_Params{..} TrusteeDecrypt_Params{..} = - VP.reify trustee_crypto $ \(crypto::Proxy c) -> runMaybeT $ do - (secKey::VP.E c) <- loadJSON trusteeDecrypt_privkey + VP.reify trustee_crypto $ \(_crypto::Proxy c) -> runMaybeT $ do + (secKey::VP.E c) <- loadJSON glob trusteeDecrypt_privkey let pubKey = VP.publicKey secKey let trusteeKeysPath = trusteeDecrypt_url FP. "public_keys.jsons" - -- Check that the public key is amongst the public keys of the election - keys <- runPipeWithError $ + outputInfo glob "check that the public key is amongst the public keys of the election" + keys <- runPipeWithError glob $ Pip.toListM' $ - readJSON trusteeKeysPath + readJSON glob trusteeKeysPath >-> Pip.filter ((pubKey ==) . VP.trustee_PublicKey) case () of - () | null keys -> outputError $ + () | null keys -> outputError glob $ "the public key associated with the given secret key "<> "is not within the list of public trustee keys of the election.\n"<> Doc.ul [ "List of trustees' public keys: "<>Doc.from trusteeKeysPath , "Trustee's public key: "<>Doc.from (show (VP.nat pubKey)) ]<>"\n" - () | List.length keys > 1 -> outputError $ + () | List.length keys > 1 -> outputError glob $ "the public key associated with the given secret key "<> "appears more than one time in the list of public trustee keys of the election.\n"<> Doc.ul @@ -179,14 +180,14 @@ run_trustee_decrypt , "Trustee's public key: "<>Doc.from (show (VP.nat pubKey)) ]<>"\n" () -> do - -- Tally the encrypted ballots + outputInfo glob "tally the encrypted ballots" -- FIXME: actually support fetching through an URL let ballotsPath = trusteeDecrypt_url FP. "ballots.jsons" - (encTally, numBallots) <- runPipeWithError $ + (encTally, numBallots) <- runPipeWithError glob $ Pip.fold' (flip VP.insertEncryptedTally) VP.emptyEncryptedTally id $ - readJSON ballotsPath + readJSON glob ballotsPath decShare <- Pip.liftIO $ Rand.getStdRandom $ runState $ VP.proveDecryptionShare encTally secKey diff --git a/hjugement-cli/src/Hjugement/CLI/Utils.hs b/hjugement-cli/src/Hjugement/CLI/Utils.hs index e838f70..005dbcd 100644 --- a/hjugement-cli/src/Hjugement/CLI/Utils.hs +++ b/hjugement-cli/src/Hjugement/CLI/Utils.hs @@ -6,22 +6,24 @@ {-# OPTIONS_GHC -Wno-missing-signatures #-} module Hjugement.CLI.Utils where +import Control.Applicative (Applicative(..), Alternative(..)) import Control.Arrow (left) -import Control.Applicative (Alternative(..)) -import Control.Monad (Monad(..), forM_) +import Control.Monad (Monad(..), forM_, when) import Control.Monad.Trans.Maybe (MaybeT(..)) import Control.Monad.Trans.State.Strict (StateT(..), evalStateT) import Data.Bits (setBit) import Data.Bool import Data.ByteString (ByteString) import Data.Either (Either(..)) +import Data.Eq (Eq(..)) import Data.Foldable (Foldable) import Data.Function (($), (.), id) import Data.Functor ((<$>)) import Data.Maybe (Maybe(..), maybe) import Data.Monoid (Monoid(..)) -import Data.String (IsString(..)) +import Data.Ord (Ord(..)) import Data.Semigroup (Semigroup(..)) +import Data.String (IsString(..)) import Data.Text (Text) import Prelude (min, max, (-)) import Symantic.CLI as CLI @@ -58,6 +60,7 @@ import qualified System.Posix as Posix import qualified Voting.Protocol as VP ref = Doc.underline +con = Doc.between "\"" "\"" fileRef = ref helps = help . Doc.justify infixr 0 `helps` @@ -118,17 +121,23 @@ run_help lay = route :!: route runLayout helpInh_full lay -- * Type 'Global_Params' -data Global_Params = Global_Params - { global_dir :: IO.FilePath +data Global_Params + = Global_Params + { global_stderr_prepend_newline :: Bool + , global_stderr_prepend_carriage :: Bool + , global_stderr_append_newline :: Bool + , global_dir :: IO.FilePath + , global_verbosity :: Verbosity } api_options = rule "OPTIONS" $ - Global_Params + Global_Params False False True <$> api_param_dir + <*> api_param_verbosity api_param_dir = "Use directory "<>ref"DIR"<>" for reading and writing election files.\n"<> - "Default to "<>fileRef (Doc.from currDir)<>".\n"<> + "Default to "<>con (Doc.from currDir)<>".\n"<> "Can also be set via HJUGEMENT_DIR="<>ref "DIR"<>"." `help` toPermDefault currDir $ @@ -141,6 +150,36 @@ api_param_url = `helps` toPermutation $ tag "url" (var "URL") +-- * Type 'Verbosity' +data Verbosity + = Verbosity_Error + | Verbosity_Warning + | Verbosity_Info + | Verbosity_Debug + deriving (Eq,Ord) + +instance IOType Verbosity +instance FromSegment Verbosity where + fromSegment = \case + "error" -> return $ Right Verbosity_Error + "warning" -> return $ Right Verbosity_Warning + "info" -> return $ Right Verbosity_Info + "debug" -> return $ Right Verbosity_Debug + _ -> return $ Left "invalid verbosity" + +api_param_verbosity = + "Verbosity level.\ + \\nDefault to "<>con "info"<>"." + `help` + toPermDefault Verbosity_Info $ + tag "verbosity" ( + constant "error" Verbosity_Error `alt` + constant "warning" Verbosity_Warning `alt` + constant "info" Verbosity_Info `alt` + constant "debug" Verbosity_Debug + ) `alt` + env "HJUGEMENT_VERBOSITY" + -- * Pipes utilities runPipe :: Pip.MonadIO m => @@ -149,20 +188,23 @@ runPipe = Pip.liftIO . Pip.runSafeT . Pip.runEffect runPipeWithError :: Pip.MonadIO m => + Global_Params -> Pip.Effect (Pip.SafeT IO) (a, Either Doc ()) -> MaybeT m a -runPipeWithError p = do +runPipeWithError glob p = do (a, r) <- runPipe p case r of - Left err -> outputError err + Left err -> outputError glob err Right () -> return a writeFileLn :: Pip.MonadSafe m => Foldable f => + Global_Params -> Posix.FileMode -> IO.FilePath -> Pip.Consumer (f Text) m r -writeFileLn fileMode filePath = +writeFileLn glob fileMode filePath = do + Pip.liftIO $ outputDebug glob $ "writing " <> Doc.from filePath Pip.bracket open close $ \h -> Pip.for Pip.cat $ \xs -> Pip.liftIO $ do @@ -181,10 +223,12 @@ writeFileLn fileMode filePath = writeJSON :: Pip.MonadSafe m => JSON.ToJSON a => + Global_Params -> Posix.FileMode -> IO.FilePath -> Pip.Consumer a m r -writeJSON fileMode filePath = +writeJSON glob fileMode filePath = do + Pip.liftIO $ outputDebug glob $ "writing " <> Doc.from filePath Pip.bracket open close $ \h -> Pip.for Pip.cat $ \a -> Pip.liftIO $ do @@ -203,10 +247,12 @@ readJSON :: Pip.MonadSafe m => JSON.FromJSON a => JSON.ToJSON a => + Global_Params -> IO.FilePath -> Pip.Producer a m (Either Doc ()) -readJSON filePath = - let bytes = Pip.withFile filePath IO.ReadMode PipBS.fromHandle in +readJSON glob filePath = do + Pip.liftIO $ outputDebug glob $ "reading " <> Doc.from filePath + let bytes = Pip.withFile filePath IO.ReadMode PipBS.fromHandle left handleError <$> Lens.view PipJSON.decoded bytes where handleError (err, _rest) = @@ -223,18 +269,25 @@ readJSON filePath = saveJSON :: JSON.ToJSON a => Pip.MonadIO m => + Global_Params -> IO.FilePath -> a -> m () -saveJSON filePath a = +saveJSON glob filePath a = -- FIXME: abort or demand confirmation if the file exists - Pip.liftIO $ JSON.encodeFile filePath a + Pip.liftIO $ do + outputDebug glob $ "saving " <> Doc.from filePath + JSON.encodeFile filePath a loadJSON :: JSON.FromJSON a => Pip.MonadIO m => + Global_Params -> IO.FilePath -> MaybeT m a -loadJSON filePath = - Pip.liftIO (JSON.eitherDecodeFileStrict' filePath) >>= \case - Left err -> outputError $ +loadJSON glob filePath = + Pip.liftIO (do + outputDebug glob $ "loading " <> Doc.from filePath + JSON.eitherDecodeFileStrict' filePath + ) >>= \case + Left err -> outputError glob $ Doc.from filePath<>": "<> Doc.from err<>"\n" Right a -> return a @@ -282,24 +335,38 @@ parseMany f = go0 pipeInfo :: Pip.MonadIO m => - Outputable (OnHandle d) => - (a -> d) -> Pip.Pipe a a m r -pipeInfo d = + Global_Params -> + (a -> Doc) -> Pip.Pipe a a m r +pipeInfo glob d = Pip.for Pip.cat $ \s -> do - Pip.liftIO $ do - output $ OnHandle IO.stderr (d s) - output $ OnHandle IO.stderr '\n' + Pip.liftIO $ outputInfo glob $ d s Pip.yield s -outputInfo :: Pip.MonadIO m => Doc -> m () -outputInfo msg = do +outputMessage :: Pip.MonadIO m => Global_Params -> Doc -> Doc -> m () +outputMessage Global_Params{..} hdr msg = Pip.liftIO $ output $ OnHandle @Doc IO.stderr $ - Doc.green "INFO"<>": "<>msg<>"\n" + (if global_stderr_prepend_newline then Doc.newline else mempty) <> + (if global_stderr_prepend_carriage then "\r" else mempty) <> + hdr<>": "<>msg<> + (if global_stderr_append_newline then Doc.newline else mempty) -outputError :: - Pip.MonadIO m => - Doc -> MaybeT m a -outputError msg = do - Pip.liftIO $ output $ OnHandle @Doc IO.stderr $ - Doc.redder "ERROR"<>": "<>msg<>"\n" +outputError :: Pip.MonadIO m => Global_Params -> Doc -> MaybeT m a +outputError glob@Global_Params{..} msg = do + when (Verbosity_Error <= global_verbosity) $ do + outputMessage glob (Doc.redder "ERROR") msg empty + +outputWarning :: Pip.MonadIO m => Global_Params -> Doc -> m () +outputWarning glob@Global_Params{..} msg = do + when (Verbosity_Warning <= global_verbosity) $ do + outputMessage glob (Doc.yellower "WARNING") msg + +outputInfo :: Pip.MonadIO m => Global_Params -> Doc -> m () +outputInfo glob@Global_Params{..} msg = do + when (Verbosity_Info <= global_verbosity) $ do + outputMessage glob (Doc.greener "info") msg + +outputDebug :: Pip.MonadIO m => Global_Params -> Doc -> m () +outputDebug glob@Global_Params{..} msg = do + when (Verbosity_Debug <= global_verbosity) $ do + outputMessage glob (Doc.magentaer "debug") msg diff --git a/hjugement-cli/src/Hjugement/CLI/Voter.hs b/hjugement-cli/src/Hjugement/CLI/Voter.hs index 1d38668..50b80fc 100644 --- a/hjugement-cli/src/Hjugement/CLI/Voter.hs +++ b/hjugement-cli/src/Hjugement/CLI/Voter.hs @@ -65,6 +65,7 @@ import qualified Pipes.Text as PipText import qualified Pipes.Text.Encoding as PipText import qualified Pipes.Text.IO as PipText import qualified Symantic.Document as Doc +import qualified System.Directory as IO import qualified System.FilePath as FP import qualified System.IO as IO import qualified System.Posix as Posix @@ -84,12 +85,14 @@ api_voter = `helps` command "voter" $ api_voter_vote + api_voter_verify api_help False run_voter globParams = run_voter_vote globParams + :!: run_voter_verify globParams :!: run_help api_voter --- ** election +-- ** vote data VoterVote_Params = VoterVote_Params { voterVote_privcred :: VP.Credential , voterVote_url :: FilePath @@ -118,14 +121,13 @@ api_voter_vote = var @Text "STRING" run_voter_vote - Global_Params{..} - o@VoterVote_Params{..} - = runMaybeT $ do - elecUnit <- loadJSON (voterVote_url FP. "election.json") - VP.reifyElection elecUnit $ \(elec@VP.Election{..} :: VP.Election c) -> do - outputInfo $ "Voted"<>Doc.from (show voterVote_grades) + glob@Global_Params{..} + o@VoterVote_Params{..} = runMaybeT $ do + rawElec <- loadJSON glob $ voterVote_url FP. "election.json" + VP.reifyElection rawElec $ \(elec@VP.Election{..} :: VP.Election c) -> do + outputInfo glob $ "Voted"<>Doc.from (show voterVote_grades) votes <- VP.isoZipWithM - (outputError $ "Mismatching number of cast grades ("<> + (outputError glob $ "Mismatching number of cast grades ("<> Doc.from (List.length voterVote_grades)<> ") and choices ("<> Doc.from (List.length election_questions)<> @@ -134,19 +136,89 @@ run_voter_vote let bools = (grade ==) <$> question_choices let boolSum = sum $ (<$> bools) $ \b -> if b then 1 else 0 :: Natural unless (boolSum == 1) $ - outputError $ + outputError glob $ "The election does not allow to cast a grade named: "<>Doc.from grade<>"\n"<> "Allowed grades are: "<>Doc.from (Text.intercalate ", " question_choices) return bools) election_questions voterVote_grades - outputInfo $ Doc.from (show votes) + outputInfo glob $ Doc.from (show votes) let (secKey :: VP.SecretKey c) = VP.credentialSecretKey election_uuid voterVote_privcred ballot <- join $ Pip.liftIO $ Rand.getStdRandom $ \gen -> case runExcept $ (`runStateT` gen) $ VP.encryptBallot elec (Just secKey) votes of - Left err -> (outputError $ Doc.from (show err), gen) + Left err -> (outputError glob $ Doc.from (show err), gen) Right (ballot, gen') -> (return ballot, gen') Pip.liftIO $ BSL8.putStrLn $ JSON.encode ballot + +-- ** verify +data VoterVerify_Params = VoterVerify_Params + { voterVerify_url :: FilePath + } deriving (Show) + +api_voter_verify = + "Cast a vote on an election." + `helps` + command "verify" $ + rule "PARAMS" + (VoterVerify_Params + <$> api_param_url) + response @(Maybe ()) + +run_voter_verify + glob@Global_Params{..} + o@VoterVerify_Params{..} = runMaybeT $ do + rawElec <- loadJSON glob $ voterVerify_url FP. "election.json" + VP.reifyElection rawElec $ \(elec@VP.Election{..} :: VP.Election c) -> do + outputInfo glob $ "verifying ballots" + (fails :: Natural, (encTally :: VP.EncryptedTally c, numBallots)) <- runPipeWithError glob $ + Pip.foldM' + (\(fails, acc@(_, numBallots)) ballot@VP.Ballot{..} -> do + let ballotNum = numBallots + fails + outputDebug glob + { global_stderr_prepend_carriage = True + , global_stderr_append_newline = False + } $ + "checking ballot #"<>Doc.from ballotNum + let globError = glob{global_stderr_prepend_newline = Verbosity_Debug <= global_verbosity} + case ballot_signature of + Nothing -> do + void $ runMaybeT $ outputError globError $ + "ballot #"<>Doc.from ballotNum<>" has no signature" + return (fails+1, acc) + Just{} -> + if VP.verifyBallot elec ballot + then return (fails, VP.insertEncryptedTally ballot acc) + else do + void $ runMaybeT $ outputError globError $ + "ballot #"<>Doc.from ballotNum<>" has an invalid signature" + return (fails+1, acc) + ) + (return (0, VP.emptyEncryptedTally)) + return $ + readJSON glob $ voterVerify_url FP. "ballots.jsons" + when (Verbosity_Debug <= global_verbosity) $ + Pip.liftIO $ output $ OnHandle IO.stderr (Doc.newline::String) + when (0 < fails) empty + let resultPath = voterVerify_url FP. "result.json" + hasResult <- Pip.liftIO $ IO.doesPathExist resultPath + if not hasResult + then do + outputWarning glob "no tally to check" + else do + tally :: VP.Tally c <- loadJSON glob resultPath + outputInfo glob $ "decrypting tally using trustees' decryption shares" + trustees <- runPipeWithError glob $ Pip.toListM' $ + readJSON glob $ voterVerify_url FP. "public_keys.jsons" + let trustPubKeys = VP.trustee_PublicKey <$> trustees + decs <- runPipeWithError glob $ Pip.toListM' $ + readJSON glob $ voterVerify_url FP. "partial_decryptions.jsons" + outputInfo glob $ "verifying tally" + case runExcept $ do + VP.verifyDecryptionShareByTrustee encTally trustPubKeys decs + VP.verifyTally tally (VP.combineIndispensableDecryptionShares trustPubKeys) + of + Left err -> outputError glob $ Doc.from (show err) + Right () -> return () -- 2.44.1 From 7dbeee8dcc0e308784af17d071c9585450de026a Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Thu, 15 Aug 2019 21:36:00 +0000 Subject: [PATCH 06/16] protocol: fix election_hash --- hjugement-protocol/benchmarks/Election.hs | 33 ++++++------ .../src/Voting/Protocol/Election.hs | 33 ++++++------ hjugement-protocol/src/Voting/Protocol/FFC.hs | 50 +++++++++++++++---- hjugement-protocol/tests/HUnit/Election.hs | 3 +- .../tests/QuickCheck/Election.hs | 9 ++-- 5 files changed, 81 insertions(+), 47 deletions(-) diff --git a/hjugement-protocol/benchmarks/Election.hs b/hjugement-protocol/benchmarks/Election.hs index c51b40d..10dc7bc 100644 --- a/hjugement-protocol/benchmarks/Election.hs +++ b/hjugement-protocol/benchmarks/Election.hs @@ -9,22 +9,25 @@ import Voting.Protocol import Utils makeElection :: forall c. Reifies c FFC => Int -> Int -> Election c -makeElection nQuests nChoices = hashElection $ Election - { election_name = Text.pack $ "elec"<>show nQuests<>show nChoices - , election_description = "benchmarkable election" - , election_uuid - , election_crypto = ElectionCrypto_FFC (reflect (Proxy::Proxy c)) $ - let secKey = credentialSecretKey election_uuid (Credential "xLcs7ev6Jy6FHHE") in - publicKey secKey - , election_hash = Hash "" - , election_questions = - (<$> [1..nQuests]) $ \quest -> Question - { question_text = Text.pack $ "quest"<>show quest - , question_choices = (<$> [1..nChoices]) $ \choice -> Text.pack $ "choice"<>show choice - , question_mini = one - , question_maxi = one -- sum $ List.replicate nChoices one +makeElection nQuests nChoices = elec + where + election_uuid = UUID "xLcs7ev6Jy6FHH" + elec = Election + { election_name = Text.pack $ "elec"<>show nQuests<>show nChoices + , election_description = "benchmarkable election" + , election_uuid + , election_crypto = ElectionCrypto_FFC (reflect (Proxy::Proxy c)) $ + let secKey = credentialSecretKey election_uuid (Credential "xLcs7ev6Jy6FHHE") in + publicKey secKey + , election_hash = hashElection elec + , election_questions = + (<$> [1..nQuests]) $ \quest -> Question + { question_text = Text.pack $ "quest"<>show quest + , question_choices = (<$> [1..nChoices]) $ \choice -> Text.pack $ "choice"<>show choice + , question_mini = one + , question_maxi = one -- sum $ List.replicate nChoices one + } } - } where election_uuid = UUID "xLcs7ev6Jy6FHH" makeVotes :: Election c -> [[Bool]] makeVotes Election{..} = diff --git a/hjugement-protocol/src/Voting/Protocol/Election.hs b/hjugement-protocol/src/Voting/Protocol/Election.hs index 39ad160..1dc16db 100644 --- a/hjugement-protocol/src/Voting/Protocol/Election.hs +++ b/hjugement-protocol/src/Voting/Protocol/Election.hs @@ -10,7 +10,7 @@ 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 Control.Monad.Trans.Except (ExceptT(..), runExcept, throwE, withExceptT) import Data.Aeson (ToJSON(..),FromJSON(..),(.:),(.:?),(.=)) import Data.Bool import Data.Either (either) @@ -23,6 +23,7 @@ import Data.Maybe (Maybe(..), maybe, fromJust) import Data.Monoid (Monoid(..)) import Data.Ord (Ord(..)) import Data.Semigroup (Semigroup(..)) +import Data.String (String) import Data.Text (Text) import Data.Traversable (Traversable(..)) import Data.Tuple (fst, snd) @@ -30,11 +31,11 @@ import GHC.Generics (Generic) import GHC.Natural (minusNaturalMaybe) import Numeric.Natural (Natural) import Prelude (fromIntegral) +import System.IO (IO, FilePath) 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 @@ -548,7 +549,18 @@ instance FromJSON (Election ()) where <*> o .: "public_key" <*> o .: "questions" <*> o .: "uuid" - <*> pure (hashJSON (JSON.Object o)) + <*> pure (Base64SHA256 "") + -- NOTE: set in 'readElection'. + +readElection :: FilePath -> ExceptT String IO (Election ()) +readElection filePath = do + fileData <- lift $ BS.readFile filePath + ExceptT $ return $ + (\e -> e{election_hash=base64SHA256 fileData}) + <$> JSON.eitherDecodeStrict' fileData + +hashElection :: Election c -> Base64SHA256 +hashElection = base64SHA256 . BSL.toStrict . JSON.encode -- ** Type 'ElectionCrypto' data ElectionCrypto c = @@ -581,25 +593,12 @@ instance FromJSON (ElectionCrypto ()) where 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 + , ballot_election_hash :: !Base64SHA256 } deriving (Generic,NFData) instance Reifies c FFC => ToJSON (Ballot c) where toJSON Ballot{..} = diff --git a/hjugement-protocol/src/Voting/Protocol/FFC.hs b/hjugement-protocol/src/Voting/Protocol/FFC.hs index bb00fb3..d9982f8 100644 --- a/hjugement-protocol/src/Voting/Protocol/FFC.hs +++ b/hjugement-protocol/src/Voting/Protocol/FFC.hs @@ -47,9 +47,11 @@ import qualified Data.Aeson as JSON import qualified Data.Aeson.Types as JSON import qualified Data.ByteArray as ByteArray import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64 as BS64 import qualified Data.Char as Char import qualified Data.List as List import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Builder as TLB import qualified Data.Text.Lazy.Builder.Int as TLB @@ -316,6 +318,11 @@ groupGenPowers :: forall c. Reifies c FFC => [G c] groupGenPowers = go one where go g = g : go (g * groupGen @c) +-- ** Type 'Hash' +newtype Hash c = Hash (E c) + deriving (Eq,Ord,Show) + deriving newtype NFData + -- | @('hash' bs gs)@ returns as a number in 'E' -- the 'Crypto.SHA256' hash of the given 'BS.ByteString' 'bs' -- prefixing the decimal representation of given subgroup elements 'gs', @@ -334,14 +341,44 @@ hash bs gs = do fromNatural $ decodeBigEndian $ ByteArray.convert h --- | @('hexHash' bs)@ returns the 'Crypto.SHA256' hash +-- | @('decodeBigEndian' bs)@ interpret @bs@ as big-endian number. +decodeBigEndian :: BS.ByteString -> Natural +decodeBigEndian = + BS.foldl' + (\acc b -> acc`shiftL`8 + fromIntegral b) + (0::Natural) + +-- ** Type 'Base64SHA256' +newtype Base64SHA256 = Base64SHA256 Text + deriving (Eq,Ord,Show,Generic) + deriving anyclass (ToJSON,FromJSON) + deriving newtype NFData + +-- | @('base64SHA256' bs)@ returns the 'Crypto.SHA256' hash +-- of the given 'BS.ByteString' 'bs', +-- as a 'Text' escaped in @base64@ encoding +-- (). +base64SHA256 :: BS.ByteString -> Base64SHA256 +base64SHA256 bs = + let h = Crypto.hashWith Crypto.SHA256 bs in + Base64SHA256 $ + Text.takeWhile (/= '=') $ + -- TODO: to be removed when Belenios will expect padding. + Text.decodeUtf8 $ BS64.encode $ ByteArray.convert h + +-- ** Type 'HexSHA256' +newtype HexSHA256 = HexSHA256 Text + deriving (Eq,Ord,Show,Generic) + deriving anyclass (ToJSON,FromJSON) + deriving newtype NFData +-- | @('hexSHA256' bs)@ returns the 'Crypto.SHA256' hash -- of the given 'BS.ByteString' 'bs', escaped in hexadecimal -- into a 'Text' of 32 lowercase characters. -- -- Used (in retro-dependencies of this library) to hash -- the 'PublicKey' of a voter or a trustee. -hexHash :: BS.ByteString -> Text -hexHash bs = +hexSHA256 :: BS.ByteString -> Text +hexSHA256 bs = let h = Crypto.hashWith Crypto.SHA256 bs in let n = decodeBigEndian $ ByteArray.convert h in -- NOTE: always set the 256 bit then remove it @@ -351,13 +388,6 @@ hexHash bs = TL.tail $ TLB.toLazyText $ TLB.hexadecimal $ setBit n 256 --- | @('decodeBigEndian' bs)@ interpret @bs@ as big-endian number. -decodeBigEndian :: BS.ByteString -> Natural -decodeBigEndian = - BS.foldl' - (\acc b -> acc`shiftL`8 + fromIntegral b) - (0::Natural) - -- * Type 'E' -- | An exponent of a (necessarily cyclic) subgroup of a Finite Prime Field. -- The value is always in @[0..'groupOrder'-1]@. diff --git a/hjugement-protocol/tests/HUnit/Election.hs b/hjugement-protocol/tests/HUnit/Election.hs index 5e193eb..a2f583b 100644 --- a/hjugement-protocol/tests/HUnit/Election.hs +++ b/hjugement-protocol/tests/HUnit/Election.hs @@ -4,7 +4,6 @@ module HUnit.Election where import Test.Tasty.HUnit -import qualified Data.Aeson as JSON import qualified Data.List as List import qualified Data.Text as Text import qualified System.Random as Random @@ -94,7 +93,7 @@ testEncryptBallot ffc seed quests opins exp = , election_crypto = ElectionCrypto_FFC ffc elecPubKey , election_questions = quests , election_uuid = uuid - , election_hash = hashJSON JSON.Null + , election_hash = hashElection elec } verifyBallot elec <$> encryptBallot elec (Just ballotSecKey) opins diff --git a/hjugement-protocol/tests/QuickCheck/Election.hs b/hjugement-protocol/tests/QuickCheck/Election.hs index 5bd09df..bb7a43e 100644 --- a/hjugement-protocol/tests/QuickCheck/Election.hs +++ b/hjugement-protocol/tests/QuickCheck/Election.hs @@ -10,7 +10,6 @@ import Data.Ord (Ord(..)) import GHC.Natural (minusNaturalMaybe) import Prelude (undefined) import Test.Tasty.QuickCheck -import qualified Data.Aeson as JSON import qualified Data.List as List import qualified Data.Text as Text @@ -86,8 +85,12 @@ instance Reifies c FFC => Arbitrary (Election c) where election_crypto <- arbitrary election_questions <- resize (fromIntegral maxArbitraryQuestions) $ listOf1 arbitrary election_uuid <- arbitrary - let election_hash = hashJSON JSON.Null - return Election{..} + let elec = + Election + { election_hash = hashElection elec + , .. + } + return elec shrink elec = [ elec{election_questions} | election_questions <- shrink $ election_questions elec -- 2.44.1 From 03f62f6c71f35207c421ae002e5575adf588e65f Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Thu, 15 Aug 2019 21:42:17 +0000 Subject: [PATCH 07/16] protocol: fix {encryt,verify}Ballot wrt. specs --- .../src/Voting/Protocol/Election.hs | 28 +++++++++++++++++-- 1 file changed, 25 insertions(+), 3 deletions(-) diff --git a/hjugement-protocol/src/Voting/Protocol/Election.hs b/hjugement-protocol/src/Voting/Protocol/Election.hs index 1dc16db..740a471 100644 --- a/hjugement-protocol/src/Voting/Protocol/Election.hs +++ b/hjugement-protocol/src/Voting/Protocol/Election.hs @@ -224,6 +224,21 @@ prove sec commitmentBases oracle = do -- TODO: switch (+) to (-) when 'commit' will switch (/) to (*). } +-- | Like 'prove' but quicker. It chould replace 'prove' entirely +-- when Helios-C specifications will be fixed. +proveQuicker :: + Reifies c FFC => + Monad m => RandomGen r => Functor list => + E c -> list (G c) -> Oracle list c -> S.StateT r m (Proof c) +proveQuicker 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')@ returns a 'Proof' -- whose 'proof_challenge' and 'proof_response' are uniformly chosen at random, -- instead of @('proof_challenge' '==' 'hash' statement commitments)@ @@ -259,6 +274,13 @@ commit Proof{..} base basePowSec = -- this would be compensated by using @('-')@ instead of @('+')@ in 'prove'. {-# INLINE commit #-} +-- | Like 'commit' but quicker. It chould replace 'commit' entirely +-- when Helios-C specifications will be fixed. +commitQuicker :: Reifies c FFC => Proof c -> G c -> G c -> Commitment c +commitQuicker Proof{..} base basePowSec = + base^proof_response * + basePowSec^proof_challenge + -- * Type 'Disjunction' -- | A 'Disjunction' is an 'inv'ersed @('groupGen' '^'opinion)@ -- it's used in 'proveEncryption' to generate a 'Proof' @@ -522,7 +544,7 @@ data Election c = Election , election_crypto :: !(ElectionCrypto c) , election_questions :: ![Question] , election_uuid :: !UUID - , election_hash :: !Hash + , election_hash :: Base64SHA256 } deriving (Eq,Show,Generic,NFData) instance ToJSON (Election c) where @@ -655,7 +677,7 @@ encryptBallot Election{..} ballotSecKeyMay opinionsByQuest Nothing -> return Nothing Just (ballotSecKey, signature_publicKey) -> do signature_proof <- - prove ballotSecKey (Identity groupGen) $ + proveQuicker ballotSecKey (Identity groupGen) $ \(Identity commitment) -> hash -- NOTE: the order is unusual, the commitments are first @@ -684,7 +706,7 @@ verifyBallot Election{..} Ballot{..} = let zkp = ZKP (bytesNat signature_publicKey) in (, zkp) $ proof_challenge signature_proof == hash - (signatureCommitments zkp (commit signature_proof groupGen signature_publicKey)) + (signatureCommitments zkp (commitQuicker signature_proof groupGen signature_publicKey)) (signatureStatement ballot_answers) in and $ isValidSign : -- 2.44.1 From 2b172054d9b07a2747117e94b16789c032baeef0 Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Thu, 15 Aug 2019 21:45:35 +0000 Subject: [PATCH 08/16] cli: use readElection to fix election_hash --- .../src/Hjugement/CLI/Administrator.hs | 17 +++++++++++------ hjugement-cli/src/Hjugement/CLI/Registrar.hs | 2 +- hjugement-cli/src/Hjugement/CLI/Trustee.hs | 2 +- hjugement-cli/src/Hjugement/CLI/Utils.hs | 15 +++++++++++++++ hjugement-cli/src/Hjugement/CLI/Voter.hs | 4 ++-- 5 files changed, 30 insertions(+), 10 deletions(-) diff --git a/hjugement-cli/src/Hjugement/CLI/Administrator.hs b/hjugement-cli/src/Hjugement/CLI/Administrator.hs index 6346d32..0fee229 100644 --- a/hjugement-cli/src/Hjugement/CLI/Administrator.hs +++ b/hjugement-cli/src/Hjugement/CLI/Administrator.hs @@ -171,10 +171,12 @@ run_administrator_election outputError glob $ "indistinct grades: " <> Doc.from (Text.intercalate ", " $ List.nub $ administratorElection_grades List.\\ grades) - let defaultGrade = fromMaybe (grades List.!!0) administratorElection_defaultGrade + let defaultGrade = + fromMaybe (grades List.!!0) + administratorElection_defaultGrade -- FIXME: put defaultGrade into election.json - saveJSON glob (global_dir FP. "election.json") $ - VP.hashElection VP.Election + let elec = + VP.Election { VP.election_name = administratorElection_name , VP.election_description = administratorElection_description , VP.election_crypto = VP.ElectionCrypto_FFC @@ -188,9 +190,12 @@ run_administrator_election , question_maxi = 1 } , VP.election_uuid - , VP.election_hash = VP.hashJSON JSON.Null + , VP.election_hash = VP.Base64SHA256 "" } - outputInfo glob $ "created election with "<>Doc.from (show election_uuid) + saveJSON glob (global_dir FP. "election.json") elec + outputInfo glob $ + "created election with "<>Doc.from (show election_uuid)<> + " and "<>Doc.from (show (VP.base64SHA256 (BSL.toStrict (JSON.encode elec)))) -- ** tally api_administrator_tally = @@ -205,7 +210,7 @@ api_administrator_tally = run_administrator_tally glob@Global_Params{..} = runMaybeT $ do - rawElec <- loadJSON glob $ global_dir FP. "election.json" + rawElec <- loadElection glob $ global_dir FP. "election.json" VP.reifyElection rawElec $ \(_elec :: VP.Election c) -> do keys <- runPipeWithError glob $ Pip.toListM' $ readJSON glob $ global_dir FP. "public_keys.jsons" diff --git a/hjugement-cli/src/Hjugement/CLI/Registrar.hs b/hjugement-cli/src/Hjugement/CLI/Registrar.hs index 9147a57..51df1be 100644 --- a/hjugement-cli/src/Hjugement/CLI/Registrar.hs +++ b/hjugement-cli/src/Hjugement/CLI/Registrar.hs @@ -170,7 +170,7 @@ run_registrar_credentials return (ident, pubKey)) >-> Pip.tee ( Pip.map (\(ident, pubKey) -> - [ident, " ", VP.hexHash $ VP.bytesNat pubKey] + [ident, " ", VP.hexSHA256 $ VP.bytesNat pubKey] ) >-> writeFileLn glob 0o444 (baseFile FP.<.>"hashcreds") ) diff --git a/hjugement-cli/src/Hjugement/CLI/Trustee.hs b/hjugement-cli/src/Hjugement/CLI/Trustee.hs index 1b06635..a0701af 100644 --- a/hjugement-cli/src/Hjugement/CLI/Trustee.hs +++ b/hjugement-cli/src/Hjugement/CLI/Trustee.hs @@ -118,7 +118,7 @@ run_trustee_generate return (secKey, pubKey) let pubIdent = T.unpack $ T.toUpper $ T.take 8 $ - VP.hexHash $ VP.bytesNat $ + VP.hexSHA256 $ VP.bytesNat $ VP.trustee_PublicKey pubKey runPipe $ do Pip.each [pubIdent] >-> pipeInfo glob (\ident -> diff --git a/hjugement-cli/src/Hjugement/CLI/Utils.hs b/hjugement-cli/src/Hjugement/CLI/Utils.hs index 005dbcd..657f1dd 100644 --- a/hjugement-cli/src/Hjugement/CLI/Utils.hs +++ b/hjugement-cli/src/Hjugement/CLI/Utils.hs @@ -10,6 +10,7 @@ import Control.Applicative (Applicative(..), Alternative(..)) import Control.Arrow (left) import Control.Monad (Monad(..), forM_, when) import Control.Monad.Trans.Maybe (MaybeT(..)) +import Control.Monad.Trans.Except (ExceptT, runExceptT) import Control.Monad.Trans.State.Strict (StateT(..), evalStateT) import Data.Bits (setBit) import Data.Bool @@ -292,6 +293,20 @@ loadJSON glob filePath = Doc.from err<>"\n" Right a -> return a +loadElection :: + Pip.MonadIO m => + Global_Params -> + IO.FilePath -> MaybeT m (VP.Election ()) +loadElection glob filePath = + Pip.liftIO ( do + outputDebug glob $ "loading " <> Doc.from filePath + runExceptT $ VP.readElection filePath + ) >>= \case + Left err -> outputError glob $ + Doc.from filePath<>": "<> + Doc.from err<>"\n" + Right a -> return a + {- readJSON' :: Pip.MonadSafe m => diff --git a/hjugement-cli/src/Hjugement/CLI/Voter.hs b/hjugement-cli/src/Hjugement/CLI/Voter.hs index 50b80fc..f50f1a0 100644 --- a/hjugement-cli/src/Hjugement/CLI/Voter.hs +++ b/hjugement-cli/src/Hjugement/CLI/Voter.hs @@ -123,7 +123,7 @@ api_voter_vote = run_voter_vote glob@Global_Params{..} o@VoterVote_Params{..} = runMaybeT $ do - rawElec <- loadJSON glob $ voterVote_url FP. "election.json" + rawElec <- loadElection glob $ voterVote_url FP. "election.json" VP.reifyElection rawElec $ \(elec@VP.Election{..} :: VP.Election c) -> do outputInfo glob $ "Voted"<>Doc.from (show voterVote_grades) votes <- VP.isoZipWithM @@ -170,7 +170,7 @@ api_voter_verify = run_voter_verify glob@Global_Params{..} o@VoterVerify_Params{..} = runMaybeT $ do - rawElec <- loadJSON glob $ voterVerify_url FP. "election.json" + rawElec <- loadElection glob $ voterVerify_url FP. "election.json" VP.reifyElection rawElec $ \(elec@VP.Election{..} :: VP.Election c) -> do outputInfo glob $ "verifying ballots" (fails :: Natural, (encTally :: VP.EncryptedTally c, numBallots)) <- runPipeWithError glob $ -- 2.44.1 From dc6c87d030755f3599a9d57066d3dbea570ea794 Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Thu, 15 Aug 2019 21:51:59 +0000 Subject: [PATCH 09/16] protocol: bump versions --- hjugement-cli/hjugement-cli.cabal | 4 ++-- hjugement-protocol/hjugement-protocol.cabal | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/hjugement-cli/hjugement-cli.cabal b/hjugement-cli/hjugement-cli.cabal index 3f1e1b3..adc6411 100644 --- a/hjugement-cli/hjugement-cli.cabal +++ b/hjugement-cli/hjugement-cli.cabal @@ -2,7 +2,7 @@ name: hjugement-cli -- PVP: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.0.0.20190721 +version: 0.0.0.20190815 category: Politic synopsis: Majority Judgment and Helios-C command line tool description: @@ -74,7 +74,7 @@ Executable hjugement -- -fhide-source-paths build-depends: hjugement >= 2.0.2 - , hjugement-protocol >= 0.0.6 + , hjugement-protocol >= 0.0.7 , aeson >= 1.3 , base >= 4.6 && < 5 , base64-bytestring >= 1.0 diff --git a/hjugement-protocol/hjugement-protocol.cabal b/hjugement-protocol/hjugement-protocol.cabal index 3c748f8..8976176 100644 --- a/hjugement-protocol/hjugement-protocol.cabal +++ b/hjugement-protocol/hjugement-protocol.cabal @@ -2,7 +2,7 @@ name: hjugement-protocol -- PVP: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.0.6.20190804 +version: 0.0.7.20190815 category: Politic synopsis: A cryptographic protocol for the Majority Judgment. description: -- 2.44.1 From 88c87f840e3c3531e8de7d702357c44a6c92f224 Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Thu, 15 Aug 2019 22:32:53 +0000 Subject: [PATCH 10/16] protocol: polish imports --- HLint.hs | 1 + hjugement-cli/src/Hjugement/CLI.hs | 17 +----- .../src/Hjugement/CLI/Administrator.hs | 49 ++------------- hjugement-cli/src/Hjugement/CLI/Registrar.hs | 33 +++------- hjugement-cli/src/Hjugement/CLI/Trustee.hs | 56 +++-------------- hjugement-cli/src/Hjugement/CLI/Utils.hs | 23 ++----- hjugement-cli/src/Hjugement/CLI/Voter.hs | 61 +++++-------------- 7 files changed, 45 insertions(+), 195 deletions(-) diff --git a/HLint.hs b/HLint.hs index 4650cf3..9c3e1bf 100644 --- a/HLint.hs +++ b/HLint.hs @@ -2,6 +2,7 @@ import "hint" HLint.HLint ignore "Move brackets to avoid $" ignore "Reduce duplication" ignore "Redundant $" +ignore "Redundant do" ignore "Use camelCase" ignore "Use import/export shortcut" ignore "Use tuple-section" diff --git a/hjugement-cli/src/Hjugement/CLI.hs b/hjugement-cli/src/Hjugement/CLI.hs index 99f4bae..e041b4d 100644 --- a/hjugement-cli/src/Hjugement/CLI.hs +++ b/hjugement-cli/src/Hjugement/CLI.hs @@ -6,32 +6,17 @@ {-# OPTIONS_GHC -Wno-missing-signatures #-} module Hjugement.CLI where -import Control.Applicative (Applicative(..), Alternative(..)) import Control.Monad (Monad(..)) import Data.Bool -import Data.Either (Either(..)) -import Data.Function (($), (.)) -import Data.Functor ((<$>), (<$)) -import Data.Int (Int) -import Data.List.NonEmpty (NonEmpty(..)) -import Data.Maybe (Maybe(..), fromMaybe) -import Data.Ord (Ord(..)) +import Data.Function (($)) import Data.Semigroup (Semigroup(..)) -import Data.String (String) import Data.Text (Text) import Data.Void (Void) import Symantic.CLI as CLI -import System.Environment (getArgs) -import System.IO (IO, FilePath, print, stderr, putStrLn) -import Text.Show (Show(..)) -import Type.Reflection (Typeable) -import qualified Data.Set as Set import qualified Data.Text as Text -import qualified Data.Text.Lazy.IO as TL import qualified Data.Version as Version import qualified Paths_hjugement_cli as Hjugement import qualified Symantic.Document as Doc -import qualified System.IO as IO import Hjugement.CLI.Utils import Hjugement.CLI.Administrator diff --git a/hjugement-cli/src/Hjugement/CLI/Administrator.hs b/hjugement-cli/src/Hjugement/CLI/Administrator.hs index 0fee229..c82007e 100644 --- a/hjugement-cli/src/Hjugement/CLI/Administrator.hs +++ b/hjugement-cli/src/Hjugement/CLI/Administrator.hs @@ -4,68 +4,31 @@ {-# OPTIONS_GHC -Wno-missing-signatures #-} module Hjugement.CLI.Administrator where -import Control.Applicative (Applicative(..), Alternative(..)) -import Control.Monad (Monad(..), forM, forM_, join, unless, void) -import Control.Monad.Trans.Class (MonadTrans(..)) +import Control.Applicative (Applicative(..)) +import Control.Monad (Monad(..), forM_, unless) import Control.Monad.Trans.Except (runExcept) import Control.Monad.Trans.Maybe (MaybeT(..)) -import Control.Monad.Trans.State.Strict (runState, runStateT) -import Data.Bits (setBit) +import Control.Monad.Trans.State.Strict (runState) import Data.Bool -import Data.ByteString (ByteString) import Data.Either (Either(..)) import Data.Eq (Eq(..)) -import Data.Foldable (Foldable, foldMap, length, null) -import Data.Function (($), (.), id, flip) -import Data.Functor ((<$>), (<$)) -import Data.Int (Int) -import Data.Maybe (Maybe(..), maybe, fromMaybe, fromJust) -import Data.Monoid (Monoid(..)) +import Data.Function (($), id, flip) +import Data.Functor ((<$>)) +import Data.Maybe (Maybe(..), fromMaybe) import Data.Ord (Ord(..)) import Data.Proxy (Proxy(..)) import Data.Semigroup (Semigroup(..)) -import Data.String (String) import Data.Text (Text) -import GHC.Natural (minusNatural, minusNaturalMaybe) -import GHC.Prim (coerce) -import Numeric.Natural (Natural) -import Pipes ((>->)) -import Prelude (logBase, ceiling, Num(..), (/), (^), fromIntegral, Double) import Symantic.CLI as CLI -import System.IO (IO, FilePath) import Text.Show (Show(..)) -import qualified Crypto.Hash as Crypto import qualified Data.Aeson as JSON -import qualified Data.ByteArray as ByteArray -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BS8 import qualified Data.ByteString.Lazy as BSL import qualified Data.List as List import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Builder as TLB -import qualified Data.Text.Lazy.Builder.Int as TLB -import qualified Data.Text.Lazy.Encoding as TL -import qualified Data.Text.Lazy.IO as TL -import qualified Data.Time as Time -import qualified Lens.Family as Lens -import qualified Lens.Family.State.Strict as Lens import qualified Pipes as Pip -import qualified Pipes.ByteString as PipBS -import qualified Pipes.Group as Pip import qualified Pipes.Prelude as Pip -import qualified Pipes.Aeson as PipJSON (DecodingError(..)) -import qualified Pipes.Aeson.Unchecked as PipJSON -import qualified Pipes.Safe as Pip -import qualified Pipes.Safe.Prelude as Pip -import qualified Pipes.Text as PipText -import qualified Pipes.Text.Encoding as PipText -import qualified Pipes.Text.IO as PipText import qualified Symantic.Document as Doc import qualified System.FilePath as FP -import qualified System.IO as IO -import qualified System.Posix as Posix import qualified System.Random as Rand import qualified Voting.Protocol as VP diff --git a/hjugement-cli/src/Hjugement/CLI/Registrar.hs b/hjugement-cli/src/Hjugement/CLI/Registrar.hs index 51df1be..184c6df 100644 --- a/hjugement-cli/src/Hjugement/CLI/Registrar.hs +++ b/hjugement-cli/src/Hjugement/CLI/Registrar.hs @@ -1,59 +1,42 @@ {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StrictData #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-missing-signatures #-} module Hjugement.CLI.Registrar where import Control.Arrow (left) import Control.Applicative (Applicative(..)) -import Control.Monad (Monad(..), forM, forM_, join, void) -import Control.Monad.Trans.Class (MonadTrans(..)) +import Control.Monad (Monad(..)) import Control.Monad.Trans.Maybe (MaybeT(..)) -import Control.Monad.Trans.State.Strict (runState, runStateT) +import Control.Monad.Trans.State.Strict (runState) import Data.Bool -import Data.ByteString (ByteString) import Data.Either (Either(..)) -import Data.Foldable (Foldable, foldMap, length) -import Data.Function (($), (.), flip) +import Data.Function (($), (.)) import Data.Functor ((<$>)) -import Data.Int (Int) -import Data.Maybe (Maybe(..), maybe, fromMaybe) -import Data.Ord (Ord(..)) +import Data.Maybe (Maybe(..)) import Data.Proxy (Proxy(..)) import Data.Semigroup (Semigroup(..)) -import Data.String (String) -import Data.Text (Text) -import GHC.Natural (minusNatural, minusNaturalMaybe) +import GHC.Natural (minusNatural) import Numeric.Natural (Natural) import Pipes ((>->)) import Prelude (logBase, ceiling, Num(..), (/), (^), fromIntegral, Double) import Symantic.CLI as CLI import Text.Show (Show(..)) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BS8 -import qualified Data.ByteString.Lazy as BSL import qualified Data.List as List import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Encoding as TL -import qualified Data.Text.Lazy.IO as TL import qualified Data.Time as Time import qualified Lens.Family as Lens -import qualified Lens.Family.State.Strict as Lens import qualified Pipes as Pip import qualified Pipes.ByteString as PipBS import qualified Pipes.Group as Pip import qualified Pipes.Prelude as Pip -import qualified Pipes.Safe as Pip import qualified Pipes.Safe.Prelude as Pip import qualified Pipes.Text as PipText import qualified Pipes.Text.Encoding as PipText -import qualified Pipes.Text.IO as PipText import qualified Symantic.Document as Doc import qualified System.FilePath as FP import qualified System.IO as IO -import qualified System.Posix as Posix import qualified System.Random as Rand import qualified Voting.Protocol as VP @@ -92,7 +75,7 @@ api_registrar_pubkey = <.> response @Natural run_registrar_pubkey Global_Params{..} - o@Registrar_Params{..} + Registrar_Params{..} cred = return $ VP.reify registrar_election_crypto $ \(_::Proxy c) -> @@ -126,7 +109,7 @@ api_registrar_credentials = <.> response @(Maybe ()) run_registrar_credentials glob@Global_Params{..} - o@Registrar_Params{..} = + Registrar_Params{..} = run_count :!: run_file where diff --git a/hjugement-cli/src/Hjugement/CLI/Trustee.hs b/hjugement-cli/src/Hjugement/CLI/Trustee.hs index a0701af..dd6bf24 100644 --- a/hjugement-cli/src/Hjugement/CLI/Trustee.hs +++ b/hjugement-cli/src/Hjugement/CLI/Trustee.hs @@ -1,70 +1,34 @@ {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StrictData #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-missing-signatures #-} module Hjugement.CLI.Trustee where import Control.Applicative (Applicative(..)) -import Control.Monad (Monad(..), forM, forM_, join, void) -import Control.Monad.Trans.Class (MonadTrans(..)) +import Control.Monad (Monad(..)) import Control.Monad.Trans.Maybe (MaybeT(..)) -import Control.Monad.Trans.State.Strict (runState, runStateT) -import Data.Bits (setBit) +import Control.Monad.Trans.State.Strict (runState) import Data.Bool -import Data.ByteString (ByteString) -import Data.Either (Either(..)) import Data.Eq (Eq(..)) -import Data.Foldable (Foldable, foldMap, length, null) +import Data.Foldable (null) import Data.Function (($), (.), id, flip) import Data.Functor ((<$>)) -import Data.Int (Int) -import Data.Maybe (Maybe(..), maybe, fromMaybe) -import Data.Monoid (Monoid(..)) +import Data.Maybe (Maybe(..)) import Data.Ord (Ord(..)) import Data.Proxy (Proxy(..)) import Data.Semigroup (Semigroup(..)) -import Data.String (String) -import Data.Text (Text) -import GHC.Natural (minusNatural, minusNaturalMaybe) import GHC.Prim (coerce) -import Numeric.Natural (Natural) import Pipes ((>->)) -import Prelude (logBase, ceiling, Num(..), (/), (^), fromIntegral, Double) import Symantic.CLI as CLI import Text.Show (Show(..)) -import System.IO (IO, FilePath) -import qualified Crypto.Hash as Crypto -import qualified Data.Aeson as JSON -import qualified Data.ByteArray as ByteArray -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BS8 -import qualified Data.ByteString.Lazy as BSL +import System.IO (FilePath) import qualified Data.List as List import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Builder as TLB -import qualified Data.Text.Lazy.Builder.Int as TLB -import qualified Data.Text.Lazy.Encoding as TL -import qualified Data.Text.Lazy.IO as TL -import qualified Data.Time as Time -import qualified Lens.Family as Lens -import qualified Lens.Family.State.Strict as Lens import qualified Pipes as Pip -import qualified Pipes.ByteString as PipBS -import qualified Pipes.Group as Pip import qualified Pipes.Prelude as Pip -import qualified Pipes.Aeson as PipJSON (DecodingError(..)) -import qualified Pipes.Aeson.Unchecked as PipJSON -import qualified Pipes.Safe as Pip -import qualified Pipes.Safe.Prelude as Pip -import qualified Pipes.Text as PipText -import qualified Pipes.Text.Encoding as PipText -import qualified Pipes.Text.IO as PipText import qualified Symantic.Document as Doc import qualified System.FilePath as FP -import qualified System.IO as IO -import qualified System.Posix as Posix import qualified System.Random as Rand import qualified Voting.Protocol as VP @@ -110,9 +74,9 @@ api_trustee_generate = response @() run_trustee_generate glob@Global_Params{..} - o@Trustee_Params{..} = + Trustee_Params{..} = VP.reify trustee_crypto $ \(_crypto::Proxy c) -> do - keys@(secKey, pubKey) <- Pip.liftIO $ Rand.getStdRandom $ runState $ do + (secKey, pubKey) <- Pip.liftIO $ Rand.getStdRandom $ runState $ do secKey <- VP.randomSecretKey @c pubKey <- VP.proveIndispensableTrusteePublicKey secKey return (secKey, pubKey) @@ -153,7 +117,7 @@ api_trustee_decrypt = run_trustee_decrypt glob@Global_Params{..} - o@Trustee_Params{..} + Trustee_Params{..} TrusteeDecrypt_Params{..} = VP.reify trustee_crypto $ \(_crypto::Proxy c) -> runMaybeT $ do (secKey::VP.E c) <- loadJSON glob trusteeDecrypt_privkey @@ -183,7 +147,7 @@ run_trustee_decrypt outputInfo glob "tally the encrypted ballots" -- FIXME: actually support fetching through an URL let ballotsPath = trusteeDecrypt_url FP. "ballots.jsons" - (encTally, numBallots) <- runPipeWithError glob $ + (encTally, _numBallots) <- runPipeWithError glob $ Pip.fold' (flip VP.insertEncryptedTally) VP.emptyEncryptedTally id $ diff --git a/hjugement-cli/src/Hjugement/CLI/Utils.hs b/hjugement-cli/src/Hjugement/CLI/Utils.hs index 657f1dd..e2bc287 100644 --- a/hjugement-cli/src/Hjugement/CLI/Utils.hs +++ b/hjugement-cli/src/Hjugement/CLI/Utils.hs @@ -2,19 +2,18 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE StrictData #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} -- for VP.Reifies instances {-# OPTIONS_GHC -Wno-missing-signatures #-} +{-# OPTIONS_GHC -Wno-orphans #-} module Hjugement.CLI.Utils where import Control.Applicative (Applicative(..), Alternative(..)) import Control.Arrow (left) import Control.Monad (Monad(..), forM_, when) import Control.Monad.Trans.Maybe (MaybeT(..)) -import Control.Monad.Trans.Except (ExceptT, runExceptT) -import Control.Monad.Trans.State.Strict (StateT(..), evalStateT) -import Data.Bits (setBit) +import Control.Monad.Trans.Except (runExceptT) import Data.Bool -import Data.ByteString (ByteString) import Data.Either (Either(..)) import Data.Eq (Eq(..)) import Data.Foldable (Foldable) @@ -24,32 +23,22 @@ import Data.Maybe (Maybe(..), maybe) import Data.Monoid (Monoid(..)) import Data.Ord (Ord(..)) import Data.Semigroup (Semigroup(..)) -import Data.String (IsString(..)) import Data.Text (Text) import Prelude (min, max, (-)) import Symantic.CLI as CLI import System.IO (IO) import Text.Show (Show(..)) -import qualified Crypto.Hash as Crypto import qualified Data.Aeson as JSON -import qualified Data.ByteArray as ByteArray -import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8 import qualified Data.ByteString.Lazy.Char8 as BSL8 import qualified Data.Text as Text import qualified Data.Text.Encoding as T -import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Builder as TLB -import qualified Data.Text.Lazy.Builder.Int as TLB import qualified Lens.Family as Lens -import qualified Lens.Family.State.Strict as Lens import qualified Pipes as Pip import qualified Pipes.Aeson as PipJSON (DecodingError(..)) import qualified Pipes.Aeson.Unchecked as PipJSON import qualified Pipes.ByteString as PipBS -import qualified Pipes.Group as Pip -import qualified Pipes.Parse as Pip -import qualified Pipes.Prelude as Pip import qualified Pipes.Safe as Pip import qualified Pipes.Safe.Prelude as Pip import qualified Symantic.Document as Doc @@ -214,8 +203,7 @@ writeFileLn glob fileMode filePath = do where open = Pip.liftIO $ do IO.createDirectoryIfMissing True $ FP.takeDirectory filePath - h <- IO.openFile filePath IO.WriteMode - return h + IO.openFile filePath IO.WriteMode close h = Pip.liftIO $ do fd <- Posix.handleToFd h Posix.setFdMode fd fileMode @@ -237,8 +225,7 @@ writeJSON glob fileMode filePath = do where open = Pip.liftIO $ do IO.createDirectoryIfMissing True $ FP.takeDirectory filePath - h <- IO.openFile filePath IO.WriteMode - return h + IO.openFile filePath IO.WriteMode close h = Pip.liftIO $ do fd <- Posix.handleToFd h Posix.setFdMode fd fileMode diff --git a/hjugement-cli/src/Hjugement/CLI/Voter.hs b/hjugement-cli/src/Hjugement/CLI/Voter.hs index f50f1a0..c4ef045 100644 --- a/hjugement-cli/src/Hjugement/CLI/Voter.hs +++ b/hjugement-cli/src/Hjugement/CLI/Voter.hs @@ -1,74 +1,41 @@ {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StrictData #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-missing-signatures #-} module Hjugement.CLI.Voter where import Control.Applicative (Applicative(..), Alternative(..)) -import Control.Monad (Monad(..), forM, forM_, join, unless, void, when) -import Control.Monad.Trans.Class (MonadTrans(..)) +import Control.Monad (Monad(..), join, unless, void, when) import Control.Monad.Trans.Maybe (MaybeT(..)) -import Control.Monad.Trans.Except (runExcept, runExceptT) -import Control.Monad.Trans.State.Strict (runState, runStateT) -import Data.Bits (setBit) +import Control.Monad.Trans.Except (runExcept) +import Control.Monad.Trans.State.Strict (runStateT) import Data.Bool -import Data.ByteString (ByteString) -import Data.Either (Either(..), either) +import Data.Either (Either(..)) import Data.Eq (Eq(..)) -import Data.Foldable (Foldable, foldMap, length, null, sum) -import Data.Function (($), (.), id, flip) -import Data.Functor ((<$>), (<$)) -import Data.Int (Int) -import Data.Maybe (Maybe(..), maybe, fromMaybe, fromJust) -import Data.Monoid (Monoid(..)) +import Data.Foldable (sum) +import Data.Function (($)) +import Data.Functor ((<$>)) +import Data.Maybe (Maybe(..)) import Data.Ord (Ord(..)) -import Data.Proxy (Proxy(..)) import Data.Semigroup (Semigroup(..)) import Data.String (String) import Data.Text (Text) -import Data.Traversable (sequence) -import GHC.Natural (minusNatural, minusNaturalMaybe) -import GHC.Prim (coerce) import Numeric.Natural (Natural) -import Pipes ((>->)) -import Prelude (logBase, ceiling, Num(..), (/), (^), fromIntegral, Double) +import Prelude (Num(..)) import Symantic.CLI as CLI -import System.IO (IO, FilePath) +import System.IO (FilePath) import Text.Show (Show(..)) -import qualified Crypto.Hash as Crypto import qualified Data.Aeson as JSON -import qualified Data.ByteArray as ByteArray -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BS8 -import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Lazy.Char8 as BSL8 import qualified Data.List as List import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Builder as TLB -import qualified Data.Text.Lazy.Builder.Int as TLB -import qualified Data.Text.Lazy.Encoding as TL -import qualified Data.Text.Lazy.IO as TL -import qualified Data.Time as Time -import qualified Lens.Family as Lens -import qualified Lens.Family.State.Strict as Lens import qualified Pipes as Pip -import qualified Pipes.Aeson as PipJSON (DecodingError(..)) -import qualified Pipes.Aeson.Unchecked as PipJSON -import qualified Pipes.ByteString as PipBS -import qualified Pipes.Group as Pip import qualified Pipes.Prelude as Pip -import qualified Pipes.Safe as Pip -import qualified Pipes.Safe.Prelude as Pip -import qualified Pipes.Text as PipText -import qualified Pipes.Text.Encoding as PipText -import qualified Pipes.Text.IO as PipText import qualified Symantic.Document as Doc import qualified System.Directory as IO import qualified System.FilePath as FP import qualified System.IO as IO -import qualified System.Posix as Posix import qualified System.Random as Rand import qualified Voting.Protocol as VP import qualified Voting.Protocol.Utils as VP @@ -122,7 +89,7 @@ api_voter_vote = run_voter_vote glob@Global_Params{..} - o@VoterVote_Params{..} = runMaybeT $ do + VoterVote_Params{..} = runMaybeT $ do rawElec <- loadElection glob $ voterVote_url FP. "election.json" VP.reifyElection rawElec $ \(elec@VP.Election{..} :: VP.Election c) -> do outputInfo glob $ "Voted"<>Doc.from (show voterVote_grades) @@ -169,11 +136,11 @@ api_voter_verify = run_voter_verify glob@Global_Params{..} - o@VoterVerify_Params{..} = runMaybeT $ do + VoterVerify_Params{..} = runMaybeT $ do rawElec <- loadElection glob $ voterVerify_url FP. "election.json" VP.reifyElection rawElec $ \(elec@VP.Election{..} :: VP.Election c) -> do outputInfo glob $ "verifying ballots" - (fails :: Natural, (encTally :: VP.EncryptedTally c, numBallots)) <- runPipeWithError glob $ + (fails :: Natural, (encTally :: VP.EncryptedTally c, _numBallots)) <- runPipeWithError glob $ Pip.foldM' (\(fails, acc@(_, numBallots)) ballot@VP.Ballot{..} -> do let ballotNum = numBallots + fails -- 2.44.1 From 7a0ddc78b50e5e1be847cdceed7984cd4f2cca69 Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Fri, 16 Aug 2019 13:03:54 +0000 Subject: [PATCH 11/16] protocol: no padding for Base64SHA256. See: https://lists.gforge.inria.fr/pipermail/belenios-discuss/2019-August/000044.html --- hjugement-protocol/src/Voting/Protocol/FFC.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/hjugement-protocol/src/Voting/Protocol/FFC.hs b/hjugement-protocol/src/Voting/Protocol/FFC.hs index d9982f8..331ce41 100644 --- a/hjugement-protocol/src/Voting/Protocol/FFC.hs +++ b/hjugement-protocol/src/Voting/Protocol/FFC.hs @@ -362,8 +362,7 @@ base64SHA256 :: BS.ByteString -> Base64SHA256 base64SHA256 bs = let h = Crypto.hashWith Crypto.SHA256 bs in Base64SHA256 $ - Text.takeWhile (/= '=') $ - -- TODO: to be removed when Belenios will expect padding. + Text.takeWhile (/= '=') $ -- NOTE: no padding. Text.decodeUtf8 $ BS64.encode $ ByteArray.convert h -- ** Type 'HexSHA256' -- 2.44.1 From e278d84b6d882d7283e6e5fc80d60680d2a5ae28 Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Mon, 28 Oct 2019 16:07:26 +0000 Subject: [PATCH 12/16] protocol: add Version and abstract over FFC --- HLint.hs | 1 + hjugement-cli/hjugement-cli.cabal | 6 +- .../src/Hjugement/CLI/Administrator.hs | 28 +- hjugement-cli/src/Hjugement/CLI/Registrar.hs | 10 +- hjugement-cli/src/Hjugement/CLI/Trustee.hs | 22 +- hjugement-cli/src/Hjugement/CLI/Utils.hs | 39 +- hjugement-cli/src/Hjugement/CLI/Voter.hs | 14 +- hjugement-protocol/benchmarks/Election.hs | 124 ++-- hjugement-protocol/hjugement-protocol.cabal | 6 +- hjugement-protocol/src/Voting/Protocol.hs | 13 +- .../src/Voting/Protocol/Credential.hs | 62 +- .../src/Voting/Protocol/Election.hs | 615 +++++++++++++----- hjugement-protocol/src/Voting/Protocol/FFC.hs | 341 ++-------- .../src/Voting/Protocol/Tally.hs | 136 +++- .../Voting/Protocol/Trustee/Indispensable.hs | 71 +- .../src/Voting/Protocol/Utils.hs | 11 +- hjugement-protocol/tests/HUnit.hs | 13 +- hjugement-protocol/tests/HUnit/Credential.hs | 15 +- hjugement-protocol/tests/HUnit/Election.hs | 65 +- hjugement-protocol/tests/HUnit/FFC.hs | 40 +- hjugement-protocol/tests/HUnit/Trustee.hs | 7 +- .../tests/HUnit/Trustee/Indispensable.hs | 81 ++- hjugement-protocol/tests/Main.hs | 14 +- hjugement-protocol/tests/QuickCheck.hs | 9 +- .../tests/QuickCheck/Election.hs | 82 ++- .../tests/QuickCheck/Trustee.hs | 34 +- 26 files changed, 1092 insertions(+), 767 deletions(-) diff --git a/HLint.hs b/HLint.hs index 9c3e1bf..e886c65 100644 --- a/HLint.hs +++ b/HLint.hs @@ -3,6 +3,7 @@ ignore "Move brackets to avoid $" ignore "Reduce duplication" ignore "Redundant $" ignore "Redundant do" +ignore "Redundant lambda" ignore "Use camelCase" ignore "Use import/export shortcut" ignore "Use tuple-section" diff --git a/hjugement-cli/hjugement-cli.cabal b/hjugement-cli/hjugement-cli.cabal index adc6411..4fc4179 100644 --- a/hjugement-cli/hjugement-cli.cabal +++ b/hjugement-cli/hjugement-cli.cabal @@ -2,7 +2,7 @@ name: hjugement-cli -- PVP: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.0.0.20190815 +version: 0.0.0.20191028 category: Politic synopsis: Majority Judgment and Helios-C command line tool description: @@ -74,7 +74,7 @@ Executable hjugement -- -fhide-source-paths build-depends: hjugement >= 2.0.2 - , hjugement-protocol >= 0.0.7 + , hjugement-protocol >= 0.0.8 , aeson >= 1.3 , base >= 4.6 && < 5 , base64-bytestring >= 1.0 @@ -98,7 +98,7 @@ Executable hjugement , random >= 1.1 , reflection >= 2.1 , symantic-cli >= 2.4.2 - , symantic-document >= 1.5 + , symantic-document >= 1.5.1 , terminal-size >= 0.3 , text >= 1.2 , time >= 1.8 diff --git a/hjugement-cli/src/Hjugement/CLI/Administrator.hs b/hjugement-cli/src/Hjugement/CLI/Administrator.hs index c82007e..b1da703 100644 --- a/hjugement-cli/src/Hjugement/CLI/Administrator.hs +++ b/hjugement-cli/src/Hjugement/CLI/Administrator.hs @@ -59,6 +59,7 @@ data AdministratorElection_Params = AdministratorElection_Params , administratorElection_uuid :: Maybe Text , administratorElection_grades :: [Text] , administratorElection_defaultGrade :: Maybe Text + , administratorElection_version :: VP.Version } deriving (Show) api_administrator_election = @@ -75,7 +76,8 @@ api_administrator_election = <*> api_param_description <*> api_option_uuid <*> api_param_grades - <*> api_param_defaultGrade) + <*> api_param_defaultGrade + <*> api_param_version) api_quests <.> response @(Maybe ()) where @@ -112,7 +114,8 @@ run_administrator_election glob@Global_Params{..} AdministratorElection_Params{..} quests = - VP.reify administratorElection_crypto $ \(_crypto::Proxy c) -> runMaybeT $ do + VP.reify administratorElection_version $ \(_v::Proxy v) -> + VP.reify administratorElection_crypto $ \(_c::Proxy c) -> runMaybeT $ do election_uuid <- case administratorElection_uuid of Nothing -> Pip.liftIO $ Rand.getStdRandom $ runState $ VP.randomUUID @@ -121,7 +124,7 @@ run_administrator_election Left err -> outputError glob $ Doc.from (show err) Right uuid -> return uuid let trusteeKeysPath = global_dir FP. "public_keys.jsons" - trusteeKeys :: [VP.TrusteePublicKey c] <- runPipeWithError glob $ + trusteeKeys :: [VP.TrusteePublicKey VP.FFC v c] <- runPipeWithError glob $ Pip.toListM' $ readJSON glob trusteeKeysPath forM_ trusteeKeys $ \trusteeKey -> case runExcept $ VP.verifyIndispensableTrusteePublicKey trusteeKey of @@ -138,22 +141,21 @@ run_administrator_election fromMaybe (grades List.!!0) administratorElection_defaultGrade -- FIXME: put defaultGrade into election.json - let elec = + let elec :: VP.Election VP.FFC v c = VP.Election { VP.election_name = administratorElection_name , VP.election_description = administratorElection_description - , VP.election_crypto = VP.ElectionCrypto_FFC - { electionCrypto_FFC_params = administratorElection_crypto - , electionCrypto_FFC_PublicKey = VP.combineIndispensableTrusteePublicKeys trusteeKeys - } - , VP.election_questions = (<$> quests) $ \quest -> VP.Question + , VP.election_crypto = administratorElection_crypto + , VP.election_public_key = VP.combineIndispensableTrusteePublicKeys trusteeKeys + , VP.election_questions = (<$> quests) $ \quest -> VP.Question { question_text = quest , question_choices = grades , question_mini = 1 , question_maxi = 1 } , VP.election_uuid - , VP.election_hash = VP.Base64SHA256 "" + , VP.election_version = Just administratorElection_version + , VP.election_hash = VP.hashElection elec } saveJSON glob (global_dir FP. "election.json") elec outputInfo glob $ @@ -173,8 +175,8 @@ api_administrator_tally = run_administrator_tally glob@Global_Params{..} = runMaybeT $ do - rawElec <- loadElection glob $ global_dir FP. "election.json" - VP.reifyElection rawElec $ \(_elec :: VP.Election c) -> do + loadElection glob (global_dir FP. "election.json") $ + \(_elec :: VP.Election VP.FFC v c) -> do keys <- runPipeWithError glob $ Pip.toListM' $ readJSON glob $ global_dir FP. "public_keys.jsons" decs <- runPipeWithError glob $ Pip.toListM' $ @@ -187,7 +189,7 @@ run_administrator_tally readJSON glob $ global_dir FP. "ballots.jsons" outputInfo glob $ "decrypting tally using trustees' decryption shares" case runExcept $ VP.proveTally - (encTally :: VP.EncryptedTally c, numBallots) decs + (encTally :: VP.EncryptedTally VP.FFC v c, numBallots) decs (VP.combineIndispensableDecryptionShares (VP.trustee_PublicKey <$> keys)) of Left err -> outputError glob $ Doc.from (show err) Right tally -> do diff --git a/hjugement-cli/src/Hjugement/CLI/Registrar.hs b/hjugement-cli/src/Hjugement/CLI/Registrar.hs index 184c6df..dd74f70 100644 --- a/hjugement-cli/src/Hjugement/CLI/Registrar.hs +++ b/hjugement-cli/src/Hjugement/CLI/Registrar.hs @@ -44,8 +44,9 @@ import Hjugement.CLI.Utils -- ** Type 'Registrar_Params' data Registrar_Params = Registrar_Params - { registrar_election_crypto :: VP.FFC - , registrar_election_uuid :: VP.UUID + { registrar_election_crypto :: VP.FFC + , registrar_election_version :: VP.Version + , registrar_election_uuid :: VP.UUID } deriving (Show) api_registrar = @@ -55,6 +56,7 @@ api_registrar = rule "PARAMS" (Registrar_Params <$> api_param_crypto + <*> api_param_version <*> api_param_uuid) ( api_registrar_credentials @@ -80,7 +82,7 @@ run_registrar_pubkey return $ VP.reify registrar_election_crypto $ \(_::Proxy c) -> VP.nat $ VP.publicKey $ - VP.credentialSecretKey @c registrar_election_uuid cred + VP.credentialSecretKey @VP.FFC @c registrar_election_uuid cred api_registrar_credentials = "Generate voters' credentials, either "<>ref "COUNT"<>" sequential identities\ @@ -148,7 +150,7 @@ run_registrar_credentials >-> writeFileLn glob 0o400 (baseFile FP.<.>"privcreds") ) >-> Pip.mapM (\(ident, cred) -> - let secKey = VP.credentialSecretKey @c registrar_election_uuid cred in + let secKey = VP.credentialSecretKey @VP.FFC @c registrar_election_uuid cred in let pubKey = VP.publicKey secKey in return (ident, pubKey)) >-> Pip.tee ( diff --git a/hjugement-cli/src/Hjugement/CLI/Trustee.hs b/hjugement-cli/src/Hjugement/CLI/Trustee.hs index dd6bf24..02bc5e1 100644 --- a/hjugement-cli/src/Hjugement/CLI/Trustee.hs +++ b/hjugement-cli/src/Hjugement/CLI/Trustee.hs @@ -36,7 +36,8 @@ import Hjugement.CLI.Utils -- * trustee data Trustee_Params = Trustee_Params - { trustee_crypto :: VP.FFC + { trustee_crypto :: VP.FFC + , trustee_version :: VP.Version } deriving (Show) api_trustee = @@ -46,6 +47,7 @@ api_trustee = rule "TrusteeParams" (Trustee_Params <$> api_param_crypto + <*> api_param_version ) ( api_trustee_generate api_trustee_decrypt @@ -75,10 +77,12 @@ api_trustee_generate = run_trustee_generate glob@Global_Params{..} Trustee_Params{..} = - VP.reify trustee_crypto $ \(_crypto::Proxy c) -> do + VP.reify trustee_version $ \(_v::Proxy v) -> do + VP.reify trustee_crypto $ \(_c::Proxy c) -> do (secKey, pubKey) <- Pip.liftIO $ Rand.getStdRandom $ runState $ do - secKey <- VP.randomSecretKey @c - pubKey <- VP.proveIndispensableTrusteePublicKey secKey + secKey <- VP.randomSecretKey @VP.FFC @c + pubKey :: VP.TrusteePublicKey VP.FFC v c + <- VP.proveIndispensableTrusteePublicKey secKey return (secKey, pubKey) let pubIdent = T.unpack $ T.toUpper $ T.take 8 $ @@ -108,7 +112,7 @@ api_trustee_decrypt = (TrusteeDecrypt_Params <$> api_param_privkey <*> api_param_url) - response @(Maybe (VP.DecryptionShare ())) + response @(Maybe (VP.DecryptionShare VP.FFC () ())) where api_param_privkey = "Read private key from file "<>ref"FILE"<>"." @@ -119,8 +123,9 @@ run_trustee_decrypt glob@Global_Params{..} Trustee_Params{..} TrusteeDecrypt_Params{..} = + VP.reify trustee_version $ \(_v::Proxy v) -> do VP.reify trustee_crypto $ \(_crypto::Proxy c) -> runMaybeT $ do - (secKey::VP.E c) <- loadJSON glob trusteeDecrypt_privkey + (secKey::VP.E VP.FFC c) <- loadJSON glob trusteeDecrypt_privkey let pubKey = VP.publicKey secKey let trusteeKeysPath = trusteeDecrypt_url FP. "public_keys.jsons" outputInfo glob "check that the public key is amongst the public keys of the election" @@ -152,7 +157,8 @@ run_trustee_decrypt (flip VP.insertEncryptedTally) VP.emptyEncryptedTally id $ readJSON glob ballotsPath - decShare <- Pip.liftIO $ + decShare :: VP.DecryptionShare VP.FFC v c + <- Pip.liftIO $ Rand.getStdRandom $ runState $ VP.proveDecryptionShare encTally secKey - return (coerce decShare :: VP.DecryptionShare ()) + return (coerce decShare :: VP.DecryptionShare VP.FFC () ()) diff --git a/hjugement-cli/src/Hjugement/CLI/Utils.hs b/hjugement-cli/src/Hjugement/CLI/Utils.hs index e2bc287..eb6071b 100644 --- a/hjugement-cli/src/Hjugement/CLI/Utils.hs +++ b/hjugement-cli/src/Hjugement/CLI/Utils.hs @@ -62,10 +62,26 @@ api_param_crypto = "Take cryptographic parameters from file "<>fileRef "FILE"<>"." `help` requiredTag "crypto" (var "FILE") +api_param_version = + "Set the protocol version to use.\n"<> + "Defaults to the \"stable\" version.\n"<> + Doc.ul + [ "stable == "<>Doc.from (show VP.stableVersion) + , "experimental == "<>Doc.from (show VP.experimentalVersion) + ] + `help` + defaultTag "version" VP.stableVersion ( + constant "stable" VP.stableVersion `alt` + constant "experimental" VP.experimentalVersion `alt` + var "VERSION" + ) +instance CLI.IOType VP.Version +instance CLI.FromSegment VP.Version where + fromSegment = return . maybe (Left "invalid version string") Right . VP.readVersion instance CLI.IOType VP.FFC instance CLI.FromSegment VP.FFC where fromSegment = JSON.eitherDecodeFileStrict' -instance VP.Reifies c VP.FFC => CLI.FromSegment (VP.E c) where +instance VP.Reifies c VP.FFC => CLI.FromSegment (VP.E VP.FFC c) where fromSegment = JSON.eitherDecodeFileStrict' api_param_uuid = "UUID of the election." @@ -77,8 +93,8 @@ instance CLI.FromSegment VP.UUID where instance CLI.IOType VP.Credential instance CLI.FromSegment VP.Credential where fromSegment = return . left show . VP.readCredential . Text.pack -instance IOType (VP.DecryptionShare ()) -instance Outputable (VP.DecryptionShare ()) where +instance IOType (VP.DecryptionShare VP.FFC () ()) +instance Outputable (VP.DecryptionShare VP.FFC () ()) where output decShare = output $ JSON.encode decShare<>"\n" api_help full = @@ -280,19 +296,28 @@ loadJSON glob filePath = Doc.from err<>"\n" Right a -> return a +-- | TODO: abstract over @crypto@ in the continuation. loadElection :: + VP.ReifyCrypto crypto => + JSON.FromJSON crypto => Pip.MonadIO m => Global_Params -> - IO.FilePath -> MaybeT m (VP.Election ()) -loadElection glob filePath = + IO.FilePath -> + (forall v c. + VP.Reifies v VP.Version => + VP.Reifies c crypto => + VP.FieldElementConstraints crypto c => + VP.Election crypto v c -> MaybeT m r) -> + MaybeT m r +loadElection glob filePath k = Pip.liftIO ( do outputDebug glob $ "loading " <> Doc.from filePath - runExceptT $ VP.readElection filePath + runExceptT $ VP.readElection filePath k ) >>= \case Left err -> outputError glob $ Doc.from filePath<>": "<> Doc.from err<>"\n" - Right a -> return a + Right r -> r {- readJSON' :: diff --git a/hjugement-cli/src/Hjugement/CLI/Voter.hs b/hjugement-cli/src/Hjugement/CLI/Voter.hs index c4ef045..3f27407 100644 --- a/hjugement-cli/src/Hjugement/CLI/Voter.hs +++ b/hjugement-cli/src/Hjugement/CLI/Voter.hs @@ -90,8 +90,8 @@ api_voter_vote = run_voter_vote glob@Global_Params{..} VoterVote_Params{..} = runMaybeT $ do - rawElec <- loadElection glob $ voterVote_url FP. "election.json" - VP.reifyElection rawElec $ \(elec@VP.Election{..} :: VP.Election c) -> do + loadElection glob (voterVote_url FP. "election.json") $ + \(elec@VP.Election{..} :: VP.Election VP.FFC v c) -> do outputInfo glob $ "Voted"<>Doc.from (show voterVote_grades) votes <- VP.isoZipWithM (outputError glob $ "Mismatching number of cast grades ("<> @@ -110,7 +110,7 @@ run_voter_vote election_questions voterVote_grades outputInfo glob $ Doc.from (show votes) - let (secKey :: VP.SecretKey c) = + let (secKey :: VP.SecretKey VP.FFC c) = VP.credentialSecretKey election_uuid voterVote_privcred ballot <- join $ Pip.liftIO $ Rand.getStdRandom $ \gen -> @@ -137,10 +137,10 @@ api_voter_verify = run_voter_verify glob@Global_Params{..} VoterVerify_Params{..} = runMaybeT $ do - rawElec <- loadElection glob $ voterVerify_url FP. "election.json" - VP.reifyElection rawElec $ \(elec@VP.Election{..} :: VP.Election c) -> do + loadElection glob (voterVerify_url FP. "election.json") $ + \(elec@VP.Election{..} :: VP.Election VP.FFC v c) -> do outputInfo glob $ "verifying ballots" - (fails :: Natural, (encTally :: VP.EncryptedTally c, _numBallots)) <- runPipeWithError glob $ + (fails :: Natural, (encTally :: VP.EncryptedTally VP.FFC v c, _numBallots)) <- runPipeWithError glob $ Pip.foldM' (\(fails, acc@(_, numBallots)) ballot@VP.Ballot{..} -> do let ballotNum = numBallots + fails @@ -175,7 +175,7 @@ run_voter_verify then do outputWarning glob "no tally to check" else do - tally :: VP.Tally c <- loadJSON glob resultPath + tally :: VP.Tally VP.FFC v c <- loadJSON glob resultPath outputInfo glob $ "decrypting tally using trustees' decryption shares" trustees <- runPipeWithError glob $ Pip.toListM' $ readJSON glob $ voterVerify_url FP. "public_keys.jsons" diff --git a/hjugement-protocol/benchmarks/Election.hs b/hjugement-protocol/benchmarks/Election.hs index 10dc7bc..fa306bc 100644 --- a/hjugement-protocol/benchmarks/Election.hs +++ b/hjugement-protocol/benchmarks/Election.hs @@ -1,14 +1,23 @@ {-# LANGUAGE OverloadedStrings #-} module Election where +import Control.DeepSeq (NFData) import qualified Data.List as List import qualified Data.Text as Text import qualified Text.Printf as Printf +import qualified Data.Aeson as JSON import Voting.Protocol import Utils -makeElection :: forall c. Reifies c FFC => Int -> Int -> Election c +makeElection :: + forall crypto v c. + Reifies v Version => + Reifies c crypto => + JSON.ToJSON crypto => + JSON.ToJSON (FieldElement crypto c) => + Key crypto => + Int -> Int -> Election crypto v c makeElection nQuests nChoices = elec where election_uuid = UUID "xLcs7ev6Jy6FHH" @@ -16,10 +25,12 @@ makeElection nQuests nChoices = elec { election_name = Text.pack $ "elec"<>show nQuests<>show nChoices , election_description = "benchmarkable election" , election_uuid - , election_crypto = ElectionCrypto_FFC (reflect (Proxy::Proxy c)) $ + , election_crypto = reflect (Proxy @c) + , election_public_key = let secKey = credentialSecretKey election_uuid (Credential "xLcs7ev6Jy6FHHE") in publicKey secKey , election_hash = hashElection elec + , election_version = Just (reflect (Proxy @v)) , election_questions = (<$> [1..nQuests]) $ \quest -> Question { question_text = Text.pack $ "quest"<>show quest @@ -29,13 +40,20 @@ makeElection nQuests nChoices = elec } } -makeVotes :: Election c -> [[Bool]] +makeVotes :: Election crypto v c -> [[Bool]] makeVotes Election{..} = [ True : List.tail [ False | _choice <- question_choices quest ] | quest <- election_questions ] -makeBallot :: Reifies c FFC => Election c -> Ballot c +makeBallot :: + Reifies v Version => + Reifies c crypto => + Group crypto => + Key crypto => + Multiplicative (FieldElement crypto c) => + ToNatural (FieldElement crypto c) => + Election crypto v c -> Ballot crypto v c makeBallot elec = case runExcept $ (`evalStateT` mkStdGen seed) $ do ballotSecKey <- randomSecretKey @@ -46,7 +64,7 @@ makeBallot elec = where seed = 0 -titleElection :: Election c -> String +titleElection :: Election crypto v c -> String titleElection Election{..} = Printf.printf "(questions=%i)×(choices=%i)==%i" nQuests nChoices (nQuests * nChoices) @@ -54,26 +72,48 @@ titleElection Election{..} = nQuests = List.length election_questions nChoices = List.foldr max 0 $ List.length . question_choices <$> election_questions -benchEncryptBallot :: FFC -> Int -> Int -> Benchmark -benchEncryptBallot ffc nQuests nChoices = - reify ffc $ \(Proxy::Proxy c) -> - let setupEnv = do - let elec :: Election c = makeElection nQuests nChoices - return elec in - env setupEnv $ \ ~(elec) -> - bench (titleElection elec) $ - nf makeBallot elec +benchEncryptBallot :: + forall crypto v c. + Reifies v Version => + Reifies c crypto => + JSON.ToJSON crypto => + Group crypto => + Key crypto => + NFData crypto => + NFData (FieldElement crypto c) => + Multiplicative (FieldElement crypto c) => + ToNatural (FieldElement crypto c) => + JSON.ToJSON (FieldElement crypto c) => + Proxy v -> Proxy c -> Int -> Int -> Benchmark +benchEncryptBallot (_v::Proxy v) (_c::Proxy c) nQuests nChoices = + let setupEnv = do + let elec :: Election crypto v c = makeElection nQuests nChoices + return elec in + env setupEnv $ \ ~(elec) -> + bench (titleElection elec) $ + nf makeBallot elec -benchVerifyBallot :: FFC -> Int -> Int -> Benchmark -benchVerifyBallot ffc nQuests nChoices = - reify ffc $ \(Proxy::Proxy c) -> - let setupEnv = do - let elec :: Election c = makeElection nQuests nChoices - let ballot = makeBallot elec - return (elec,ballot) in - env setupEnv $ \ ~(elec, ballot) -> - bench (titleElection elec) $ - nf (verifyBallot elec) ballot +benchVerifyBallot :: + forall crypto v c. + Reifies v Version => + Reifies c crypto => + JSON.ToJSON crypto => + Group crypto => + Key crypto => + NFData crypto => + NFData (FieldElement crypto c) => + Multiplicative (FieldElement crypto c) => + ToNatural (FieldElement crypto c) => + JSON.ToJSON (FieldElement crypto c) => + Proxy v -> Proxy c -> Int -> Int -> Benchmark +benchVerifyBallot (_v::Proxy v) (_c::Proxy c) nQuests nChoices = + let setupEnv = do + let elec :: Election crypto v c = makeElection nQuests nChoices + let ballot = makeBallot elec + return (elec,ballot) in + env setupEnv $ \ ~(elec, ballot) -> + bench (titleElection elec) $ + nf (verifyBallot elec) ballot benchmarks :: [Benchmark] benchmarks = @@ -82,24 +122,26 @@ benchmarks = | nQ <- [1,5,10,15,20,25] , nC <- [5,7] ] in - [ bgroup "weakFFC" - [ bgroup "encryptBallot" - [ benchEncryptBallot weakFFC nQuests nChoices - | (nQuests,nChoices) <- inputs + [ bgroup "stableVersion" $ reify stableVersion $ \v -> + [ bgroup "weakFFC" $ reify weakFFC $ \c -> + [ bgroup "encryptBallot" + [ benchEncryptBallot v c nQuests nChoices + | (nQuests,nChoices) <- inputs + ] + , bgroup "verifyBallot" + [ benchVerifyBallot v c nQuests nChoices + | (nQuests,nChoices) <- inputs + ] ] - , bgroup "verifyBallot" - [ benchVerifyBallot weakFFC nQuests nChoices - | (nQuests,nChoices) <- inputs - ] - ] - , bgroup "beleniosFFC" - [ bgroup "encryptBallot" - [ benchEncryptBallot beleniosFFC nQuests nChoices - | (nQuests,nChoices) <- inputs - ] - , bgroup "verifyBallot" - [ benchVerifyBallot beleniosFFC nQuests nChoices - | (nQuests,nChoices) <- inputs + , bgroup "beleniosFFC" $ reify beleniosFFC $ \c -> + [ bgroup "encryptBallot" + [ benchEncryptBallot v c nQuests nChoices + | (nQuests,nChoices) <- inputs + ] + , bgroup "verifyBallot" + [ benchVerifyBallot v c nQuests nChoices + | (nQuests,nChoices) <- inputs + ] ] ] ] diff --git a/hjugement-protocol/hjugement-protocol.cabal b/hjugement-protocol/hjugement-protocol.cabal index 8976176..452ee6e 100644 --- a/hjugement-protocol/hjugement-protocol.cabal +++ b/hjugement-protocol/hjugement-protocol.cabal @@ -2,7 +2,7 @@ name: hjugement-protocol -- PVP: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.0.7.20190815 +version: 0.0.8.20191027 category: Politic synopsis: A cryptographic protocol for the Majority Judgment. description: @@ -61,9 +61,10 @@ Library hs-source-dirs: src exposed-modules: Voting.Protocol - Voting.Protocol.FFC + Voting.Protocol.Arith Voting.Protocol.Credential Voting.Protocol.Election + Voting.Protocol.FFC Voting.Protocol.Tally Voting.Protocol.Trustee Voting.Protocol.Trustee.Indispensable @@ -212,6 +213,7 @@ Benchmark hjugement-protocol-benchmark , hjugement-protocol , containers >= 0.5 , criterion >= 1.4 + , deepseq >= 1.4 , QuickCheck >= 2.11 , random >= 1.1 , text >= 1.2 diff --git a/hjugement-protocol/src/Voting/Protocol.hs b/hjugement-protocol/src/Voting/Protocol.hs index e7dc8b8..e7c9c59 100644 --- a/hjugement-protocol/src/Voting/Protocol.hs +++ b/hjugement-protocol/src/Voting/Protocol.hs @@ -1,13 +1,24 @@ module Voting.Protocol - ( module Voting.Protocol.FFC + ( module Voting.Protocol.Arith + , module Voting.Protocol.FFC , module Voting.Protocol.Credential , module Voting.Protocol.Election , module Voting.Protocol.Tally , module Voting.Protocol.Trustee + , Natural + , RandomGen + , Reifies(..), reify + , Proxy(..) ) where +import Voting.Protocol.Arith import Voting.Protocol.FFC import Voting.Protocol.Credential import Voting.Protocol.Election import Voting.Protocol.Tally import Voting.Protocol.Trustee + +import Data.Proxy (Proxy(..)) +import Data.Reflection (Reifies(..), reify) +import Numeric.Natural (Natural) +import System.Random (RandomGen) diff --git a/hjugement-protocol/src/Voting/Protocol/Credential.hs b/hjugement-protocol/src/Voting/Protocol/Credential.hs index dd3b354..5d1b197 100644 --- a/hjugement-protocol/src/Voting/Protocol/Credential.hs +++ b/hjugement-protocol/src/Voting/Protocol/Credential.hs @@ -14,22 +14,50 @@ import Data.Functor ((<$>)) import Data.Int (Int) import Data.Maybe (maybe) import Data.Ord (Ord(..)) +import Data.Reflection (Reifies(..)) import Data.Semigroup (Semigroup(..)) import Data.Text (Text) import GHC.Generics (Generic) import Prelude (Integral(..), fromIntegral) import Text.Show (Show(..)) import qualified Control.Monad.Trans.State.Strict as S -import qualified Crypto.KDF.PBKDF2 as Crypto import qualified Data.Aeson as JSON import qualified Data.Aeson.Types as JSON import qualified Data.Char as Char import qualified Data.List as List import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text import qualified System.Random as Random -import Voting.Protocol.FFC +import Voting.Protocol.Arith + +-- * Class 'Key' +class Key crypto where + -- | Type of cryptography, eg. "FFC". + cryptoType :: crypto -> Text + -- | Name of the cryptographic paramaters, eg. "Belenios". + cryptoName :: crypto -> Text + -- | Generate a random 'SecretKey'. + randomSecretKey :: + Reifies c crypto => + Monad m => Random.RandomGen r => + S.StateT r m (SecretKey crypto c) + -- | @('credentialSecretKey' uuid cred)@ returns the 'SecretKey' + -- derived from given 'uuid' and 'cred' + -- using 'Crypto.fastPBKDF2_SHA256'. + credentialSecretKey :: + Reifies c crypto => + UUID -> Credential -> SecretKey crypto c + -- | @('publicKey' secKey)@ returns the 'PublicKey' + -- derived from given 'SecretKey' @secKey@. + publicKey :: + Reifies c crypto => + SecretKey crypto c -> + PublicKey crypto c + +-- ** Type 'PublicKey' +type PublicKey = G +-- ** Type 'SecretKey' +type SecretKey = E -- * Type 'Credential' -- | A 'Credential' is a word of @('tokenLength'+1 '==' 15)@-characters @@ -128,31 +156,3 @@ readUUID s digitOfChar c = maybe (Left $ ErrorToken_BadChar c) Right $ List.elemIndex c credentialAlphabet - --- ** Type 'SecretKey' -type SecretKey = E - -randomSecretKey :: Reifies c FFC => Monad m => RandomGen r => S.StateT r m (SecretKey c) -randomSecretKey = random - --- | @('credentialSecretKey' uuid cred)@ returns the 'SecretKey' --- derived from given 'uuid' and 'cred' --- using 'Crypto.fastPBKDF2_SHA256'. -credentialSecretKey :: Reifies c FFC => UUID -> Credential -> (SecretKey c) -credentialSecretKey (UUID uuid) (Credential cred) = - fromNatural $ decodeBigEndian $ - Crypto.fastPBKDF2_SHA256 - Crypto.Parameters - { Crypto.iterCounts = 1000 - , Crypto.outputLength = 32 -- bytes, ie. 256 bits - } - (Text.encodeUtf8 cred) - (Text.encodeUtf8 uuid) - --- ** Type 'PublicKey' -type PublicKey = G - --- | @('publicKey' secKey)@ returns the 'PublicKey' --- derived from given 'SecretKey' @secKey@. -publicKey :: Reifies c FFC => SecretKey c -> PublicKey c -publicKey = (groupGen ^) diff --git a/hjugement-protocol/src/Voting/Protocol/Election.hs b/hjugement-protocol/src/Voting/Protocol/Election.hs index 740a471..7448664 100644 --- a/hjugement-protocol/src/Voting/Protocol/Election.hs +++ b/hjugement-protocol/src/Voting/Protocol/Election.hs @@ -2,11 +2,11 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE Rank2Types #-} -- for reifyElection +{-# LANGUAGE Rank2Types #-} -- for readElection {-# LANGUAGE UndecidableInstances #-} -- for Reifies instances module Voting.Protocol.Election where -import Control.Applicative (Applicative(..)) +import Control.Applicative (Applicative(..), Alternative(..)) import Control.DeepSeq (NFData) import Control.Monad (Monad(..), join, mapM, replicateM, zipWithM) import Control.Monad.Trans.Class (MonadTrans(..)) @@ -17,13 +17,15 @@ 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 (Functor, (<$>), (<$)) import Data.Functor.Identity (Identity(..)) -import Data.Maybe (Maybe(..), maybe, fromJust) +import Data.Maybe (Maybe(..), maybe, fromJust, fromMaybe, listToMaybe) import Data.Monoid (Monoid(..)) import Data.Ord (Ord(..)) +import Data.Proxy (Proxy(..)) +import Data.Reflection (Reifies(..), reify) import Data.Semigroup (Semigroup(..)) -import Data.String (String) +import Data.String (String, IsString(..)) import Data.Text (Text) import Data.Traversable (Traversable(..)) import Data.Tuple (fst, snd) @@ -32,16 +34,26 @@ import GHC.Natural (minusNaturalMaybe) import Numeric.Natural (Natural) import Prelude (fromIntegral) import System.IO (IO, FilePath) -import Text.Show (Show(..)) +import System.Random (RandomGen) +import Text.Show (Show(..), showChar, showString) import qualified Control.Monad.Trans.State.Strict as S import qualified Data.Aeson as JSON +import qualified Data.Aeson.Encoding as JSON +import qualified Data.Aeson.Internal as JSON +import qualified Data.Aeson.Parser.Internal as JSON +import qualified Data.Aeson.Types as JSON import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL +import qualified Data.Char as Char import qualified Data.List as List +import qualified Data.Text as Text +import qualified Text.ParserCombinators.ReadP as Read +import qualified Text.Read as Read import Voting.Protocol.Utils -import Voting.Protocol.FFC +import Voting.Protocol.Arith import Voting.Protocol.Credential +import Voting.Protocol.FFC (FFC) -- * Type 'Encryption' -- | ElGamal-like encryption. @@ -55,15 +67,22 @@ import Voting.Protocol.Credential -- -- 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) +data Encryption crypto v c = Encryption + { encryption_nonce :: !(G crypto c) -- ^ Public part of the randomness 'encNonce' used to 'encrypt' the 'clear' text, -- equal to @('groupGen' '^'encNonce)@ - , encryption_vault :: !(G c) + , encryption_vault :: !(G crypto c) -- ^ Encrypted 'clear' text, -- equal to @('pubKey' '^'encNone '*' 'groupGen' '^'clear)@ - } deriving (Eq,Show,Generic,NFData) -instance Reifies c FFC => ToJSON (Encryption c) where + } deriving (Generic) +deriving instance Eq (FieldElement crypto c) => Eq (Encryption crypto v c) +deriving instance (Show (FieldElement crypto c), Show (G crypto c)) => Show (Encryption crypto v c) +deriving instance NFData (FieldElement crypto c) => NFData (Encryption crypto v c) +instance + ( Reifies v Version + , Reifies c crypto + , ToJSON (FieldElement crypto c) + ) => ToJSON (Encryption crypto v c) where toJSON Encryption{..} = JSON.object [ "alpha" .= encryption_nonce @@ -74,7 +93,11 @@ instance Reifies c FFC => ToJSON (Encryption c) where ( "alpha" .= encryption_nonce <> "beta" .= encryption_vault ) -instance Reifies c FFC => FromJSON (Encryption c) where +instance + ( Reifies v Version + , Reifies c crypto + , FromJSON (G crypto c) + ) => FromJSON (Encryption crypto v c) where parseJSON = JSON.withObject "Encryption" $ \o -> do encryption_nonce <- o .: "alpha" encryption_vault <- o .: "beta" @@ -82,7 +105,10 @@ instance Reifies c FFC => FromJSON (Encryption c) where -- | Additive homomorphism. -- Using the fact that: @'groupGen' '^'x '*' 'groupGen' '^'y '==' 'groupGen' '^'(x'+'y)@. -instance Reifies c FFC => Additive (Encryption c) where +instance + ( Reifies c crypto + , Multiplicative (FieldElement crypto c) + ) => Additive (Encryption crypto v c) where zero = Encryption one one x+y = Encryption (encryption_nonce x * encryption_nonce y) @@ -100,10 +126,13 @@ type EncryptionNonce = E -- as it may be used to decipher the 'Encryption' -- without the 'SecretKey' associated with 'pubKey'. encrypt :: - Reifies c FFC => + Reifies v Version => + Reifies c crypto => + Group crypto => + Multiplicative (FieldElement crypto c) => Monad m => RandomGen r => - PublicKey c -> E c -> - S.StateT r m (EncryptionNonce c, Encryption c) + PublicKey crypto c -> E crypto c -> + S.StateT r m (EncryptionNonce crypto c, Encryption crypto v c) encrypt pubKey clear = do encNonce <- random -- NOTE: preserve the 'encNonce' for 'prove' in 'proveEncryption'. @@ -117,8 +146,8 @@ encrypt pubKey clear = do -- | Non-Interactive Zero-Knowledge 'Proof' -- of knowledge of a discrete logarithm: -- @(secret == logBase base (base^secret))@. -data Proof c = Proof - { proof_challenge :: Challenge c +data Proof crypto v c = Proof + { proof_challenge :: !(Challenge crypto c) -- ^ 'Challenge' sent by the verifier to the prover -- to ensure that the prover really has knowledge -- of the secret and is not replaying. @@ -126,7 +155,7 @@ data Proof c = Proof -- 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 + , proof_response :: !(E crypto c) -- ^ A discrete logarithm sent by the prover to the verifier, -- as a response to 'proof_challenge'. -- @@ -147,8 +176,8 @@ data Proof c = Proof -- 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 + } deriving (Eq,Show,NFData,Generic) +instance Group crypto => ToJSON (Proof crypto v c) where toJSON Proof{..} = JSON.object [ "challenge" .= proof_challenge @@ -159,7 +188,7 @@ instance ToJSON (Proof c) where ( "challenge" .= proof_challenge <> "response" .= proof_response ) -instance Reifies c FFC => FromJSON (Proof c) where +instance (Reifies c crypto, Group crypto) => FromJSON (Proof crypto v c) where parseJSON = JSON.withObject "TrusteePublicKey" $ \o -> do proof_challenge <- o .: "challenge" proof_response <- o .: "response" @@ -191,7 +220,7 @@ type Challenge = E -- 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 +type Oracle list crypto c = list (Commitment crypto c) -> Challenge crypto c -- | @('prove' sec commitmentBases oracle)@ -- returns a 'Proof' that @sec@ is known @@ -211,25 +240,43 @@ type Oracle list c = list (Commitment c) -> Challenge c -- because two 'Proof's using the same 'Commitment' -- can be used to deduce @sec@ (using the special-soundness). prove :: - Reifies c FFC => + forall crypto v c list m r. + Reifies c crypto => + Reifies v Version => + Group crypto => + Multiplicative (FieldElement crypto c) => Monad m => RandomGen r => Functor list => - E c -> list (G c) -> Oracle list c -> S.StateT r m (Proof c) + E crypto c -> + list (G crypto c) -> + Oracle list crypto c -> + S.StateT r m (Proof crypto v 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 (*). + , proof_response = nonce `op` (sec*proof_challenge) } + where + -- | See comments in 'commit'. + op = + if reflect (Proxy @v) `hasVersionTag` versionTagQuicker + then (-) + else (+) -- | Like 'prove' but quicker. It chould replace 'prove' entirely -- when Helios-C specifications will be fixed. proveQuicker :: - Reifies c FFC => + Reifies c crypto => + Reifies v Version => + Group crypto => + Multiplicative (FieldElement crypto c) => Monad m => RandomGen r => Functor list => - E c -> list (G c) -> Oracle list c -> S.StateT r m (Proof c) + E crypto c -> + list (G crypto c) -> + Oracle list crypto c -> + S.StateT r m (Proof crypto v c) proveQuicker sec commitmentBases oracle = do nonce <- random let commitments = (^ nonce) <$> commitmentBases @@ -248,9 +295,10 @@ proveQuicker sec commitmentBases oracle = do -- 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) + Reifies c crypto => + Group crypto => + Monad m => RandomGen r => + S.StateT r m (Proof crypto v c) fakeProof = do proof_challenge <- random proof_response <- random @@ -264,19 +312,39 @@ 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 :: + forall crypto v c. + Reifies v Version => + Reifies c crypto => + Group crypto => + Multiplicative (FieldElement crypto c) => + Proof crypto v c -> + G crypto c -> + G crypto c -> + Commitment crypto c commit Proof{..} base basePowSec = - base^proof_response / - basePowSec^proof_challenge + (base^proof_response) `op` + (basePowSec^proof_challenge) + where + op = + if reflect (Proxy @v) `hasVersionTag` versionTagQuicker + then (*) + else (/) -- 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'. + -- this is compensated by using @('-')@ instead of @('+')@ in 'prove'. {-# INLINE commit #-} -- | Like 'commit' but quicker. It chould replace 'commit' entirely -- when Helios-C specifications will be fixed. -commitQuicker :: Reifies c FFC => Proof c -> G c -> G c -> Commitment c +commitQuicker :: + Reifies c crypto => + Multiplicative (FieldElement crypto c) => + Proof crypto v c -> + G crypto c -> + G crypto c -> + Commitment crypto c commitQuicker Proof{..} base basePowSec = base^proof_response * basePowSec^proof_challenge @@ -287,29 +355,50 @@ commitQuicker Proof{..} base basePowSec = -- that an 'encryption_vault' contains a given @('groupGen' '^'opinion)@, type Disjunction = G -booleanDisjunctions :: Reifies c FFC => [Disjunction c] -booleanDisjunctions = List.take 2 groupGenInverses +booleanDisjunctions :: + forall crypto c. + Reifies c crypto => + Group crypto => + Multiplicative (FieldElement crypto c) => + [Disjunction crypto c] +booleanDisjunctions = List.take 2 $ groupGenInverses @crypto -intervalDisjunctions :: Reifies c FFC => Natural -> Natural -> [Disjunction c] +intervalDisjunctions :: + forall crypto c. + Reifies c crypto => + Group crypto => + Multiplicative (FieldElement crypto c) => + Natural -> Natural -> [Disjunction crypto c] intervalDisjunctions mini maxi = List.genericTake (fromJust $ (nat maxi + 1)`minusNaturalMaybe`nat mini) $ List.genericDrop (nat mini) $ - groupGenInverses + groupGenInverses @crypto -- ** Type 'Opinion' -- | Index of a 'Disjunction' within a list of them. --- It is encrypted as an 'E'xponent by 'encrypt'. +-- It is encrypted as a 'GroupExponent' 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] +newtype DisjProof crypto v c = DisjProof [Proof crypto v 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) + deriving newtype (NFData,ToJSON,FromJSON) +{- +deriving instance Eq (GroupExponent crypto c) => Eq (DisjProof crypto v c) +deriving instance Show (GroupExponent crypto c) => Show (DisjProof crypto v c) +deriving newtype instance NFData (GroupExponent crypto c) => NFData (DisjProof crypto v c) +deriving newtype instance + ( Reifies c crypto + , ToJSON (GroupExponent crypto c) + ) => ToJSON (DisjProof crypto v c) +deriving newtype instance + ( Reifies c crypto + , FromJSON (GroupExponent crypto c) + ) => FromJSON (DisjProof crypto v c) +-} -- | @('proveEncryption' elecPubKey voterZKP (prevDisjs,nextDisjs) (encNonce,enc))@ -- returns a 'DisjProof' that 'enc' 'encrypt's @@ -322,12 +411,16 @@ deriving newtype instance Reifies c FFC => FromJSON (DisjProof c) -- -- DOC: Pierrick Gaudry. , 2017. proveEncryption :: - Reifies c FFC => + Reifies v Version => + Reifies c crypto => + Group crypto => + ToNatural (FieldElement crypto c) => + Multiplicative (FieldElement crypto c) => Monad m => RandomGen r => - PublicKey c -> ZKP -> - ([Disjunction c],[Disjunction c]) -> - (EncryptionNonce c, Encryption c) -> - S.StateT r m (DisjProof c) + PublicKey crypto c -> ZKP -> + ([Disjunction crypto c],[Disjunction crypto c]) -> + (EncryptionNonce crypto c, Encryption crypto v c) -> + S.StateT r m (DisjProof crypto v 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 @@ -351,9 +444,14 @@ proveEncryption elecPubKey voterZKP (prevDisjs,nextDisjs) (encNonce,enc) = do return (DisjProof proofs) verifyEncryption :: - Reifies c FFC => Monad m => - PublicKey c -> ZKP -> - [Disjunction c] -> (Encryption c, DisjProof c) -> + Reifies v Version => + Reifies c crypto => + Group crypto => + ToNatural (FieldElement crypto c) => + Multiplicative (FieldElement crypto c) => + Monad m => + PublicKey crypto c -> ZKP -> + [Disjunction crypto c] -> (Encryption crypto v c, DisjProof crypto v c) -> ExceptT ErrorVerifyEncryption m Bool verifyEncryption elecPubKey voterZKP disjs (enc, DisjProof proofs) = case isoZipWith (encryptionCommitments elecPubKey enc) disjs proofs of @@ -368,7 +466,10 @@ verifyEncryption elecPubKey voterZKP disjs (enc, DisjProof proofs) = challengeSum = sum (proof_challenge <$> proofs) -- ** Hashing -encryptionStatement :: Reifies c FFC => ZKP -> Encryption c -> BS.ByteString +encryptionStatement :: + Reifies c crypto => + ToNatural (FieldElement crypto c) => + ZKP -> Encryption crypto v c -> BS.ByteString encryptionStatement (ZKP voterZKP) Encryption{..} = "prove|"<>voterZKP<>"|" <> bytesNat encryption_nonce<>"," @@ -380,9 +481,12 @@ encryptionStatement (ZKP voterZKP) Encryption{..} = -- 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] + Reifies v Version => + Reifies c crypto => + Group crypto => + Multiplicative (FieldElement crypto c) => + PublicKey crypto c -> Encryption crypto v c -> + Disjunction crypto c -> Proof crypto v c -> [G crypto c] encryptionCommitments elecPubKey Encryption{..} disj proof = [ commit proof groupGen encryption_nonce -- == groupGen ^ nonce if 'Proof' comes from 'prove'. @@ -402,14 +506,14 @@ data ErrorVerifyEncryption deriving (Eq,Show) -- * Type 'Question' -data Question = Question +data Question v = 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 +instance Reifies v Version => ToJSON (Question v) where toJSON Question{..} = JSON.object [ "question" .= question_text @@ -424,7 +528,7 @@ instance ToJSON Question where <> "min" .= question_mini <> "max" .= question_maxi ) -instance FromJSON Question where +instance Reifies v Version => FromJSON (Question v) where parseJSON = JSON.withObject "Question" $ \o -> do question_text <- o .: "question" question_choices <- o .: "answers" @@ -433,16 +537,24 @@ instance FromJSON Question where return Question{..} -- * Type 'Answer' -data Answer c = Answer - { answer_opinions :: ![(Encryption c, DisjProof c)] +data Answer crypto v c = Answer + { answer_opinions :: ![(Encryption crypto v c, DisjProof crypto v c)] -- ^ Encrypted 'Opinion' for each 'question_choices' -- with a 'DisjProof' that they belong to [0,1]. - , answer_sumProof :: !(DisjProof c) + , answer_sumProof :: !(DisjProof crypto v 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 + } deriving (Generic) +deriving instance Eq (FieldElement crypto c) => Eq (Answer crypto v c) +deriving instance (Show (FieldElement crypto c), Show (G crypto c)) => Show (Answer crypto v c) +deriving instance NFData (FieldElement crypto c) => NFData (Answer crypto v c) +instance + ( Reifies v Version + , Reifies c crypto + , ToJSON (FieldElement crypto c) + , Group crypto + ) => ToJSON (Answer crypto v c) where toJSON Answer{..} = let (answer_choices, answer_individual_proofs) = List.unzip answer_opinions in @@ -459,7 +571,12 @@ instance Reifies c FFC => ToJSON (Answer c) where <> "individual_proofs" .= answer_individual_proofs <> "overall_proof" .= answer_sumProof ) -instance Reifies c FFC => FromJSON (Answer c) where +instance + ( Reifies v Version + , Reifies c crypto + , FromJSON (G crypto c) + , Group crypto + ) => FromJSON (Answer crypto v c) where parseJSON = JSON.withObject "Answer" $ \o -> do answer_choices <- o .: "choices" answer_individual_proofs <- o .: "individual_proofs" @@ -471,11 +588,15 @@ instance Reifies c FFC => FromJSON (Answer c) where -- returns an 'Answer' validable by 'verifyAnswer', -- unless an 'ErrorAnswer' is returned. encryptAnswer :: - Reifies c FFC => + Reifies v Version => + Reifies c crypto => + Group crypto => + Multiplicative (FieldElement crypto c) => + ToNatural (FieldElement crypto c) => Monad m => RandomGen r => - PublicKey c -> ZKP -> - Question -> [Bool] -> - S.StateT r (ExceptT ErrorAnswer m) (Answer c) + PublicKey crypto c -> ZKP -> + Question v -> [Bool] -> + S.StateT r (ExceptT ErrorAnswer m) (Answer crypto v c) encryptAnswer elecPubKey zkp Question{..} opinionByChoice | not (question_mini <= opinionsSum && opinionsSum <= question_maxi) = lift $ throwE $ @@ -511,9 +632,13 @@ encryptAnswer elecPubKey zkp Question{..} opinionByChoice opinions = (\o -> if o then one else zero) <$> opinionByChoice verifyAnswer :: - Reifies c FFC => - PublicKey c -> ZKP -> - Question -> Answer c -> Bool + Reifies v Version => + Reifies c crypto => + Group crypto => + Multiplicative (FieldElement crypto c) => + ToNatural (FieldElement crypto c) => + PublicKey crypto c -> ZKP -> + Question v -> Answer crypto v c -> Bool verifyAnswer elecPubKey zkp Question{..} Answer{..} | List.length question_choices /= List.length answer_opinions = False | otherwise = either (const False) id $ runExcept $ do @@ -538,91 +663,160 @@ data ErrorAnswer deriving (Eq,Show,Generic,NFData) -- * Type 'Election' -data Election c = Election +data Election crypto v c = Election { election_name :: !Text , election_description :: !Text - , election_crypto :: !(ElectionCrypto c) - , election_questions :: ![Question] + , election_questions :: ![Question v] , election_uuid :: !UUID , election_hash :: Base64SHA256 - } deriving (Eq,Show,Generic,NFData) - -instance ToJSON (Election c) where + , election_crypto :: !crypto + , election_version :: !(Maybe Version) + , election_public_key :: !(PublicKey crypto c) + } deriving (Generic) +deriving instance (Eq crypto, Eq (FieldElement crypto c)) => Eq (Election crypto v c) +deriving instance (Show crypto, Show (FieldElement crypto c)) => Show (Election crypto v c) +deriving instance (NFData crypto, NFData (FieldElement crypto c)) => NFData (Election crypto v c) +instance + ( ToJSON crypto + , ToJSON (FieldElement crypto c) + , Reifies v Version + , Reifies c crypto + ) => ToJSON (Election crypto v c) where toJSON Election{..} = - JSON.object - [ "name" .= election_name + JSON.object $ + [ "name" .= election_name , "description" .= election_description - , "public_key" .= election_crypto - , "questions" .= election_questions - , "uuid" .= election_uuid - ] + , ("public_key", JSON.object + [ "group" .= election_crypto + , "y" .= election_public_key + ]) + , "questions" .= election_questions + , "uuid" .= election_uuid + ] <> + maybe [] (\version -> [ "version" .= version ]) election_version toEncoding Election{..} = - JSON.pairs - ( "name" .= election_name + JSON.pairs $ + ( "name" .= election_name <> "description" .= election_description - <> "public_key" .= election_crypto - <> "questions" .= election_questions - <> "uuid" .= election_uuid + <> JSON.pair "public_key" (JSON.pairs $ + "group" .= election_crypto + <> "y" .= election_public_key ) -instance FromJSON (Election ()) where - parseJSON = JSON.withObject "Election" $ \o -> Election - <$> o .: "name" - <*> o .: "description" - <*> o .: "public_key" - <*> o .: "questions" - <*> o .: "uuid" - <*> pure (Base64SHA256 "") - -- NOTE: set in 'readElection'. - -readElection :: FilePath -> ExceptT String IO (Election ()) -readElection filePath = do + <> "questions" .= election_questions + <> "uuid" .= election_uuid + ) <> + maybe mempty ("version" .=) election_version + +readElection :: + ReifyCrypto crypto => + FromJSON crypto => + FilePath -> + (forall v c. + Reifies v Version => + Reifies c crypto => + FieldElementConstraints crypto c => + Election crypto v c -> r) -> + ExceptT String IO r +readElection filePath k = do fileData <- lift $ BS.readFile filePath ExceptT $ return $ - (\e -> e{election_hash=base64SHA256 fileData}) - <$> JSON.eitherDecodeStrict' fileData + jsonEitherFormatError $ + JSON.eitherDecodeStrictWith JSON.jsonEOF + (JSON.iparse (parseElection fileData)) + fileData + where + parseElection fileData = JSON.withObject "Election" $ \o -> do + election_version <- o .:? "version" + reify (fromMaybe stableVersion election_version) $ \(_v::Proxy v) -> do + (election_crypto, elecPubKey) <- + JSON.explicitParseField + (JSON.withObject "public_key" $ \obj -> do + crypto <- obj .: "group" + pubKey :: JSON.Value <- obj .: "y" + return (crypto, pubKey) + ) o "public_key" + reifyCrypto election_crypto $ \(_c::Proxy c) -> do + election_name <- o .: "name" + election_description <- o .: "description" + election_questions <- o .: "questions" :: JSON.Parser [Question v] + election_uuid <- o .: "uuid" + election_public_key :: PublicKey crypto c <- parseJSON elecPubKey + return $ k $ Election + { election_questions = election_questions + , election_public_key = election_public_key + , election_hash = base64SHA256 fileData + , .. + } -hashElection :: Election c -> Base64SHA256 +hashElection :: + ToJSON crypto => + Reifies c crypto => + Reifies v Version => + ToJSON (FieldElement crypto c) => + Election crypto v c -> Base64SHA256 hashElection = base64SHA256 . BSL.toStrict . JSON.encode --- ** Type 'ElectionCrypto' -data ElectionCrypto c = - ElectionCrypto_FFC - { electionCrypto_FFC_params :: !FFC - , electionCrypto_FFC_PublicKey :: !(PublicKey c) - } deriving (Eq,Show,Generic,NFData) +-- ** Class 'ReifyCrypto' +-- | @('reifyCrypto' crypto k)@ is like @('reify' crypto k)@ +-- but gives to @(k)@ more constraints than just @('Reifies' c crypto)@, +-- which is used when defining classes on @(crypto)@ +-- where @(c)@ (the type variable guarantying the same +-- @crypto@graphic parameters are used throughout) +-- is not yet in scope and thus where one cannot +-- add those constraints requiring to have @(c)@ in scope. +-- See for instance the 'QuickcheckElection' class, in the tests. +-- +-- For convenience, the 'ReifyCrypto' class also implies the pervasive +-- constraint 'Group'. +class + ( Group crypto + , Key crypto + , Show crypto + , NFData crypto + , JSON.ToJSON crypto + , JSON.FromJSON crypto + ) => ReifyCrypto crypto where + reifyCrypto :: + crypto -> (forall c. + Reifies c crypto => + FieldElementConstraints crypto c => + Proxy c -> r) -> r +instance ReifyCrypto FFC where + reifyCrypto = reify -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)) +-- ** Class 'FieldElementConstraints' +-- | List the 'Constraint's on the element of the field +-- when the @(crypto)@ has not been instantiated to a specific type yet. +-- It concerns only 'Constraint's whose method act on @(a)@, +-- not @(x c)@ (eg. 'Group'). +type FieldElementConstraints crypto c = + ( Multiplicative (FieldElement crypto c) + , FromNatural (FieldElement crypto c) + , ToNatural (FieldElement crypto c) + , Eq (FieldElement crypto c) + , Ord (FieldElement crypto c) + , Show (FieldElement crypto c) + , NFData (FieldElement crypto c) + , FromJSON (FieldElement crypto c) + , ToJSON (FieldElement crypto c) + , FromJSON (G crypto c) + , ToJSON (G crypto c) + ) -- * Type 'Ballot' -data Ballot c = Ballot - { ballot_answers :: ![Answer c] - , ballot_signature :: !(Maybe (Signature c)) +data Ballot crypto v c = Ballot + { ballot_answers :: ![Answer crypto v c] + , ballot_signature :: !(Maybe (Signature crypto v c)) , ballot_election_uuid :: !UUID , ballot_election_hash :: !Base64SHA256 - } deriving (Generic,NFData) -instance Reifies c FFC => ToJSON (Ballot c) where + } deriving (Generic) +deriving instance (NFData (FieldElement crypto c), NFData crypto) => NFData (Ballot crypto v c) +instance + ( Reifies v Version + , Reifies c crypto + , Group crypto + , ToJSON (FieldElement crypto c) + ) => ToJSON (Ballot crypto v c) where toJSON Ballot{..} = JSON.object $ [ "answers" .= ballot_answers @@ -636,8 +830,13 @@ instance Reifies c FFC => ToJSON (Ballot c) where <> "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 + maybe mempty ("signature" .=) ballot_signature +instance + ( Reifies v Version + , Reifies c crypto + , Group crypto + , FromJSON (G crypto c) + ) => FromJSON (Ballot crypto v c) where parseJSON = JSON.withObject "Ballot" $ \o -> do ballot_answers <- o .: "answers" ballot_signature <- o .:? "signature" @@ -645,16 +844,22 @@ instance Reifies c FFC => FromJSON (Ballot c) where ballot_election_hash <- o .: "election_hash" return Ballot{..} --- | @('encryptBallot' elec ('Just' ballotSecKey) opinionsByQuest)@ +-- | @('encryptBallot' c ('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 => + forall crypto m v c r. + Reifies c crypto => + Reifies v Version => + Group crypto => + Key crypto => + Multiplicative (FieldElement crypto c) => + ToNatural (FieldElement crypto c) => Monad m => RandomGen r => - Election c -> - Maybe (SecretKey c) -> [[Bool]] -> - S.StateT r (ExceptT ErrorBallot m) (Ballot c) + Election crypto v c -> + Maybe (SecretKey crypto c) -> [[Bool]] -> + S.StateT r (ExceptT ErrorBallot m) (Ballot crypto v c) encryptBallot Election{..} ballotSecKeyMay opinionsByQuest | List.length election_questions /= List.length opinionsByQuest = lift $ throwE $ @@ -671,7 +876,7 @@ encryptBallot Election{..} ballotSecKeyMay opinionsByQuest where ballotPubKey = publicKey ballotSecKey ballot_answers <- S.mapStateT (withExceptT ErrorBallot_Answer) $ - zipWithM (encryptAnswer (electionCrypto_FFC_PublicKey election_crypto) voterZKP) + zipWithM (encryptAnswer election_public_key voterZKP) election_questions opinionsByQuest ballot_signature <- case voterKeys of Nothing -> return Nothing @@ -679,12 +884,12 @@ encryptBallot Election{..} ballotSecKeyMay opinionsByQuest signature_proof <- proveQuicker ballotSecKey (Identity groupGen) $ \(Identity commitment) -> - hash + hash @_ @crypto -- 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) + (signatureCommitments @_ @crypto voterZKP commitment) + (signatureStatement @_ @crypto ballot_answers) return $ Just Signature{..} return Ballot { ballot_answers @@ -693,9 +898,17 @@ encryptBallot Election{..} ballotSecKeyMay opinionsByQuest , ballot_signature } -verifyBallot :: Reifies c FFC => Election c -> Ballot c -> Bool +verifyBallot :: + forall crypto v c. + Reifies v Version => + Reifies c crypto => + Group crypto => + Multiplicative (FieldElement crypto c) => + ToNatural (FieldElement crypto c) => + ToNatural (PublicKey crypto c) => + Election crypto v c -> + Ballot crypto v 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 && @@ -706,11 +919,11 @@ verifyBallot Election{..} Ballot{..} = let zkp = ZKP (bytesNat signature_publicKey) in (, zkp) $ proof_challenge signature_proof == hash - (signatureCommitments zkp (commitQuicker signature_proof groupGen signature_publicKey)) - (signatureStatement ballot_answers) + (signatureCommitments @_ @crypto zkp (commitQuicker signature_proof groupGen signature_publicKey)) + (signatureStatement @_ @crypto ballot_answers) in and $ isValidSign : - List.zipWith (verifyAnswer elecPubKey zkpSign) + List.zipWith (verifyAnswer election_public_key zkpSign) election_questions ballot_answers -- ** Type 'Signature' @@ -719,12 +932,20 @@ verifyBallot Election{..} Ballot{..} = -- 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) +data Signature crypto v c = Signature + { signature_publicKey :: !(PublicKey crypto c) -- ^ Verification key. - , signature_proof :: !(Proof c) - } deriving (Generic,NFData) -instance Reifies c FFC => ToJSON (Signature c) where + , signature_proof :: !(Proof crypto v c) + } deriving (Generic) +deriving instance + ( NFData crypto + , NFData (FieldElement crypto c) + ) => NFData (Signature crypto v c) +instance + ( Reifies c crypto + , Reifies v Version + , ToJSON (FieldElement crypto c) + ) => ToJSON (Signature crypto v c) where toJSON (Signature pubKey Proof{..}) = JSON.object [ "public_key" .= pubKey @@ -737,7 +958,12 @@ instance Reifies c FFC => ToJSON (Signature c) where <> "challenge" .= proof_challenge <> "response" .= proof_response ) -instance Reifies c FFC => FromJSON (Signature c) where +instance + ( Reifies c crypto + , Reifies v Version + , Group crypto + , FromJSON (PublicKey crypto c) + ) => FromJSON (Signature crypto v c) where parseJSON = JSON.withObject "Signature" $ \o -> do signature_publicKey <- o .: "public_key" proof_challenge <- o .: "challenge" @@ -750,14 +976,17 @@ instance Reifies c FFC => FromJSON (Signature c) where -- | @('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 :: Reifies c crypto => Foldable f => f (Answer crypto v c) -> [G crypto c] signatureStatement = foldMap $ \Answer{..} -> (`foldMap` answer_opinions) $ \(Encryption{..}, _proof) -> [encryption_nonce, encryption_vault] -- | @('signatureCommitments' voterZKP commitment)@ -signatureCommitments :: ZKP -> Commitment c -> BS.ByteString +signatureCommitments :: + Reifies c crypto => + ToNatural (FieldElement crypto c) => + ZKP -> Commitment crypto c -> BS.ByteString signatureCommitments (ZKP voterZKP) commitment = "sig|"<>voterZKP<>"|" -- NOTE: this is actually part of the statement <> bytesNat commitment<>"|" @@ -773,3 +1002,59 @@ data ErrorBallot | ErrorBallot_Wrong -- ^ TODO: to be more precise. deriving (Eq,Show,Generic,NFData) + +-- * Type 'Version' +-- | Version of the Helios-C protocol. +data Version = Version + { version_branch :: [Natural] + , version_tags :: [(Text, Natural)] + } deriving (Eq,Ord,Generic,NFData) +instance IsString Version where + fromString = fromJust . readVersion +instance Show Version where + showsPrec _p Version{..} = + List.foldr (.) id + (List.intersperse (showChar '.') $ + showsPrec 0 <$> version_branch) . + List.foldr (.) id + ((\(t,n) -> showChar '-' . showString (Text.unpack t) . + if n > 0 then showsPrec 0 n else id) + <$> version_tags) +instance ToJSON Version where + toJSON = toJSON . show + toEncoding = toEncoding . show +instance FromJSON Version where + parseJSON (JSON.String s) + | Just v <- readVersion (Text.unpack s) + = return v + parseJSON json = JSON.typeMismatch "Version" json + +hasVersionTag :: Version -> Text -> Bool +hasVersionTag v tag = List.any (\(t,_n) -> t == tag) (version_tags v) + +experimentalVersion :: Version +experimentalVersion = stableVersion + {version_tags = [(versionTagQuicker,0)]} + +stableVersion :: Version +stableVersion = "1.6" + +versionTagQuicker :: Text +versionTagQuicker = "quicker" + +readVersion :: String -> Maybe Version +readVersion = parseReadP $ do + version_branch <- Read.sepBy1 + (Read.read <$> Read.munch1 Char.isDigit) + (Read.char '.') + version_tags <- Read.many $ (,) + <$> (Text.pack <$ Read.char '-' <*> Read.munch1 Char.isAlpha) + <*> (Read.read <$> Read.munch1 Char.isDigit <|> return 0) + return Version{..} + +parseReadP :: Read.ReadP a -> String -> Maybe a +parseReadP p s = + let p' = Read.readP_to_S p in + listToMaybe $ do + (x, "") <- p' s + return x diff --git a/hjugement-protocol/src/Voting/Protocol/FFC.hs b/hjugement-protocol/src/Voting/Protocol/FFC.hs index 331ce41..b858e6f 100644 --- a/hjugement-protocol/src/Voting/Protocol/FFC.hs +++ b/hjugement-protocol/src/Voting/Protocol/FFC.hs @@ -1,63 +1,49 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE UndecidableInstances #-} -- for Reifies instances {-# OPTIONS_GHC -fno-warn-orphans #-} -- | Finite Field Cryptography (FFC) -- is a method of implementing discrete logarithm cryptography -- using finite field mathematics. -module Voting.Protocol.FFC - ( module Voting.Protocol.FFC - , Natural - , Random.RandomGen - , Reifies(..), reify - , Proxy(..) - ) where +module Voting.Protocol.FFC where import Control.Arrow (first) import Control.DeepSeq (NFData) import Control.Monad (Monad(..), unless) import Data.Aeson (ToJSON(..),FromJSON(..),(.:),(.:?),(.=)) -import Data.Bits import Data.Bool import Data.Either (Either(..)) import Data.Eq (Eq(..)) -import Data.Foldable (Foldable, foldl') -import Data.Function (($), (.), id) +import Data.Function (($), (.)) import Data.Functor ((<$>)) -import Data.Int (Int) import Data.Maybe (Maybe(..), fromMaybe, fromJust) import Data.Monoid (Monoid(..)) import Data.Ord (Ord(..)) import Data.Proxy (Proxy(..)) -import Data.Reflection (Reifies(..), reify) +import Data.Reflection (Reifies(..)) import Data.Semigroup (Semigroup(..)) -import Data.String (IsString(..)) import Data.Text (Text) import GHC.Generics (Generic) import GHC.Natural (minusNaturalMaybe) import Numeric.Natural (Natural) -import Prelude (Integer, Integral(..), fromIntegral, Enum(..)) +import Prelude (Integral(..), fromIntegral) import Text.Read (readMaybe, readEither) import Text.Show (Show(..)) -import qualified Control.Monad.Trans.State.Strict as S -import qualified Crypto.Hash as Crypto +import qualified Crypto.KDF.PBKDF2 as Crypto import qualified Data.Aeson as JSON import qualified Data.Aeson.Types as JSON -import qualified Data.ByteArray as ByteArray -import qualified Data.ByteString as BS -import qualified Data.ByteString.Base64 as BS64 import qualified Data.Char as Char -import qualified Data.List as List import qualified Data.Text as Text import qualified Data.Text.Encoding as Text -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Builder as TLB -import qualified Data.Text.Lazy.Builder.Int as TLB -import qualified Prelude as Num import qualified System.Random as Random +import Voting.Protocol.Arith +import Voting.Protocol.Credential + -- * Type 'FFC' -- | Mutiplicative Sub-Group of a Finite Prime Field. -- @@ -130,15 +116,14 @@ instance FromJSON FFC where unless (fromJust (ffc_fieldCharac`minusNaturalMaybe`one) `rem` ffc_groupOrder == 0) $ JSON.typeMismatch "FFC: groupOrder does not divide fieldCharac-1" (JSON.Object o) return FFC{..} +instance Group FFC where + groupGen :: forall c. Reifies c FFC => G FFC c + groupGen = G $ F $ ffc_groupGen $ reflect (Proxy::Proxy c) + groupOrder :: forall c. Reifies c FFC => Proxy c -> Natural + groupOrder c = ffc_groupOrder $ reflect c fieldCharac :: forall c. Reifies c FFC => Natural -fieldCharac = ffc_fieldCharac (reflect (Proxy::Proxy c)) - -groupGen :: forall c. Reifies c FFC => G c -groupGen = G $ F $ ffc_groupGen (reflect (Proxy::Proxy c)) - -groupOrder :: forall c. Reifies c FFC => Natural -groupOrder = ffc_groupOrder (reflect (Proxy::Proxy c)) +fieldCharac = ffc_fieldCharac $ reflect (Proxy::Proxy c) -- ** Examples -- | Weak parameters for debugging purposes only. @@ -189,8 +174,7 @@ beleniosFFC = FFC newtype F c = F { unF :: Natural } deriving (Eq,Ord,Show) deriving newtype NFData -instance ToJSON (F c) where - toJSON (F x) = JSON.toJSON (show x) +type instance FieldElement FFC = F instance Reifies c FFC => FromJSON (F c) where parseJSON (JSON.String s) | Just (c0,_) <- Text.uncons s @@ -199,7 +183,20 @@ instance Reifies c FFC => FromJSON (F c) where , Just x <- readMaybe (Text.unpack s) , x < fieldCharac @c = return (F x) - parseJSON json = JSON.typeMismatch "FieldElement" json + parseJSON json = JSON.typeMismatch "FieldElement FFC" json +instance Reifies c FFC => FromJSON (G FFC c) where + parseJSON (JSON.String s) + | Just (c0,_) <- Text.uncons s + , c0 /= '0' + , Text.all Char.isDigit s + , Just x <- readMaybe (Text.unpack s) + , x < fieldCharac @c + , r <- G (F x) + , r ^ E (groupOrder @FFC (Proxy @c)) == one + = return r + parseJSON json = JSON.typeMismatch "GroupElement" json +instance ToJSON (F c) where + toJSON (F x) = JSON.toJSON (show x) instance Reifies c FFC => FromNatural (F c) where fromNatural i = F $ abs $ i `mod` fieldCharac @c where @@ -227,267 +224,19 @@ instance Reifies c FFC => Random.Random (F c) where first (F . fromIntegral) . Random.randomR (0, toInteger (fieldCharac @c) - 1) --- ** Class 'Additive' -class Additive a where - zero :: a - (+) :: a -> a -> a; infixl 6 + - sum :: Foldable f => f a -> a - sum = foldl' (+) zero -instance Additive Natural where - zero = 0 - (+) = (Num.+) -instance Additive Integer where - zero = 0 - (+) = (Num.+) -instance Additive Int where - zero = 0 - (+) = (Num.+) - --- *** Class 'Negable' -class Additive a => Negable a where - neg :: a -> a - (-) :: a -> a -> a; infixl 6 - - x-y = x + neg y -instance Negable Integer where - neg = Num.negate -instance Negable Int where - neg = Num.negate - --- ** Class 'Multiplicative' -class Multiplicative a where - one :: a - (*) :: a -> a -> a; infixl 7 * -instance Multiplicative Natural where - one = 1 - (*) = (Num.*) -instance Multiplicative Integer where - one = 1 - (*) = (Num.*) -instance Multiplicative Int where - one = 1 - (*) = (Num.*) - --- ** Class 'Invertible' -class Multiplicative a => Invertible a where - inv :: a -> a - (/) :: a -> a -> a; infixl 7 / - x/y = x * inv y - --- * Type 'G' --- | The type of the elements of a 'Multiplicative' subgroup of a Finite Prime Field. -newtype G c = G { unG :: F c } - deriving (Eq,Ord,Show) - deriving newtype NFData -instance ToJSON (G c) where - toJSON (G x) = JSON.toJSON x -instance Reifies c FFC => FromJSON (G c) where - parseJSON (JSON.String s) - | Just (c0,_) <- Text.uncons s - , c0 /= '0' - , Text.all Char.isDigit s - , Just x <- readMaybe (Text.unpack s) - , x < fieldCharac @c - , r <- G (F x) - , r ^ E (groupOrder @c) == one - = return r - parseJSON json = JSON.typeMismatch "GroupElement" json -instance Reifies c FFC => FromNatural (G c) where - fromNatural = G . fromNatural -instance ToNatural (G c) where - nat = unF . unG -instance Reifies c FFC => Multiplicative (G c) where - one = G $ F one - G x * G y = G (x * y) -instance Reifies c FFC => Invertible (G c) where - -- | NOTE: add 'groupOrder' so the exponent given to (^) is positive. - inv = (^ E (fromJust $ groupOrder @c`minusNaturalMaybe`1)) - --- | 'groupGenInverses' returns the infinite list --- of 'inv'erse powers of 'groupGen': --- @['groupGen' '^' 'neg' i | i <- [0..]]@, --- but by computing each value from the previous one. --- --- Used by 'intervalDisjunctions'. -groupGenInverses :: forall c. Reifies c FFC => [G c] -groupGenInverses = go one - where - invGen = inv $ groupGen @c - go g = g : go (g * invGen) - -groupGenPowers :: forall c. Reifies c FFC => [G c] -groupGenPowers = go one - where go g = g : go (g * groupGen @c) - --- ** Type 'Hash' -newtype Hash c = Hash (E c) - deriving (Eq,Ord,Show) - deriving newtype NFData - --- | @('hash' bs gs)@ returns as a number in 'E' --- the 'Crypto.SHA256' hash of the given 'BS.ByteString' 'bs' --- prefixing the decimal representation of given subgroup elements 'gs', --- with a comma (",") intercalated between them. --- --- NOTE: to avoid any collision when the 'hash' function is used in different contexts, --- a message 'gs' is actually prefixed by a 'bs' indicating the context. --- --- Used by 'proveEncryption' and 'verifyEncryption', --- where the 'bs' usually contains the 'statement' to be proven, --- and the 'gs' contains the 'commitments'. -hash :: Reifies c FFC => BS.ByteString -> [G c] -> E c -hash bs gs = do - let s = bs <> BS.intercalate (fromString ",") (bytesNat <$> gs) - let h = Crypto.hashWith Crypto.SHA256 s - fromNatural $ - decodeBigEndian $ ByteArray.convert h - --- | @('decodeBigEndian' bs)@ interpret @bs@ as big-endian number. -decodeBigEndian :: BS.ByteString -> Natural -decodeBigEndian = - BS.foldl' - (\acc b -> acc`shiftL`8 + fromIntegral b) - (0::Natural) - --- ** Type 'Base64SHA256' -newtype Base64SHA256 = Base64SHA256 Text - deriving (Eq,Ord,Show,Generic) - deriving anyclass (ToJSON,FromJSON) - deriving newtype NFData - --- | @('base64SHA256' bs)@ returns the 'Crypto.SHA256' hash --- of the given 'BS.ByteString' 'bs', --- as a 'Text' escaped in @base64@ encoding --- (). -base64SHA256 :: BS.ByteString -> Base64SHA256 -base64SHA256 bs = - let h = Crypto.hashWith Crypto.SHA256 bs in - Base64SHA256 $ - Text.takeWhile (/= '=') $ -- NOTE: no padding. - Text.decodeUtf8 $ BS64.encode $ ByteArray.convert h - --- ** Type 'HexSHA256' -newtype HexSHA256 = HexSHA256 Text - deriving (Eq,Ord,Show,Generic) - deriving anyclass (ToJSON,FromJSON) - deriving newtype NFData --- | @('hexSHA256' bs)@ returns the 'Crypto.SHA256' hash --- of the given 'BS.ByteString' 'bs', escaped in hexadecimal --- into a 'Text' of 32 lowercase characters. --- --- Used (in retro-dependencies of this library) to hash --- the 'PublicKey' of a voter or a trustee. -hexSHA256 :: BS.ByteString -> Text -hexSHA256 bs = - let h = Crypto.hashWith Crypto.SHA256 bs in - let n = decodeBigEndian $ ByteArray.convert h in - -- NOTE: always set the 256 bit then remove it - -- to always have leading zeros, - -- and thus always 64 characters wide hashes. - TL.toStrict $ - TL.tail $ TLB.toLazyText $ TLB.hexadecimal $ - setBit n 256 - --- * Type 'E' --- | An exponent of a (necessarily cyclic) subgroup of a Finite Prime Field. --- The value is always in @[0..'groupOrder'-1]@. -newtype E c = E { unE :: Natural } - deriving (Eq,Ord,Show) - deriving newtype NFData -instance ToJSON (E c) where - toJSON (E x) = JSON.toJSON (show x) -instance Reifies c FFC => FromJSON (E c) where - parseJSON (JSON.String s) - | Just (c0,_) <- Text.uncons s - , c0 /= '0' - , Text.all Char.isDigit s - , Just x <- readMaybe (Text.unpack s) - , x < groupOrder @c - = return (E x) - parseJSON json = JSON.typeMismatch "Exponent" json - -instance Reifies c FFC => FromNatural (E c) where - fromNatural i = - E $ abs $ i `mod` groupOrder @c - where - abs x | x < 0 = x + groupOrder @c - | otherwise = x -instance ToNatural (E c) where - nat = unE - -instance Reifies c FFC => Additive (E c) where - zero = E zero - E x + E y = E $ (x + y) `mod` groupOrder @c -instance Reifies c FFC => Negable (E c) where - neg (E x) - | x == 0 = zero - | otherwise = E $ fromJust $ nat (groupOrder @c)`minusNaturalMaybe`x -instance Reifies c FFC => Multiplicative (E c) where - one = E one - E x * E y = E $ (x * y) `mod` groupOrder @c -instance Reifies c FFC => Random.Random (E c) where - randomR (E lo, E hi) = - first (E . fromIntegral) . - Random.randomR - ( 0`max`toInteger lo - , toInteger hi`min`(toInteger (groupOrder @c) - 1) ) - random = - first (E . fromIntegral) . - Random.randomR (0, toInteger (groupOrder @c) - 1) -instance Reifies c FFC => Enum (E c) where - toEnum = fromNatural . fromIntegral - fromEnum = fromIntegral . nat - enumFromTo lo hi = List.unfoldr - (\i -> if i<=hi then Just (i, i+one) else Nothing) lo - -infixr 8 ^ --- | @(b '^' e)@ returns the modular exponentiation of base 'b' by exponent 'e'. -(^) :: Reifies c FFC => G c -> E c -> G c -(^) b (E e) - | e == 0 = one - | otherwise = t * (b*b) ^ E (e`shiftR`1) - where - t | testBit e 0 = b - | otherwise = one - --- | @('randomR' i)@ returns a random integer in @[0..i-1]@. -randomR :: - Monad m => - Random.RandomGen r => - Random.Random i => - Negable i => - Multiplicative i => - i -> S.StateT r m i -randomR i = S.StateT $ return . Random.randomR (zero, i-one) - --- | @('random')@ returns a random integer --- in the range determined by its type. -random :: - Monad m => - Random.RandomGen r => - Random.Random i => - Negable i => - Multiplicative i => - S.StateT r m i -random = S.StateT $ return . Random.random - -instance Random.Random Natural where - randomR (mini,maxi) = - first (fromIntegral::Integer -> Natural) . - Random.randomR (fromIntegral mini, fromIntegral maxi) - random = first (fromIntegral::Integer -> Natural) . Random.random - -- * Conversions --- ** Class 'FromNatural' -class FromNatural a where - fromNatural :: Natural -> a - --- ** Class 'ToNatural' -class ToNatural a where - nat :: a -> Natural -instance ToNatural Natural where - nat = id - --- | @('bytesNat' x)@ returns the serialization of 'x'. -bytesNat :: ToNatural n => n -> BS.ByteString -bytesNat = fromString . show . nat +instance Key FFC where + cryptoType _ = "FFC" + cryptoName = ffc_name + randomSecretKey = random + credentialSecretKey (UUID uuid) (Credential cred) = + fromNatural $ decodeBigEndian $ + Crypto.fastPBKDF2_SHA256 + Crypto.Parameters + { Crypto.iterCounts = 1000 + , Crypto.outputLength = 32 -- bytes, ie. 256 bits + } + (Text.encodeUtf8 cred) + (Text.encodeUtf8 uuid) + publicKey = (groupGen @FFC ^) diff --git a/hjugement-protocol/src/Voting/Protocol/Tally.hs b/hjugement-protocol/src/Voting/Protocol/Tally.hs index 5113155..5fbbee1 100644 --- a/hjugement-protocol/src/Voting/Protocol/Tally.hs +++ b/hjugement-protocol/src/Voting/Protocol/Tally.hs @@ -14,9 +14,12 @@ import Data.Function (($), (.)) import Data.Functor ((<$>)) import Data.Maybe (maybe) import Data.Semigroup (Semigroup(..)) +import Data.Ord (Ord(..)) +import Data.Reflection (Reifies(..)) import Data.Tuple (fst, snd) import GHC.Generics (Generic) import Numeric.Natural (Natural) +import System.Random (RandomGen) import Text.Show (Show(..)) import qualified Data.Aeson as JSON import qualified Data.Aeson.Types as JSON @@ -27,12 +30,12 @@ import qualified Data.List as List import qualified Data.Map.Strict as Map import Voting.Protocol.Utils -import Voting.Protocol.FFC +import Voting.Protocol.Arith import Voting.Protocol.Credential import Voting.Protocol.Election -- * Type 'Tally' -data Tally c = Tally +data Tally crypto v c = Tally { tally_countMax :: !Natural -- ^ The maximal number of supportive 'Opinion's that a choice can get, -- which is here the same as the number of 'Ballot's. @@ -40,14 +43,22 @@ data Tally c = Tally -- Used in 'proveTally' to decrypt the actual -- count of votes obtained by a choice, -- by precomputing all powers of 'groupGen's up to it. - , tally_encByChoiceByQuest :: !(EncryptedTally c) + , tally_encByChoiceByQuest :: !(EncryptedTally crypto v c) -- ^ 'Encryption' by 'Question' by 'Ballot'. - , tally_decShareByTrustee :: ![DecryptionShare c] + , tally_decShareByTrustee :: ![DecryptionShare crypto v c] -- ^ 'DecryptionShare' by trustee. , tally_countByChoiceByQuest :: ![[Natural]] -- ^ The decrypted count of supportive 'Opinion's, by choice by 'Question'. - } deriving (Eq,Show,Generic,NFData) -instance Reifies c FFC => ToJSON (Tally c) where + } deriving (Generic) +deriving instance Eq (FieldElement crypto c) => Eq (Tally crypto v c) +deriving instance (Show (FieldElement crypto c), Show (G crypto c)) => Show (Tally crypto v c) +deriving instance NFData (FieldElement crypto c) => NFData (Tally crypto v c) +instance + ( Reifies v Version + , Reifies c crypto + , Group crypto + , ToJSON (FieldElement crypto c) + ) => ToJSON (Tally crypto v c) where toJSON Tally{..} = JSON.object [ "num_tallied" .= tally_countMax @@ -62,7 +73,12 @@ instance Reifies c FFC => ToJSON (Tally c) where <> "partial_decryptions" .= tally_decShareByTrustee <> "result" .= tally_countByChoiceByQuest ) -instance Reifies c FFC => FromJSON (Tally c) where +instance + ( Reifies v Version + , Reifies c crypto + , Group crypto + , FromJSON (G crypto c) + ) => FromJSON (Tally crypto v c) where parseJSON = JSON.withObject "Tally" $ \o -> do tally_countMax <- o .: "num_tallied" tally_encByChoiceByQuest <- o .: "encrypted_tally" @@ -72,22 +88,31 @@ instance Reifies c FFC => FromJSON (Tally c) where -- ** Type 'EncryptedTally' -- | 'Encryption' by choice by 'Question'. -type EncryptedTally c = [[Encryption c]] +type EncryptedTally crypto v c = [[Encryption crypto v c]] -- | @('encryptedTally' ballots)@ -- returns the sum of the 'Encryption's of the given @ballots@, -- along with the number of 'Ballot's. -encryptedTally :: Reifies c FFC => [Ballot c] -> (EncryptedTally c, Natural) +encryptedTally :: + Reifies c crypto => + Multiplicative (FieldElement crypto c) => + [Ballot crypto v c] -> (EncryptedTally crypto v c, Natural) encryptedTally = List.foldr insertEncryptedTally emptyEncryptedTally -- | The initial 'EncryptedTally' which tallies no 'Ballot'. -emptyEncryptedTally :: Reifies c FFC => (EncryptedTally c, Natural) +emptyEncryptedTally :: + Reifies c crypto => + Multiplicative (FieldElement crypto c) => + (EncryptedTally crypto v c, Natural) emptyEncryptedTally = (List.repeat (List.repeat zero), 0) -- | @('insertEncryptedTally' ballot encTally)@ -- returns the 'EncryptedTally' adding the votes of the given @(ballot)@ -- to those of the given @(encTally)@. -insertEncryptedTally :: Reifies c FFC => Ballot c -> (EncryptedTally c, Natural) -> (EncryptedTally c, Natural) +insertEncryptedTally :: + Reifies c crypto => + Multiplicative (FieldElement crypto c) => + Ballot crypto v c -> (EncryptedTally crypto v c, Natural) -> (EncryptedTally crypto v c, Natural) insertEncryptedTally Ballot{..} (encTally, numBallots) = ( List.zipWith (\Answer{..} -> List.zipWith (+) (fst <$> answer_opinions)) @@ -97,14 +122,19 @@ insertEncryptedTally Ballot{..} (encTally, numBallots) = ) -- ** Type 'DecryptionShareCombinator' -type DecryptionShareCombinator c = - EncryptedTally c -> [DecryptionShare c] -> Except ErrorTally [[DecryptionFactor c]] +type DecryptionShareCombinator crypto v c = + EncryptedTally crypto v c -> + [DecryptionShare crypto v c] -> + Except ErrorTally [[DecryptionFactor crypto c]] proveTally :: - Reifies c FFC => - (EncryptedTally c, Natural) -> [DecryptionShare c] -> - DecryptionShareCombinator c -> - Except ErrorTally (Tally c) + Reifies c crypto => + Group crypto => + Multiplicative (FieldElement crypto c) => + Ord (FieldElement crypto c) => + (EncryptedTally crypto v c, Natural) -> [DecryptionShare crypto v c] -> + DecryptionShareCombinator crypto v c -> + Except ErrorTally (Tally crypto v c) proveTally (tally_encByChoiceByQuest, tally_countMax) tally_decShareByTrustee @@ -126,8 +156,12 @@ proveTally return Tally{..} verifyTally :: - Reifies c FFC => - Tally c -> DecryptionShareCombinator c -> + Reifies c crypto => + Group crypto => + Multiplicative (FieldElement crypto c) => + Eq (FieldElement crypto c) => + Tally crypto v c -> + DecryptionShareCombinator crypto v c -> Except ErrorTally () verifyTally Tally{..} decShareCombinator = do decFactorByChoiceByQuest <- decShareCombinator tally_encByChoiceByQuest tally_decShareByTrustee @@ -144,11 +178,16 @@ verifyTally Tally{..} decShareCombinator = do -- ** Type 'DecryptionShare' -- | A decryption share is a 'DecryptionFactor' and a decryption 'Proof', by choice by 'Question'. -- Computed by a trustee in 'proveDecryptionShare'. -newtype DecryptionShare c = DecryptionShare - { unDecryptionShare :: [[(DecryptionFactor c, Proof c)]] } - deriving (Eq,Show,Generic) -deriving newtype instance NFData (DecryptionShare c) -instance ToJSON (DecryptionShare c) where +newtype DecryptionShare crypto v c = DecryptionShare + { unDecryptionShare :: [[(DecryptionFactor crypto c, Proof crypto v c)]] } + deriving (Generic) +deriving instance Eq (FieldElement crypto c) => Eq (DecryptionShare crypto v c) +deriving instance Show (G crypto c) => Show (DecryptionShare crypto v c) +deriving newtype instance NFData (FieldElement crypto c) => NFData (DecryptionShare crypto v c) +instance + ( Group crypto + , ToJSON (FieldElement crypto c) + ) => ToJSON (DecryptionShare crypto v c) where toJSON (DecryptionShare decByChoiceByQuest) = JSON.object [ "decryption_factors" .= @@ -162,7 +201,11 @@ instance ToJSON (DecryptionShare c) where (JSON.list (JSON.list (toEncoding . fst)) decByChoiceByQuest) <> JSON.pair "decryption_proofs" (JSON.list (JSON.list (toEncoding . snd)) decByChoiceByQuest) -instance Reifies c FFC => FromJSON (DecryptionShare c) where +instance + ( Reifies c crypto + , Group crypto + , FromJSON (G crypto c) + ) => FromJSON (DecryptionShare crypto v c) where parseJSON = JSON.withObject "DecryptionShare" $ \o -> do decFactors <- o .: "decryption_factors" decProofs <- o .: "decryption_proofs" @@ -179,21 +222,36 @@ type DecryptionFactor = G -- @('proveDecryptionShare' encByChoiceByQuest trusteeSecKey)@ proveDecryptionShare :: - Monad m => Reifies c FFC => RandomGen r => - EncryptedTally c -> SecretKey c -> S.StateT r m (DecryptionShare c) + Reifies v Version => + Reifies c crypto => + Group crypto => + Multiplicative (FieldElement crypto c) => + Key crypto => + ToNatural (FieldElement crypto c) => + Monad m => RandomGen r => + EncryptedTally crypto v c -> SecretKey crypto c -> S.StateT r m (DecryptionShare crypto v c) proveDecryptionShare encByChoiceByQuest trusteeSecKey = (DecryptionShare <$>) $ (proveDecryptionFactor trusteeSecKey `mapM`) `mapM` encByChoiceByQuest proveDecryptionFactor :: - Monad m => Reifies c FFC => RandomGen r => - SecretKey c -> Encryption c -> S.StateT r m (DecryptionFactor c, Proof c) + Reifies v Version => + Reifies c crypto => + Group crypto => + Multiplicative (FieldElement crypto c) => + Key crypto => + ToNatural (FieldElement crypto c) => + Monad m => RandomGen r => + SecretKey crypto c -> Encryption crypto v c -> S.StateT r m (DecryptionFactor crypto c, Proof crypto v c) proveDecryptionFactor trusteeSecKey Encryption{..} = do proof <- prove trusteeSecKey [groupGen, encryption_nonce] (hash zkp) return (encryption_nonce^trusteeSecKey, proof) where zkp = decryptionShareStatement (publicKey trusteeSecKey) -decryptionShareStatement :: Reifies c FFC => PublicKey c -> BS.ByteString +decryptionShareStatement :: + Reifies c crypto => + ToNatural (FieldElement crypto c) => + PublicKey crypto c -> BS.ByteString decryptionShareStatement pubKey = "decrypt|"<>bytesNat pubKey<>"|" @@ -218,8 +276,13 @@ data ErrorTally -- (supposedly submitted by a trustee whose 'PublicKey' is 'trusteePubKey') -- is valid with respect to the 'EncryptedTally' 'encTally'. verifyDecryptionShare :: - Monad m => Reifies c FFC => - EncryptedTally c -> PublicKey c -> DecryptionShare c -> + Reifies v Version => + Reifies c crypto => + Group crypto => + Multiplicative (FieldElement crypto c) => + ToNatural (FieldElement crypto c) => + Monad m => + EncryptedTally crypto v c -> PublicKey crypto c -> DecryptionShare crypto v c -> ExceptT ErrorTally m () verifyDecryptionShare encByChoiceByQuest trusteePubKey (DecryptionShare decShare) = let zkp = decryptionShareStatement trusteePubKey in @@ -234,8 +297,13 @@ verifyDecryptionShare encByChoiceByQuest trusteePubKey (DecryptionShare decShare decShare verifyDecryptionShareByTrustee :: - Monad m => Reifies c FFC => - EncryptedTally c -> [PublicKey c] -> [DecryptionShare c] -> + Reifies v Version => + Reifies c crypto => + Group crypto => + Multiplicative (FieldElement crypto c) => + ToNatural (FieldElement crypto c) => + Monad m => + EncryptedTally crypto v c -> [PublicKey crypto c] -> [DecryptionShare crypto v c] -> ExceptT ErrorTally m () verifyDecryptionShareByTrustee encTally = isoZipWithM_ (throwE ErrorTally_NumberOfTrustees) diff --git a/hjugement-protocol/src/Voting/Protocol/Trustee/Indispensable.hs b/hjugement-protocol/src/Voting/Protocol/Trustee/Indispensable.hs index 2777ddd..95f1a03 100644 --- a/hjugement-protocol/src/Voting/Protocol/Trustee/Indispensable.hs +++ b/hjugement-protocol/src/Voting/Protocol/Trustee/Indispensable.hs @@ -12,9 +12,11 @@ import Data.Eq (Eq(..)) import Data.Function (($)) import Data.Functor ((<$>)) import Data.Maybe (maybe) +import Data.Reflection (Reifies(..)) import Data.Semigroup (Semigroup(..)) import Data.Tuple (fst) import GHC.Generics (Generic) +import System.Random (RandomGen) import Text.Show (Show(..)) import qualified Control.Monad.Trans.State.Strict as S import qualified Data.Aeson as JSON @@ -22,15 +24,15 @@ import qualified Data.ByteString as BS import qualified Data.List as List import Voting.Protocol.Utils -import Voting.Protocol.FFC +import Voting.Protocol.Arith import Voting.Protocol.Credential import Voting.Protocol.Election import Voting.Protocol.Tally -- * Type 'TrusteePublicKey' -data TrusteePublicKey c = TrusteePublicKey - { trustee_PublicKey :: !(PublicKey c) - , trustee_SecretKeyProof :: !(Proof c) +data TrusteePublicKey crypto v c = TrusteePublicKey + { trustee_PublicKey :: !(PublicKey crypto c) + , trustee_SecretKeyProof :: !(Proof crypto v c) -- ^ NOTE: It is important to ensure -- that each trustee generates its key pair independently -- of the 'PublicKey's published by the other trustees. @@ -44,8 +46,14 @@ data TrusteePublicKey c = TrusteePublicKey -- must 'prove' knowledge of the corresponding 'SecretKey'. -- Which is done in 'proveIndispensableTrusteePublicKey' -- and 'verifyIndispensableTrusteePublicKey'. - } deriving (Eq,Show,Generic,NFData) -instance ToJSON (TrusteePublicKey c) where + } deriving (Generic) +deriving instance Eq (FieldElement crypto c) => Eq (TrusteePublicKey crypto v c) +deriving instance (Show (FieldElement crypto c), Show (PublicKey crypto c)) => Show (TrusteePublicKey crypto v c) +deriving instance NFData (FieldElement crypto c) => NFData (TrusteePublicKey crypto v c) +instance + ( Group crypto + , ToJSON (FieldElement crypto c) + ) => ToJSON (TrusteePublicKey crypto v c) where toJSON TrusteePublicKey{..} = JSON.object [ "pok" .= trustee_SecretKeyProof @@ -56,7 +64,11 @@ instance ToJSON (TrusteePublicKey c) where ( "pok" .= trustee_SecretKeyProof <> "public_key" .= trustee_PublicKey ) -instance Reifies c FFC => FromJSON (TrusteePublicKey c) where +instance + ( Reifies c crypto + , Group crypto + , FromJSON (PublicKey crypto c) + ) => FromJSON (TrusteePublicKey crypto v c) where parseJSON = JSON.withObject "TrusteePublicKey" $ \o -> do trustee_PublicKey <- o .: "public_key" trustee_SecretKeyProof <- o .: "pok" @@ -68,8 +80,14 @@ instance Reifies c FFC => FromJSON (TrusteePublicKey c) where -- returns the 'PublicKey' associated to 'trustSecKey' -- and a 'Proof' of its knowledge. proveIndispensableTrusteePublicKey :: - Reifies c FFC => Monad m => RandomGen r => - SecretKey c -> S.StateT r m (TrusteePublicKey c) + Reifies v Version => + Reifies c crypto => + Group crypto => + Key crypto => + Multiplicative (FieldElement crypto c) => + ToNatural (FieldElement crypto c) => + Monad m => RandomGen r => + SecretKey crypto c -> S.StateT r m (TrusteePublicKey crypto v c) proveIndispensableTrusteePublicKey trustSecKey = do let trustee_PublicKey = publicKey trustSecKey trustee_SecretKeyProof <- @@ -84,8 +102,13 @@ proveIndispensableTrusteePublicKey trustSecKey = do -- does 'prove' that the 'SecretKey' associated with -- the given 'trustee_PublicKey' is known by the trustee. verifyIndispensableTrusteePublicKey :: - Reifies c FFC => Monad m => - TrusteePublicKey c -> + Reifies v Version => + Reifies c crypto => + Group crypto => + Multiplicative (FieldElement crypto c) => + ToNatural (FieldElement crypto c) => + Monad m => + TrusteePublicKey crypto v c -> ExceptT ErrorTrusteePublicKey m () verifyIndispensableTrusteePublicKey TrusteePublicKey{..} = unless ( @@ -102,7 +125,10 @@ data ErrorTrusteePublicKey deriving (Eq,Show) -- ** Hashing -indispensableTrusteePublicKeyStatement :: PublicKey c -> BS.ByteString +indispensableTrusteePublicKeyStatement :: + Reifies c crypto => + ToNatural (FieldElement crypto c) => + PublicKey crypto c -> BS.ByteString indispensableTrusteePublicKeyStatement trustPubKey = "pok|"<>bytesNat trustPubKey<>"|" @@ -111,15 +137,23 @@ indispensableTrusteePublicKeyStatement trustPubKey = -- ** Generating an 'Election''s 'PublicKey' from multiple 'TrusteePublicKey's. combineIndispensableTrusteePublicKeys :: - Reifies c FFC => [TrusteePublicKey c] -> PublicKey c + Reifies c crypto => + Multiplicative (FieldElement crypto c) => + ToNatural (FieldElement crypto c) => + [TrusteePublicKey crypto v c] -> PublicKey crypto c combineIndispensableTrusteePublicKeys = List.foldr (\TrusteePublicKey{..} -> (trustee_PublicKey *)) one -- ** Checking the trustee's 'DecryptionShare's before decrypting an 'EncryptedTally'. verifyIndispensableDecryptionShareByTrustee :: - Reifies c FFC => Monad m => - EncryptedTally c -> [PublicKey c] -> [DecryptionShare c] -> + Reifies v Version => + Reifies c crypto => + Group crypto => + Multiplicative (FieldElement crypto c) => + ToNatural (FieldElement crypto c) => + Monad m => + EncryptedTally crypto v c -> [PublicKey crypto c] -> [DecryptionShare crypto v c] -> ExceptT ErrorTally m () verifyIndispensableDecryptionShareByTrustee encByChoiceByQuest = isoZipWithM_ (throwE $ ErrorTally_NumberOfTrustees) @@ -130,7 +164,12 @@ verifyIndispensableDecryptionShareByTrustee encByChoiceByQuest = -- | @('combineDecryptionShares' pubKeyByTrustee decShareByTrustee)@ -- returns the 'DecryptionFactor's by choice by 'Question' combineIndispensableDecryptionShares :: - Reifies c FFC => [PublicKey c] -> DecryptionShareCombinator c + Reifies v Version => + Reifies c crypto => + Group crypto => + Multiplicative (FieldElement crypto c) => + ToNatural (FieldElement crypto c) => + [PublicKey crypto c] -> DecryptionShareCombinator crypto v c combineIndispensableDecryptionShares pubKeyByTrustee encByChoiceByQuest diff --git a/hjugement-protocol/src/Voting/Protocol/Utils.hs b/hjugement-protocol/src/Voting/Protocol/Utils.hs index 1cc30f0..7952ccf 100644 --- a/hjugement-protocol/src/Voting/Protocol/Utils.hs +++ b/hjugement-protocol/src/Voting/Protocol/Utils.hs @@ -2,12 +2,16 @@ module Voting.Protocol.Utils where import Control.Applicative (Applicative(..)) import Data.Bool +import Data.Either (Either(..), either) import Data.Eq (Eq(..)) import Data.Foldable (sequenceA_) -import Data.Function (($)) +import Data.Function (($), (.)) import Data.Functor ((<$)) import Data.Maybe (Maybe(..), maybe) +import Data.String (String) import Data.Traversable (Traversable(..)) +import Data.Tuple (uncurry) +import qualified Data.Aeson.Internal as JSON import qualified Data.List as List -- | Like ('.') but with two arguments. @@ -58,3 +62,8 @@ isoZipWith3M_ err f as bs cs = maybe err sequenceA_ $ isoZipWith3 f as bs cs +-- | Copied from 'Data.Aeson''s 'eitherFormatError' +-- which is not exported. +jsonEitherFormatError :: Either (JSON.JSONPath, String) a -> Either String a +jsonEitherFormatError = either (Left . uncurry JSON.formatError) Right +{-# INLINE jsonEitherFormatError #-} diff --git a/hjugement-protocol/tests/HUnit.hs b/hjugement-protocol/tests/HUnit.hs index bd6c3f0..752118c 100644 --- a/hjugement-protocol/tests/HUnit.hs +++ b/hjugement-protocol/tests/HUnit.hs @@ -1,15 +1,16 @@ module HUnit where import Test.Tasty +import Voting.Protocol import qualified HUnit.FFC import qualified HUnit.Credential import qualified HUnit.Election import qualified HUnit.Trustee -hunits :: TestTree -hunits = +hunits :: Reifies v Version => Proxy v -> TestTree +hunits v = testGroup "HUnit" - [ HUnit.FFC.hunit - , HUnit.Credential.hunit - , HUnit.Election.hunit - , HUnit.Trustee.hunit + [ HUnit.FFC.hunit v + , HUnit.Credential.hunit v + , HUnit.Election.hunit v + , HUnit.Trustee.hunit v ] diff --git a/hjugement-protocol/tests/HUnit/Credential.hs b/hjugement-protocol/tests/HUnit/Credential.hs index 9602612..12ea5ad 100644 --- a/hjugement-protocol/tests/HUnit/Credential.hs +++ b/hjugement-protocol/tests/HUnit/Credential.hs @@ -8,8 +8,8 @@ import qualified System.Random as Random import Voting.Protocol import Utils -hunit :: TestTree -hunit = testGroup "Credential" +hunit :: Reifies v Version => Proxy v -> TestTree +hunit _v = testGroup "Credential" [ testGroup "randomCredential" [ testCase "0" $ S.evalState randomCredential (Random.mkStdGen 0) @?= @@ -42,8 +42,11 @@ hunit = testGroup "Credential" ] ] -testSecretKey :: FFC -> UUID -> Credential -> Natural -> TestTree -testSecretKey ffc uuid cred exp = - reify ffc $ \(Proxy::Proxy c) -> +testSecretKey :: + ReifyCrypto crypto => + Key crypto => + crypto -> UUID -> Credential -> Natural -> TestTree +testSecretKey crypto uuid cred exp = + reifyCrypto crypto $ \(Proxy::Proxy c) -> testCase (show (uuid,cred)) $ - credentialSecretKey @c uuid cred @?= E exp + credentialSecretKey @_ @c uuid cred @?= E exp diff --git a/hjugement-protocol/tests/HUnit/Election.hs b/hjugement-protocol/tests/HUnit/Election.hs index a2f583b..6715544 100644 --- a/hjugement-protocol/tests/HUnit/Election.hs +++ b/hjugement-protocol/tests/HUnit/Election.hs @@ -4,6 +4,7 @@ module HUnit.Election where import Test.Tasty.HUnit +import qualified Data.Aeson as JSON import qualified Data.List as List import qualified Data.Text as Text import qualified System.Random as Random @@ -12,60 +13,65 @@ import Voting.Protocol import Utils -hunit :: TestTree -hunit = testGroup "Election" +hunit :: Reifies v Version => Proxy v -> TestTree +hunit v = testGroup "Election" $ [ testGroup "groupGenInverses" [ testCase "WeakParams" $ reify weakFFC $ \(Proxy::Proxy c) -> - List.take 10 (groupGenInverses @c) @?= + List.take 10 (groupGenInverses @_ @c) @?= [groupGen^neg (fromNatural n) | n <- [0..9]] , testCase "BeleniosParams" $ reify beleniosFFC $ \(Proxy::Proxy c) -> - List.take 10 (groupGenInverses @c) @?= + List.take 10 (groupGenInverses @_ @c) @?= [groupGen^neg (fromNatural n) | n <- [0..9]] ] , testGroup "encryptBallot" $ - [ testsEncryptBallot weakFFC - , testsEncryptBallot beleniosFFC + [ hunitsEncryptBallot v weakFFC + , hunitsEncryptBallot v beleniosFFC ] ] -testsEncryptBallot :: FFC -> TestTree -testsEncryptBallot ffc = - testGroup (Text.unpack $ ffc_name ffc) - [ testEncryptBallot ffc 0 +hunitsEncryptBallot :: + ReifyCrypto crypto => + JSON.ToJSON crypto => + Key crypto => + Reifies v Version => Proxy v -> + crypto -> TestTree +hunitsEncryptBallot v crypto = + testGroup (Text.unpack $ cryptoName crypto) + [ hunitEncryptBallot v crypto 0 [Question "q1" ["a1","a2","a3"] zero one] [[True, False, False]] (Right True) - , testEncryptBallot ffc 0 + , hunitEncryptBallot v crypto 0 [Question "q1" ["a1","a2","a3"] zero one] [[False, False, False]] (Right True) - , testEncryptBallot ffc 0 + , hunitEncryptBallot v crypto 0 [Question "q1" ["a1","a2","a3"] zero one] [[False, False, False]] (Right True) - , testEncryptBallot ffc 0 + , hunitEncryptBallot v crypto 0 [Question "q1" [] zero one] [] (Left (ErrorBallot_WrongNumberOfAnswers 0 1)) - , testEncryptBallot ffc 0 + , hunitEncryptBallot v crypto 0 [Question "q1" ["a1","a2"] one one] [[True]] (Left (ErrorBallot_Answer (ErrorAnswer_WrongNumberOfOpinions 1 2))) - , testEncryptBallot ffc 0 + , hunitEncryptBallot v crypto 0 [Question "q1" ["a1","a2","a3"] zero one] [[True, True, False]] (Left (ErrorBallot_Answer (ErrorAnswer_WrongSumOfOpinions 2 0 1))) - , testEncryptBallot ffc 0 + , hunitEncryptBallot v crypto 0 [Question "q1" ["a1","a2","a3"] one one] [[False, False, False]] (Left (ErrorBallot_Answer (ErrorAnswer_WrongSumOfOpinions 0 1 1))) - , testEncryptBallot ffc 0 + , hunitEncryptBallot v crypto 0 [Question "q1" ["a1","a2"] one one] [[False, False, True]] (Left (ErrorBallot_Answer (ErrorAnswer_WrongNumberOfOpinions 3 2))) - , testEncryptBallot ffc 0 + , hunitEncryptBallot v crypto 0 [ Question "q1" ["a11","a12","a13"] zero (one+one) , Question "q2" ["a21","a22","a23"] one one ] @@ -74,26 +80,29 @@ testsEncryptBallot ffc = (Right True) ] -testEncryptBallot :: - FFC -> Int -> [Question] -> [[Bool]] -> +hunitEncryptBallot :: + ReifyCrypto crypto => + JSON.ToJSON crypto => + Key crypto => + Reifies v Version => Proxy v -> + crypto -> Int -> [Question v] -> [[Bool]] -> Either ErrorBallot Bool -> TestTree -testEncryptBallot ffc seed quests opins exp = +hunitEncryptBallot v election_crypto seed election_questions opins exp = let got = - reify ffc $ \(Proxy::Proxy c) -> + reifyCrypto election_crypto $ \(Proxy::Proxy c) -> runExcept $ (`evalStateT` Random.mkStdGen seed) $ do - uuid <- randomUUID + election_uuid <- randomUUID cred <- randomCredential - let ballotSecKey = credentialSecretKey @c uuid cred - elecPubKey <- publicKey <$> randomSecretKey + let ballotSecKey = credentialSecretKey @_ @c election_uuid cred + election_public_key <- publicKey <$> randomSecretKey let elec = Election { election_name = "election" , election_description = "description" - , election_crypto = ElectionCrypto_FFC ffc elecPubKey - , election_questions = quests - , election_uuid = uuid , election_hash = hashElection elec + , election_version = Just (reflect v) + , .. } verifyBallot elec <$> encryptBallot elec (Just ballotSecKey) opins diff --git a/hjugement-protocol/tests/HUnit/FFC.hs b/hjugement-protocol/tests/HUnit/FFC.hs index aa74a43..0d68469 100644 --- a/hjugement-protocol/tests/HUnit/FFC.hs +++ b/hjugement-protocol/tests/HUnit/FFC.hs @@ -6,41 +6,45 @@ import Data.Maybe (fromJust) import Test.Tasty.HUnit import Voting.Protocol import Utils +import qualified Data.Text as Text -hunit :: TestTree -hunit = testGroup "FFC" +hunit :: Reifies v Version => Proxy v -> TestTree +hunit _v = testGroup "FFC" [ testGroup "inv" - [ testGroup "WeakParams" - [ testCase "groupGen" $ - reify weakFFC $ \(Proxy::Proxy c) -> - inv (groupGen @c) @?= - groupGen ^ E (fromJust $ groupOrder @c `minusNaturalMaybe` one) - ] - , testGroup "BeleniosParams" - [ testCase "groupGen" $ - reify beleniosFFC $ \(Proxy::Proxy c) -> - inv (groupGen @c) @?= - groupGen ^ E (fromJust $ groupOrder @c `minusNaturalMaybe` one) - ] + [ hunitInv weakFFC + , hunitInv beleniosFFC ] , testGroup "hash" [ testGroup "WeakParams" $ reify weakFFC $ \(Proxy::Proxy c) -> [ testCase "[groupGen]" $ - hash "start" [groupGen @c] @?= + hash "start" [groupGen :: G FFC c] @?= fromNatural 62 , testCase "[groupGen, groupGen]" $ - hash "start" [groupGen @c, groupGen] @?= + hash "start" [groupGen :: G FFC c, groupGen] @?= fromNatural 31 ] , testGroup "BeleniosParams" $ reify beleniosFFC $ \(Proxy::Proxy c) -> [ testCase "[groupGen]" $ - hash "start" [groupGen @c] @?= + hash "start" [groupGen :: G FFC c] @?= fromNatural 75778590284190557660612328423573274641033882642784670156837892421285248292707 , testCase "[groupGen, groupGen]" $ - hash "start" [groupGen @c, groupGen] @?= + hash "start" [groupGen :: G FFC c, groupGen] @?= fromNatural 28798937720387703653439047952832768487958170248947132321730024269734141660223 ] ] ] + +hunitInv :: + forall crypto. + ReifyCrypto crypto => + Key crypto => + crypto -> TestTree +hunitInv crypto = + testGroup (Text.unpack $ cryptoName crypto) + [ testCase "groupGen" $ + reifyCrypto crypto $ \(_c::Proxy c) -> + inv (groupGen :: G crypto c) @?= + groupGen ^ E (fromJust $ groupOrder (Proxy @c) `minusNaturalMaybe` one) + ] diff --git a/hjugement-protocol/tests/HUnit/Trustee.hs b/hjugement-protocol/tests/HUnit/Trustee.hs index 212ea2e..7f1c094 100644 --- a/hjugement-protocol/tests/HUnit/Trustee.hs +++ b/hjugement-protocol/tests/HUnit/Trustee.hs @@ -1,9 +1,10 @@ module HUnit.Trustee where import Test.Tasty +import Voting.Protocol import qualified HUnit.Trustee.Indispensable -hunit :: TestTree -hunit = +hunit :: Reifies v Version => Proxy v -> TestTree +hunit v = testGroup "Trustee" - [ HUnit.Trustee.Indispensable.hunit + [ HUnit.Trustee.Indispensable.hunit v ] diff --git a/hjugement-protocol/tests/HUnit/Trustee/Indispensable.hs b/hjugement-protocol/tests/HUnit/Trustee/Indispensable.hs index b035d5d..63bf549 100644 --- a/hjugement-protocol/tests/HUnit/Trustee/Indispensable.hs +++ b/hjugement-protocol/tests/HUnit/Trustee/Indispensable.hs @@ -12,61 +12,77 @@ import Voting.Protocol import Utils -hunit :: TestTree -hunit = testGroup "Indispensable" +hunit :: Reifies v Version => Proxy v -> TestTree +hunit v = testGroup "Indispensable" $ [ testGroup "verifyIndispensableTrusteePublicKey" $ - [ testsVerifyIndispensableTrusteePublicKey weakFFC + [ testsVerifyIndispensableTrusteePublicKey v weakFFC ] , testGroup "verifyTally" $ - [ testsVerifyTally weakFFC - , testsVerifyTally beleniosFFC + [ testsVerifyTally v weakFFC + , testsVerifyTally v beleniosFFC ] ] -testsVerifyIndispensableTrusteePublicKey :: FFC -> TestTree -testsVerifyIndispensableTrusteePublicKey ffc = - testGroup (Text.unpack $ ffc_name ffc) - [ testVerifyIndispensableTrusteePublicKey ffc 0 (Right ()) +testsVerifyIndispensableTrusteePublicKey :: + ReifyCrypto crypto => + Reifies v Version => Proxy v -> + crypto -> TestTree +testsVerifyIndispensableTrusteePublicKey v crypto = + testGroup (Text.unpack $ cryptoName crypto) + [ testVerifyIndispensableTrusteePublicKey v crypto 0 (Right ()) ] testVerifyIndispensableTrusteePublicKey :: - FFC -> Int -> Either ErrorTrusteePublicKey () -> TestTree -testVerifyIndispensableTrusteePublicKey ffc seed exp = + forall crypto v. + ReifyCrypto crypto => + Reifies v Version => Proxy v -> + crypto -> Int -> Either ErrorTrusteePublicKey () -> TestTree +testVerifyIndispensableTrusteePublicKey (_v::Proxy v) crypto seed exp = + reifyCrypto crypto $ \(Proxy::Proxy c) -> let got = - reify ffc $ \(Proxy::Proxy c) -> runExcept $ (`evalStateT` Random.mkStdGen seed) $ do - trusteeSecKey :: SecretKey c <- randomSecretKey - trusteePubKey <- proveIndispensableTrusteePublicKey trusteeSecKey + trusteeSecKey :: SecretKey crypto c <- randomSecretKey + trusteePubKey :: TrusteePublicKey crypto v c <- proveIndispensableTrusteePublicKey trusteeSecKey lift $ verifyIndispensableTrusteePublicKey trusteePubKey in - testCase (Text.unpack $ ffc_name ffc) $ + testCase (Text.unpack $ cryptoName crypto) $ got @?= exp -testsVerifyTally :: FFC -> TestTree -testsVerifyTally ffc = - testGroup (Text.unpack $ ffc_name ffc) - [ testVerifyTally ffc 0 1 1 1 - , testVerifyTally ffc 0 2 1 1 - , testVerifyTally ffc 0 1 2 1 - , testVerifyTally ffc 0 2 2 1 - , testVerifyTally ffc 0 5 10 5 +testsVerifyTally :: + ReifyCrypto crypto => + Reifies v Version => Proxy v -> + crypto -> TestTree +testsVerifyTally v crypto = + testGroup (Text.unpack $ cryptoName crypto) + [ testVerifyTally v crypto 0 1 1 1 + , testVerifyTally v crypto 0 2 1 1 + , testVerifyTally v crypto 0 1 2 1 + , testVerifyTally v crypto 0 2 2 1 + , testVerifyTally v crypto 0 5 10 5 ] -testVerifyTally :: FFC -> Int -> Natural -> Natural -> Natural -> TestTree -testVerifyTally ffc seed nTrustees nQuests nChoices = +testVerifyTally :: + ReifyCrypto crypto => + Reifies v Version => Proxy v -> + crypto -> Int -> Natural -> Natural -> Natural -> TestTree +testVerifyTally (_v::Proxy v) crypto seed nTrustees nQuests nChoices = let clearTallyResult = dummyTallyResult nQuests nChoices in let decryptedTallyResult :: Either ErrorTally [[Natural]] = - reify ffc $ \(Proxy::Proxy c) -> + reifyCrypto crypto $ \(Proxy::Proxy c) -> runExcept $ (`evalStateT` Random.mkStdGen seed) $ do - secKeyByTrustee :: [SecretKey c] <- + secKeyByTrustee :: [SecretKey crypto c] <- replicateM (fromIntegral nTrustees) $ randomSecretKey - trusteePubKeys <- forM secKeyByTrustee $ proveIndispensableTrusteePublicKey + trusteePubKeys + :: [TrusteePublicKey crypto v c] + <- forM secKeyByTrustee $ proveIndispensableTrusteePublicKey let pubKeyByTrustee = trustee_PublicKey <$> trusteePubKeys let elecPubKey = combineIndispensableTrusteePublicKeys trusteePubKeys (encTally, countMax) <- encryptTallyResult elecPubKey clearTallyResult - decShareByTrustee <- forM secKeyByTrustee $ proveDecryptionShare encTally + decShareByTrustee + :: [DecryptionShare crypto v c] + <- forM secKeyByTrustee $ proveDecryptionShare encTally lift $ verifyDecryptionShareByTrustee encTally pubKeyByTrustee decShareByTrustee tally@Tally{..} <- lift $ proveTally (encTally, countMax) decShareByTrustee $ @@ -90,9 +106,12 @@ dummyTallyResult nQuests nChoices = ] encryptTallyResult :: - Reifies c FFC => + Reifies v Version => + Reifies c crypto => + Group crypto => + Multiplicative (FieldElement crypto c) => Monad m => RandomGen r => - PublicKey c -> [[Natural]] -> StateT r m (EncryptedTally c, Natural) + PublicKey crypto c -> [[Natural]] -> StateT r m (EncryptedTally crypto v c, Natural) encryptTallyResult pubKey countByChoiceByQuest = (`runStateT` 0) $ forM countByChoiceByQuest $ diff --git a/hjugement-protocol/tests/Main.hs b/hjugement-protocol/tests/Main.hs index 9b82d30..35cb590 100644 --- a/hjugement-protocol/tests/Main.hs +++ b/hjugement-protocol/tests/Main.hs @@ -1,15 +1,17 @@ module Main where -import System.IO (IO) import Data.Function (($)) -import Test.Tasty -import QuickCheck import HUnit +import QuickCheck +import System.IO (IO) +import Test.Tasty +import Voting.Protocol main :: IO () main = defaultMain $ - testGroup "Protocol" - [ hunits - , quickchecks + reify stableVersion $ \v -> + testGroup "Voting.Protocol" + [ hunits v + , quickchecks v ] diff --git a/hjugement-protocol/tests/QuickCheck.hs b/hjugement-protocol/tests/QuickCheck.hs index 13bd156..e18db84 100644 --- a/hjugement-protocol/tests/QuickCheck.hs +++ b/hjugement-protocol/tests/QuickCheck.hs @@ -1,11 +1,12 @@ module QuickCheck where import Test.Tasty +import Voting.Protocol import qualified QuickCheck.Election import qualified QuickCheck.Trustee -quickchecks :: TestTree -quickchecks = +quickchecks :: Reifies v Version => Proxy v -> TestTree +quickchecks v = testGroup "QuickCheck" - [ QuickCheck.Election.quickcheck - , QuickCheck.Trustee.quickcheck + [ QuickCheck.Election.quickcheck v + , QuickCheck.Trustee.quickcheck v ] diff --git a/hjugement-protocol/tests/QuickCheck/Election.hs b/hjugement-protocol/tests/QuickCheck/Election.hs index bb7a43e..10ea694 100644 --- a/hjugement-protocol/tests/QuickCheck/Election.hs +++ b/hjugement-protocol/tests/QuickCheck/Election.hs @@ -10,6 +10,7 @@ import Data.Ord (Ord(..)) import GHC.Natural (minusNaturalMaybe) import Prelude (undefined) import Test.Tasty.QuickCheck +import qualified Data.Aeson as JSON import qualified Data.List as List import qualified Data.Text as Text @@ -23,20 +24,23 @@ maxArbitraryChoices = 5 maxArbitraryQuestions :: Natural maxArbitraryQuestions = 2 -quickcheck :: TestTree -quickcheck = +quickcheck :: Reifies v Version => Proxy v -> TestTree +quickcheck v = testGroup "Election" [ testGroup "verifyBallot" $ - [ testElection weakFFC - , testElection beleniosFFC + [ quickcheckElection v weakFFC + , quickcheckElection v beleniosFFC ] ] -testElection :: FFC -> TestTree -testElection ffc = - reify ffc $ \(Proxy::Proxy c) -> - testGroup (Text.unpack $ ffc_name ffc) - [ testProperty "verifyBallot" $ \(seed, (elec::Election c) :> votes) -> +quickcheckElection :: + ReifyCrypto crypto => + Reifies v Version => Proxy v -> + crypto -> TestTree +quickcheckElection (_v::Proxy v) crypto = + reifyCrypto crypto $ \(Proxy::Proxy c) -> + testGroup (Text.unpack $ cryptoName crypto) + [ testProperty "verifyBallot" $ \(seed, (elec::Election crypto v c) :> votes) -> isRight $ runExcept $ (`evalStateT` mkStdGen seed) $ do -- ballotSecKey :: SecretKey c <- randomSecretKey @@ -47,23 +51,34 @@ testElection ffc = instance Reifies c FFC => Arbitrary (F c) where arbitrary = F <$> choose (zero, fromJust $ fieldCharac @c `minusNaturalMaybe` one) -instance Reifies c FFC => Arbitrary (G c) where +instance + ( Reifies c crypto + , Group crypto + , Multiplicative (FieldElement crypto c) + ) => Arbitrary (G crypto c) where arbitrary = do m <- arbitrary return (groupGen ^ m) -instance Reifies c FFC => Arbitrary (E c) where - arbitrary = E <$> choose (zero, fromJust $ groupOrder @c `minusNaturalMaybe` one) +instance + ( Reifies c crypto + , Group crypto + ) => Arbitrary (E crypto c) where + arbitrary = E <$> choose (zero, fromJust $ groupOrder @crypto (Proxy @c) `minusNaturalMaybe` one) instance Arbitrary UUID where arbitrary = do seed <- arbitrary (`evalStateT` mkStdGen seed) $ randomUUID -instance Reifies c FFC => Arbitrary (Proof c) where +instance + ( Reifies v Version + , Reifies c crypto + , Arbitrary (E crypto c) + ) => Arbitrary (Proof crypto v c) where arbitrary = do proof_challenge <- arbitrary proof_response <- arbitrary return Proof{..} -instance Arbitrary Question where +instance Reifies v Version => Arbitrary (Question v) where arbitrary = do let question_text = "question" choices :: Natural <- choose (1, maxArbitraryChoices) @@ -78,16 +93,26 @@ instance Arbitrary Question where , question_mini <- shrinkIntegral $ min nChoices $ max zero $ question_mini quest , question_maxi <- shrinkIntegral $ min nChoices $ max question_mini $ question_maxi quest ] -instance Reifies c FFC => Arbitrary (Election c) where +instance + ( Reifies v Version + , Reifies c crypto + , Group crypto + , Key crypto + , Multiplicative (FieldElement crypto c) + , JSON.ToJSON crypto + , JSON.ToJSON (FieldElement crypto c) + ) => Arbitrary (Election crypto v c) where arbitrary = do let election_name = "election" let election_description = "description" - election_crypto <- arbitrary + let election_crypto = reflect (Proxy @c) + election_secret_key <- arbitrary + let election_public_key = publicKey election_secret_key election_questions <- resize (fromIntegral maxArbitraryQuestions) $ listOf1 arbitrary election_uuid <- arbitrary - let elec = - Election - { election_hash = hashElection elec + let elec = Election + { election_hash = hashElection elec + , election_version = Just (reflect (Proxy @v)) , .. } return elec @@ -95,16 +120,18 @@ instance Reifies c FFC => Arbitrary (Election c) where [ elec{election_questions} | election_questions <- shrink $ election_questions elec ] +{- instance Reifies c FFC => Arbitrary (ElectionCrypto c) where arbitrary = do let electionCrypto_FFC_params = reflect (Proxy::Proxy c) electionCrypto_FFC_PublicKey <- arbitrary return ElectionCrypto_FFC{..} +-} -- | A type to declare an 'Arbitrary' instance where @b@ depends on @a@. data (:>) a b = a :> b deriving (Eq,Show) -instance Arbitrary (Question :> [Bool]) where +instance Reifies v Version => Arbitrary (Question v :> [Bool]) where arbitrary = do quest@Question{..} <- arbitrary votes <- do @@ -117,7 +144,15 @@ instance Arbitrary (Question :> [Bool]) where [ q :> shrinkVotes q votes | q <- shrink quest ] -instance Reifies c FFC => Arbitrary (Election c :> [[Bool]]) where +instance + ( Reifies v Version + , Reifies c crypto + , Group crypto + , Key crypto + , JSON.ToJSON crypto + , JSON.ToJSON (FieldElement crypto c) + , Multiplicative (FieldElement crypto c) + ) => Arbitrary (Election crypto v c :> [[Bool]]) where arbitrary = do elec@Election{..} <- arbitrary votes <- forM election_questions $ \Question{..} -> do @@ -127,7 +162,7 @@ instance Reifies c FFC => Arbitrary (Election c :> [[Bool]]) where return $ boolsOfCombin numChoices numTrue rank return (elec :> votes) shrink (elec :> votes) = - [ e :> List.zipWith shrinkVotes (election_questions e) votes + [ e :> List.zipWith shrinkVotes (election_questions e :: [Question v]) votes | e <- shrink elec ] @@ -149,7 +184,7 @@ boolsOfCombin nBits nTrue rank -- | @('shrinkVotes' quest votes)@ -- returns a reduced version of the given @votes@ -- to fit the requirement of the given @quest@. -shrinkVotes :: Question -> [Bool] -> [Bool] +shrinkVotes :: Reifies v Version => Question v -> [Bool] -> [Bool] shrinkVotes Question{..} votes = (\(nTrue, b) -> nTrue <= nat question_maxi && b) <$> List.zip (countTrue votes) votes @@ -159,4 +194,3 @@ shrinkVotes Question{..} votes = where inc [] = [zero] inc (n:ns) = (n+one):n:ns - diff --git a/hjugement-protocol/tests/QuickCheck/Trustee.hs b/hjugement-protocol/tests/QuickCheck/Trustee.hs index 586295c..2b7838b 100644 --- a/hjugement-protocol/tests/QuickCheck/Trustee.hs +++ b/hjugement-protocol/tests/QuickCheck/Trustee.hs @@ -1,4 +1,5 @@ {-# OPTIONS -fno-warn-orphans #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE UndecidableInstances #-} -- for Reifies instances module QuickCheck.Trustee where @@ -10,28 +11,37 @@ import Voting.Protocol import Utils import QuickCheck.Election () -quickcheck :: TestTree -quickcheck = - testGroup "Trustee" +quickcheck :: Reifies v Version => Proxy v -> TestTree +quickcheck v = + testGroup "Trustee" $ [ testGroup "verifyIndispensableTrusteePublicKey" $ - [ testIndispensableTrusteePublicKey weakFFC - , testIndispensableTrusteePublicKey beleniosFFC + [ testIndispensableTrusteePublicKey v weakFFC + , testIndispensableTrusteePublicKey v beleniosFFC ] ] -testIndispensableTrusteePublicKey :: FFC -> TestTree -testIndispensableTrusteePublicKey ffc = - reify ffc $ \(Proxy::Proxy c) -> - testGroup (Text.unpack $ ffc_name ffc) +testIndispensableTrusteePublicKey :: + ReifyCrypto crypto => + Reifies v Version => Proxy v -> + crypto -> TestTree +testIndispensableTrusteePublicKey (_v::Proxy v) crypto = + reifyCrypto crypto $ \(Proxy::Proxy c) -> + testGroup (Text.unpack $ cryptoName crypto) [ testProperty "Right" $ \seed -> isRight $ runExcept $ (`evalStateT` mkStdGen seed) $ do - trusteeSecKey :: SecretKey c <- randomSecretKey - trusteePubKey <- proveIndispensableTrusteePublicKey trusteeSecKey + trusteeSecKey :: SecretKey crypto c <- randomSecretKey + trusteePubKey :: TrusteePublicKey crypto v c + <- proveIndispensableTrusteePublicKey trusteeSecKey lift $ verifyIndispensableTrusteePublicKey trusteePubKey ] -instance Reifies c FFC => Arbitrary (TrusteePublicKey c) where +instance + ( Reifies v Version + , Reifies c crypto + , Group crypto + , Multiplicative (FieldElement crypto c) + ) => Arbitrary (TrusteePublicKey crypto v c) where arbitrary = do trustee_PublicKey <- arbitrary trustee_SecretKeyProof <- arbitrary -- 2.44.1 From 09f94714f259868ed7e336528caeffffe11469db Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Mon, 28 Oct 2019 21:22:17 +0000 Subject: [PATCH 13/16] protocol: replace F by G --- hjugement-protocol/benchmarks/Election.hs | 25 ++-- .../src/Voting/Protocol/Election.hs | 117 ++++++++++-------- hjugement-protocol/src/Voting/Protocol/FFC.hs | 64 +++++----- .../src/Voting/Protocol/Tally.hs | 55 ++++---- .../Voting/Protocol/Trustee/Indispensable.hs | 35 +++--- .../tests/HUnit/Trustee/Indispensable.hs | 3 +- .../tests/QuickCheck/Election.hs | 15 ++- .../tests/QuickCheck/Trustee.hs | 3 +- 8 files changed, 172 insertions(+), 145 deletions(-) diff --git a/hjugement-protocol/benchmarks/Election.hs b/hjugement-protocol/benchmarks/Election.hs index fa306bc..1386493 100644 --- a/hjugement-protocol/benchmarks/Election.hs +++ b/hjugement-protocol/benchmarks/Election.hs @@ -15,7 +15,7 @@ makeElection :: Reifies v Version => Reifies c crypto => JSON.ToJSON crypto => - JSON.ToJSON (FieldElement crypto c) => + JSON.ToJSON (G crypto c) => Key crypto => Int -> Int -> Election crypto v c makeElection nQuests nChoices = elec @@ -51,8 +51,9 @@ makeBallot :: Reifies c crypto => Group crypto => Key crypto => - Multiplicative (FieldElement crypto c) => - ToNatural (FieldElement crypto c) => + Multiplicative (G crypto c) => + Invertible (G crypto c) => + ToNatural (G crypto c) => Election crypto v c -> Ballot crypto v c makeBallot elec = case runExcept $ (`evalStateT` mkStdGen seed) $ do @@ -80,10 +81,11 @@ benchEncryptBallot :: Group crypto => Key crypto => NFData crypto => - NFData (FieldElement crypto c) => - Multiplicative (FieldElement crypto c) => - ToNatural (FieldElement crypto c) => - JSON.ToJSON (FieldElement crypto c) => + NFData (G crypto c) => + Multiplicative (G crypto c) => + Invertible (G crypto c) => + ToNatural (G crypto c) => + JSON.ToJSON (G crypto c) => Proxy v -> Proxy c -> Int -> Int -> Benchmark benchEncryptBallot (_v::Proxy v) (_c::Proxy c) nQuests nChoices = let setupEnv = do @@ -101,10 +103,11 @@ benchVerifyBallot :: Group crypto => Key crypto => NFData crypto => - NFData (FieldElement crypto c) => - Multiplicative (FieldElement crypto c) => - ToNatural (FieldElement crypto c) => - JSON.ToJSON (FieldElement crypto c) => + NFData (G crypto c) => + Multiplicative (G crypto c) => + Invertible (G crypto c) => + ToNatural (G crypto c) => + JSON.ToJSON (G crypto c) => Proxy v -> Proxy c -> Int -> Int -> Benchmark benchVerifyBallot (_v::Proxy v) (_c::Proxy c) nQuests nChoices = let setupEnv = do diff --git a/hjugement-protocol/src/Voting/Protocol/Election.hs b/hjugement-protocol/src/Voting/Protocol/Election.hs index 7448664..f851526 100644 --- a/hjugement-protocol/src/Voting/Protocol/Election.hs +++ b/hjugement-protocol/src/Voting/Protocol/Election.hs @@ -75,13 +75,13 @@ data Encryption crypto v c = Encryption -- ^ Encrypted 'clear' text, -- equal to @('pubKey' '^'encNone '*' 'groupGen' '^'clear)@ } deriving (Generic) -deriving instance Eq (FieldElement crypto c) => Eq (Encryption crypto v c) -deriving instance (Show (FieldElement crypto c), Show (G crypto c)) => Show (Encryption crypto v c) -deriving instance NFData (FieldElement crypto c) => NFData (Encryption crypto v c) +deriving instance Eq (G crypto c) => Eq (Encryption crypto v c) +deriving instance (Show (G crypto c), Show (G crypto c)) => Show (Encryption crypto v c) +deriving instance NFData (G crypto c) => NFData (Encryption crypto v c) instance ( Reifies v Version , Reifies c crypto - , ToJSON (FieldElement crypto c) + , ToJSON (G crypto c) ) => ToJSON (Encryption crypto v c) where toJSON Encryption{..} = JSON.object @@ -107,7 +107,7 @@ instance -- Using the fact that: @'groupGen' '^'x '*' 'groupGen' '^'y '==' 'groupGen' '^'(x'+'y)@. instance ( Reifies c crypto - , Multiplicative (FieldElement crypto c) + , Multiplicative (G crypto c) ) => Additive (Encryption crypto v c) where zero = Encryption one one x+y = Encryption @@ -129,7 +129,7 @@ encrypt :: Reifies v Version => Reifies c crypto => Group crypto => - Multiplicative (FieldElement crypto c) => + Multiplicative (G crypto c) => Monad m => RandomGen r => PublicKey crypto c -> E crypto c -> S.StateT r m (EncryptionNonce crypto c, Encryption crypto v c) @@ -244,7 +244,7 @@ prove :: Reifies c crypto => Reifies v Version => Group crypto => - Multiplicative (FieldElement crypto c) => + Multiplicative (G crypto c) => Monad m => RandomGen r => Functor list => E crypto c -> list (G crypto c) -> @@ -271,7 +271,7 @@ proveQuicker :: Reifies c crypto => Reifies v Version => Group crypto => - Multiplicative (FieldElement crypto c) => + Multiplicative (G crypto c) => Monad m => RandomGen r => Functor list => E crypto c -> list (G crypto c) -> @@ -317,7 +317,8 @@ commit :: Reifies v Version => Reifies c crypto => Group crypto => - Multiplicative (FieldElement crypto c) => + Multiplicative (G crypto c) => + Invertible (G crypto c) => Proof crypto v c -> G crypto c -> G crypto c -> @@ -340,7 +341,7 @@ commit Proof{..} base basePowSec = -- when Helios-C specifications will be fixed. commitQuicker :: Reifies c crypto => - Multiplicative (FieldElement crypto c) => + Multiplicative (G crypto c) => Proof crypto v c -> G crypto c -> G crypto c -> @@ -359,7 +360,8 @@ booleanDisjunctions :: forall crypto c. Reifies c crypto => Group crypto => - Multiplicative (FieldElement crypto c) => + Multiplicative (G crypto c) => + Invertible (G crypto c) => [Disjunction crypto c] booleanDisjunctions = List.take 2 $ groupGenInverses @crypto @@ -367,7 +369,8 @@ intervalDisjunctions :: forall crypto c. Reifies c crypto => Group crypto => - Multiplicative (FieldElement crypto c) => + Multiplicative (G crypto c) => + Invertible (G crypto c) => Natural -> Natural -> [Disjunction crypto c] intervalDisjunctions mini maxi = List.genericTake (fromJust $ (nat maxi + 1)`minusNaturalMaybe`nat mini) $ @@ -414,8 +417,9 @@ proveEncryption :: Reifies v Version => Reifies c crypto => Group crypto => - ToNatural (FieldElement crypto c) => - Multiplicative (FieldElement crypto c) => + ToNatural (G crypto c) => + Multiplicative (G crypto c) => + Invertible (G crypto c) => Monad m => RandomGen r => PublicKey crypto c -> ZKP -> ([Disjunction crypto c],[Disjunction crypto c]) -> @@ -447,8 +451,9 @@ verifyEncryption :: Reifies v Version => Reifies c crypto => Group crypto => - ToNatural (FieldElement crypto c) => - Multiplicative (FieldElement crypto c) => + ToNatural (G crypto c) => + Multiplicative (G crypto c) => + Invertible (G crypto c) => Monad m => PublicKey crypto c -> ZKP -> [Disjunction crypto c] -> (Encryption crypto v c, DisjProof crypto v c) -> @@ -468,7 +473,7 @@ verifyEncryption elecPubKey voterZKP disjs (enc, DisjProof proofs) = -- ** Hashing encryptionStatement :: Reifies c crypto => - ToNatural (FieldElement crypto c) => + ToNatural (G crypto c) => ZKP -> Encryption crypto v c -> BS.ByteString encryptionStatement (ZKP voterZKP) Encryption{..} = "prove|"<>voterZKP<>"|" @@ -484,7 +489,7 @@ encryptionCommitments :: Reifies v Version => Reifies c crypto => Group crypto => - Multiplicative (FieldElement crypto c) => + Invertible (G crypto c) => PublicKey crypto c -> Encryption crypto v c -> Disjunction crypto c -> Proof crypto v c -> [G crypto c] encryptionCommitments elecPubKey Encryption{..} disj proof = @@ -546,13 +551,13 @@ data Answer crypto v c = Answer -- is an element of @[mini..maxi]@. -- , answer_blankProof :: } deriving (Generic) -deriving instance Eq (FieldElement crypto c) => Eq (Answer crypto v c) -deriving instance (Show (FieldElement crypto c), Show (G crypto c)) => Show (Answer crypto v c) -deriving instance NFData (FieldElement crypto c) => NFData (Answer crypto v c) +deriving instance Eq (G crypto c) => Eq (Answer crypto v c) +deriving instance (Show (G crypto c), Show (G crypto c)) => Show (Answer crypto v c) +deriving instance NFData (G crypto c) => NFData (Answer crypto v c) instance ( Reifies v Version , Reifies c crypto - , ToJSON (FieldElement crypto c) + , ToJSON (G crypto c) , Group crypto ) => ToJSON (Answer crypto v c) where toJSON Answer{..} = @@ -591,8 +596,9 @@ encryptAnswer :: Reifies v Version => Reifies c crypto => Group crypto => - Multiplicative (FieldElement crypto c) => - ToNatural (FieldElement crypto c) => + Multiplicative (G crypto c) => + Invertible (G crypto c) => + ToNatural (G crypto c) => Monad m => RandomGen r => PublicKey crypto c -> ZKP -> Question v -> [Bool] -> @@ -635,8 +641,9 @@ verifyAnswer :: Reifies v Version => Reifies c crypto => Group crypto => - Multiplicative (FieldElement crypto c) => - ToNatural (FieldElement crypto c) => + Multiplicative (G crypto c) => + Invertible (G crypto c) => + ToNatural (G crypto c) => PublicKey crypto c -> ZKP -> Question v -> Answer crypto v c -> Bool verifyAnswer elecPubKey zkp Question{..} Answer{..} @@ -673,12 +680,12 @@ data Election crypto v c = Election , election_version :: !(Maybe Version) , election_public_key :: !(PublicKey crypto c) } deriving (Generic) -deriving instance (Eq crypto, Eq (FieldElement crypto c)) => Eq (Election crypto v c) -deriving instance (Show crypto, Show (FieldElement crypto c)) => Show (Election crypto v c) -deriving instance (NFData crypto, NFData (FieldElement crypto c)) => NFData (Election crypto v c) +deriving instance (Eq crypto, Eq (G crypto c)) => Eq (Election crypto v c) +deriving instance (Show crypto, Show (G crypto c)) => Show (Election crypto v c) +deriving instance (NFData crypto, NFData (G crypto c)) => NFData (Election crypto v c) instance ( ToJSON crypto - , ToJSON (FieldElement crypto c) + , ToJSON (G crypto c) , Reifies v Version , Reifies c crypto ) => ToJSON (Election crypto v c) where @@ -714,7 +721,7 @@ readElection :: (forall v c. Reifies v Version => Reifies c crypto => - FieldElementConstraints crypto c => + GConstraints crypto c => Election crypto v c -> r) -> ExceptT String IO r readElection filePath k = do @@ -752,7 +759,7 @@ hashElection :: ToJSON crypto => Reifies c crypto => Reifies v Version => - ToJSON (FieldElement crypto c) => + ToJSON (G crypto c) => Election crypto v c -> Base64SHA256 hashElection = base64SHA256 . BSL.toStrict . JSON.encode @@ -779,26 +786,27 @@ class reifyCrypto :: crypto -> (forall c. Reifies c crypto => - FieldElementConstraints crypto c => + GConstraints crypto c => Proxy c -> r) -> r instance ReifyCrypto FFC where reifyCrypto = reify --- ** Class 'FieldElementConstraints' +-- ** Class 'GConstraints' -- | List the 'Constraint's on the element of the field -- when the @(crypto)@ has not been instantiated to a specific type yet. -- It concerns only 'Constraint's whose method act on @(a)@, -- not @(x c)@ (eg. 'Group'). -type FieldElementConstraints crypto c = - ( Multiplicative (FieldElement crypto c) - , FromNatural (FieldElement crypto c) - , ToNatural (FieldElement crypto c) - , Eq (FieldElement crypto c) - , Ord (FieldElement crypto c) - , Show (FieldElement crypto c) - , NFData (FieldElement crypto c) - , FromJSON (FieldElement crypto c) - , ToJSON (FieldElement crypto c) +type GConstraints crypto c = + ( Multiplicative (G crypto c) + , Invertible (G crypto c) + , FromNatural (G crypto c) + , ToNatural (G crypto c) + , Eq (G crypto c) + , Ord (G crypto c) + , Show (G crypto c) + , NFData (G crypto c) + , FromJSON (G crypto c) + , ToJSON (G crypto c) , FromJSON (G crypto c) , ToJSON (G crypto c) ) @@ -810,12 +818,12 @@ data Ballot crypto v c = Ballot , ballot_election_uuid :: !UUID , ballot_election_hash :: !Base64SHA256 } deriving (Generic) -deriving instance (NFData (FieldElement crypto c), NFData crypto) => NFData (Ballot crypto v c) +deriving instance (NFData (G crypto c), NFData crypto) => NFData (Ballot crypto v c) instance ( Reifies v Version , Reifies c crypto , Group crypto - , ToJSON (FieldElement crypto c) + , ToJSON (G crypto c) ) => ToJSON (Ballot crypto v c) where toJSON Ballot{..} = JSON.object $ @@ -854,8 +862,9 @@ encryptBallot :: Reifies v Version => Group crypto => Key crypto => - Multiplicative (FieldElement crypto c) => - ToNatural (FieldElement crypto c) => + Multiplicative (G crypto c) => + Invertible (G crypto c) => + ToNatural (G crypto c) => Monad m => RandomGen r => Election crypto v c -> Maybe (SecretKey crypto c) -> [[Bool]] -> @@ -903,9 +912,9 @@ verifyBallot :: Reifies v Version => Reifies c crypto => Group crypto => - Multiplicative (FieldElement crypto c) => - ToNatural (FieldElement crypto c) => - ToNatural (PublicKey crypto c) => + Multiplicative (G crypto c) => + Invertible (G crypto c) => + ToNatural (G crypto c) => Election crypto v c -> Ballot crypto v c -> Bool verifyBallot Election{..} Ballot{..} = @@ -939,12 +948,12 @@ data Signature crypto v c = Signature } deriving (Generic) deriving instance ( NFData crypto - , NFData (FieldElement crypto c) + , NFData (G crypto c) ) => NFData (Signature crypto v c) instance ( Reifies c crypto , Reifies v Version - , ToJSON (FieldElement crypto c) + , ToJSON (G crypto c) ) => ToJSON (Signature crypto v c) where toJSON (Signature pubKey Proof{..}) = JSON.object @@ -985,7 +994,7 @@ signatureStatement = -- | @('signatureCommitments' voterZKP commitment)@ signatureCommitments :: Reifies c crypto => - ToNatural (FieldElement crypto c) => + ToNatural (G crypto c) => ZKP -> Commitment crypto c -> BS.ByteString signatureCommitments (ZKP voterZKP) commitment = "sig|"<>voterZKP<>"|" -- NOTE: this is actually part of the statement diff --git a/hjugement-protocol/src/Voting/Protocol/FFC.hs b/hjugement-protocol/src/Voting/Protocol/FFC.hs index b858e6f..29acc05 100644 --- a/hjugement-protocol/src/Voting/Protocol/FFC.hs +++ b/hjugement-protocol/src/Voting/Protocol/FFC.hs @@ -118,7 +118,7 @@ instance FromJSON FFC where return FFC{..} instance Group FFC where groupGen :: forall c. Reifies c FFC => G FFC c - groupGen = G $ F $ ffc_groupGen $ reflect (Proxy::Proxy c) + groupGen = G $ ffc_groupGen $ reflect (Proxy::Proxy c) groupOrder :: forall c. Reifies c FFC => Proxy c -> Natural groupOrder c = ffc_groupOrder $ reflect c @@ -147,7 +147,6 @@ beleniosFFC = FFC , ffc_groupOrder = 78571733251071885079927659812671450121821421258408794611510081919805623223441 } --- * Type 'F' -- | The type of the elements of a Finite Prime Field. -- -- A field must satisfy the following properties: @@ -171,19 +170,11 @@ beleniosFFC = FFC -- @(a'+'b)'*'c == (a'*'c) '+' (b'*'c)@ -- -- The 'Natural' is always within @[0..'fieldCharac'-1]@. -newtype F c = F { unF :: Natural } - deriving (Eq,Ord,Show) - deriving newtype NFData -type instance FieldElement FFC = F -instance Reifies c FFC => FromJSON (F c) where - parseJSON (JSON.String s) - | Just (c0,_) <- Text.uncons s - , c0 /= '0' - , Text.all Char.isDigit s - , Just x <- readMaybe (Text.unpack s) - , x < fieldCharac @c - = return (F x) - parseJSON json = JSON.typeMismatch "FieldElement FFC" json +type instance FieldElement FFC = Natural +deriving newtype instance Eq (G FFC c) +deriving newtype instance Ord (G FFC c) +deriving newtype instance NFData (G FFC c) +deriving newtype instance Show (G FFC c) instance Reifies c FFC => FromJSON (G FFC c) where parseJSON (JSON.String s) | Just (c0,_) <- Text.uncons s @@ -191,38 +182,41 @@ instance Reifies c FFC => FromJSON (G FFC c) where , Text.all Char.isDigit s , Just x <- readMaybe (Text.unpack s) , x < fieldCharac @c - , r <- G (F x) + , r <- G x , r ^ E (groupOrder @FFC (Proxy @c)) == one = return r parseJSON json = JSON.typeMismatch "GroupElement" json -instance ToJSON (F c) where - toJSON (F x) = JSON.toJSON (show x) -instance Reifies c FFC => FromNatural (F c) where - fromNatural i = F $ abs $ i `mod` fieldCharac @c +instance ToJSON (G FFC c) where + toJSON (G x) = JSON.toJSON (show x) +instance Reifies c FFC => FromNatural (G FFC c) where + fromNatural i = G $ abs $ i `mod` fieldCharac @c where abs x | x < 0 = x + fieldCharac @c | otherwise = x -instance ToNatural (F c) where - nat = unF -instance Reifies c FFC => Additive (F c) where - zero = F 0 - F x + F y = F $ (x + y) `mod` fieldCharac @c -instance Reifies c FFC => Negable (F c) where - neg (F x) +instance ToNatural (G FFC c) where + nat = unG +instance Reifies c FFC => Additive (G FFC c) where + zero = G 0 + G x + G y = G $ (x + y) `mod` fieldCharac @c +instance Reifies c FFC => Negable (G FFC c) where + neg (G x) | x == 0 = zero - | otherwise = F $ fromJust $ nat (fieldCharac @c)`minusNaturalMaybe`x -instance Reifies c FFC => Multiplicative (F c) where - one = F 1 - F x * F y = F $ (x * y) `mod` fieldCharac @c -instance Reifies c FFC => Random.Random (F c) where - randomR (F lo, F hi) = - first (F . fromIntegral) . + | otherwise = G $ fromJust $ nat (fieldCharac @c)`minusNaturalMaybe`x +instance Reifies c FFC => Multiplicative (G FFC c) where + one = G 1 + G x * G y = G $ (x * y) `mod` fieldCharac @c +instance Reifies c FFC => Random.Random (G FFC c) where + randomR (G lo, G hi) = + first (G . fromIntegral) . Random.randomR ( 0`max`toInteger lo , toInteger hi`min`(toInteger (fieldCharac @c) - 1) ) random = - first (F . fromIntegral) . + first (G . fromIntegral) . Random.randomR (0, toInteger (fieldCharac @c) - 1) +instance Reifies c FFC => Invertible (G FFC c) where + -- | NOTE: add 'groupOrder' so the exponent given to (^) is positive. + inv = (^ E (fromJust $ groupOrder @FFC (Proxy @c)`minusNaturalMaybe`1)) -- * Conversions diff --git a/hjugement-protocol/src/Voting/Protocol/Tally.hs b/hjugement-protocol/src/Voting/Protocol/Tally.hs index 5fbbee1..172f831 100644 --- a/hjugement-protocol/src/Voting/Protocol/Tally.hs +++ b/hjugement-protocol/src/Voting/Protocol/Tally.hs @@ -50,14 +50,14 @@ data Tally crypto v c = Tally , tally_countByChoiceByQuest :: ![[Natural]] -- ^ The decrypted count of supportive 'Opinion's, by choice by 'Question'. } deriving (Generic) -deriving instance Eq (FieldElement crypto c) => Eq (Tally crypto v c) -deriving instance (Show (FieldElement crypto c), Show (G crypto c)) => Show (Tally crypto v c) -deriving instance NFData (FieldElement crypto c) => NFData (Tally crypto v c) +deriving instance Eq (G crypto c) => Eq (Tally crypto v c) +deriving instance (Show (G crypto c), Show (G crypto c)) => Show (Tally crypto v c) +deriving instance NFData (G crypto c) => NFData (Tally crypto v c) instance ( Reifies v Version , Reifies c crypto , Group crypto - , ToJSON (FieldElement crypto c) + , ToJSON (G crypto c) ) => ToJSON (Tally crypto v c) where toJSON Tally{..} = JSON.object @@ -95,14 +95,16 @@ type EncryptedTally crypto v c = [[Encryption crypto v c]] -- along with the number of 'Ballot's. encryptedTally :: Reifies c crypto => - Multiplicative (FieldElement crypto c) => + Multiplicative (G crypto c) => + Invertible (G crypto c) => [Ballot crypto v c] -> (EncryptedTally crypto v c, Natural) encryptedTally = List.foldr insertEncryptedTally emptyEncryptedTally -- | The initial 'EncryptedTally' which tallies no 'Ballot'. emptyEncryptedTally :: Reifies c crypto => - Multiplicative (FieldElement crypto c) => + Multiplicative (G crypto c) => + Invertible (G crypto c) => (EncryptedTally crypto v c, Natural) emptyEncryptedTally = (List.repeat (List.repeat zero), 0) @@ -111,7 +113,8 @@ emptyEncryptedTally = (List.repeat (List.repeat zero), 0) -- to those of the given @(encTally)@. insertEncryptedTally :: Reifies c crypto => - Multiplicative (FieldElement crypto c) => + Multiplicative (G crypto c) => + Invertible (G crypto c) => Ballot crypto v c -> (EncryptedTally crypto v c, Natural) -> (EncryptedTally crypto v c, Natural) insertEncryptedTally Ballot{..} (encTally, numBallots) = ( List.zipWith @@ -130,8 +133,9 @@ type DecryptionShareCombinator crypto v c = proveTally :: Reifies c crypto => Group crypto => - Multiplicative (FieldElement crypto c) => - Ord (FieldElement crypto c) => + Multiplicative (G crypto c) => + Invertible (G crypto c) => + Ord (G crypto c) => (EncryptedTally crypto v c, Natural) -> [DecryptionShare crypto v c] -> DecryptionShareCombinator crypto v c -> Except ErrorTally (Tally crypto v c) @@ -158,8 +162,9 @@ proveTally verifyTally :: Reifies c crypto => Group crypto => - Multiplicative (FieldElement crypto c) => - Eq (FieldElement crypto c) => + Multiplicative (G crypto c) => + Invertible (G crypto c) => + Eq (G crypto c) => Tally crypto v c -> DecryptionShareCombinator crypto v c -> Except ErrorTally () @@ -181,12 +186,12 @@ verifyTally Tally{..} decShareCombinator = do newtype DecryptionShare crypto v c = DecryptionShare { unDecryptionShare :: [[(DecryptionFactor crypto c, Proof crypto v c)]] } deriving (Generic) -deriving instance Eq (FieldElement crypto c) => Eq (DecryptionShare crypto v c) +deriving instance Eq (G crypto c) => Eq (DecryptionShare crypto v c) deriving instance Show (G crypto c) => Show (DecryptionShare crypto v c) -deriving newtype instance NFData (FieldElement crypto c) => NFData (DecryptionShare crypto v c) +deriving newtype instance NFData (G crypto c) => NFData (DecryptionShare crypto v c) instance ( Group crypto - , ToJSON (FieldElement crypto c) + , ToJSON (G crypto c) ) => ToJSON (DecryptionShare crypto v c) where toJSON (DecryptionShare decByChoiceByQuest) = JSON.object @@ -225,9 +230,10 @@ proveDecryptionShare :: Reifies v Version => Reifies c crypto => Group crypto => - Multiplicative (FieldElement crypto c) => + Multiplicative (G crypto c) => + Invertible (G crypto c) => Key crypto => - ToNatural (FieldElement crypto c) => + ToNatural (G crypto c) => Monad m => RandomGen r => EncryptedTally crypto v c -> SecretKey crypto c -> S.StateT r m (DecryptionShare crypto v c) proveDecryptionShare encByChoiceByQuest trusteeSecKey = @@ -238,9 +244,10 @@ proveDecryptionFactor :: Reifies v Version => Reifies c crypto => Group crypto => - Multiplicative (FieldElement crypto c) => + Multiplicative (G crypto c) => + Invertible (G crypto c) => Key crypto => - ToNatural (FieldElement crypto c) => + ToNatural (G crypto c) => Monad m => RandomGen r => SecretKey crypto c -> Encryption crypto v c -> S.StateT r m (DecryptionFactor crypto c, Proof crypto v c) proveDecryptionFactor trusteeSecKey Encryption{..} = do @@ -250,7 +257,7 @@ proveDecryptionFactor trusteeSecKey Encryption{..} = do decryptionShareStatement :: Reifies c crypto => - ToNatural (FieldElement crypto c) => + ToNatural (G crypto c) => PublicKey crypto c -> BS.ByteString decryptionShareStatement pubKey = "decrypt|"<>bytesNat pubKey<>"|" @@ -279,8 +286,9 @@ verifyDecryptionShare :: Reifies v Version => Reifies c crypto => Group crypto => - Multiplicative (FieldElement crypto c) => - ToNatural (FieldElement crypto c) => + Multiplicative (G crypto c) => + Invertible (G crypto c) => + ToNatural (G crypto c) => Monad m => EncryptedTally crypto v c -> PublicKey crypto c -> DecryptionShare crypto v c -> ExceptT ErrorTally m () @@ -300,8 +308,9 @@ verifyDecryptionShareByTrustee :: Reifies v Version => Reifies c crypto => Group crypto => - Multiplicative (FieldElement crypto c) => - ToNatural (FieldElement crypto c) => + Multiplicative (G crypto c) => + Invertible (G crypto c) => + ToNatural (G crypto c) => Monad m => EncryptedTally crypto v c -> [PublicKey crypto c] -> [DecryptionShare crypto v c] -> ExceptT ErrorTally m () diff --git a/hjugement-protocol/src/Voting/Protocol/Trustee/Indispensable.hs b/hjugement-protocol/src/Voting/Protocol/Trustee/Indispensable.hs index 95f1a03..3c26f98 100644 --- a/hjugement-protocol/src/Voting/Protocol/Trustee/Indispensable.hs +++ b/hjugement-protocol/src/Voting/Protocol/Trustee/Indispensable.hs @@ -47,12 +47,12 @@ data TrusteePublicKey crypto v c = TrusteePublicKey -- Which is done in 'proveIndispensableTrusteePublicKey' -- and 'verifyIndispensableTrusteePublicKey'. } deriving (Generic) -deriving instance Eq (FieldElement crypto c) => Eq (TrusteePublicKey crypto v c) -deriving instance (Show (FieldElement crypto c), Show (PublicKey crypto c)) => Show (TrusteePublicKey crypto v c) -deriving instance NFData (FieldElement crypto c) => NFData (TrusteePublicKey crypto v c) +deriving instance Eq (G crypto c) => Eq (TrusteePublicKey crypto v c) +deriving instance (Show (G crypto c), Show (PublicKey crypto c)) => Show (TrusteePublicKey crypto v c) +deriving instance NFData (G crypto c) => NFData (TrusteePublicKey crypto v c) instance ( Group crypto - , ToJSON (FieldElement crypto c) + , ToJSON (G crypto c) ) => ToJSON (TrusteePublicKey crypto v c) where toJSON TrusteePublicKey{..} = JSON.object @@ -84,8 +84,9 @@ proveIndispensableTrusteePublicKey :: Reifies c crypto => Group crypto => Key crypto => - Multiplicative (FieldElement crypto c) => - ToNatural (FieldElement crypto c) => + Multiplicative (G crypto c) => + Invertible (G crypto c) => + ToNatural (G crypto c) => Monad m => RandomGen r => SecretKey crypto c -> S.StateT r m (TrusteePublicKey crypto v c) proveIndispensableTrusteePublicKey trustSecKey = do @@ -105,8 +106,9 @@ verifyIndispensableTrusteePublicKey :: Reifies v Version => Reifies c crypto => Group crypto => - Multiplicative (FieldElement crypto c) => - ToNatural (FieldElement crypto c) => + Multiplicative (G crypto c) => + Invertible (G crypto c) => + ToNatural (G crypto c) => Monad m => TrusteePublicKey crypto v c -> ExceptT ErrorTrusteePublicKey m () @@ -127,7 +129,7 @@ data ErrorTrusteePublicKey -- ** Hashing indispensableTrusteePublicKeyStatement :: Reifies c crypto => - ToNatural (FieldElement crypto c) => + ToNatural (G crypto c) => PublicKey crypto c -> BS.ByteString indispensableTrusteePublicKeyStatement trustPubKey = "pok|"<>bytesNat trustPubKey<>"|" @@ -138,8 +140,9 @@ indispensableTrusteePublicKeyStatement trustPubKey = combineIndispensableTrusteePublicKeys :: Reifies c crypto => - Multiplicative (FieldElement crypto c) => - ToNatural (FieldElement crypto c) => + Multiplicative (G crypto c) => + Invertible (G crypto c) => + ToNatural (G crypto c) => [TrusteePublicKey crypto v c] -> PublicKey crypto c combineIndispensableTrusteePublicKeys = List.foldr (\TrusteePublicKey{..} -> (trustee_PublicKey *)) one @@ -150,8 +153,9 @@ verifyIndispensableDecryptionShareByTrustee :: Reifies v Version => Reifies c crypto => Group crypto => - Multiplicative (FieldElement crypto c) => - ToNatural (FieldElement crypto c) => + Multiplicative (G crypto c) => + Invertible (G crypto c) => + ToNatural (G crypto c) => Monad m => EncryptedTally crypto v c -> [PublicKey crypto c] -> [DecryptionShare crypto v c] -> ExceptT ErrorTally m () @@ -167,8 +171,9 @@ combineIndispensableDecryptionShares :: Reifies v Version => Reifies c crypto => Group crypto => - Multiplicative (FieldElement crypto c) => - ToNatural (FieldElement crypto c) => + Multiplicative (G crypto c) => + Invertible (G crypto c) => + ToNatural (G crypto c) => [PublicKey crypto c] -> DecryptionShareCombinator crypto v c combineIndispensableDecryptionShares pubKeyByTrustee diff --git a/hjugement-protocol/tests/HUnit/Trustee/Indispensable.hs b/hjugement-protocol/tests/HUnit/Trustee/Indispensable.hs index 63bf549..b654f4e 100644 --- a/hjugement-protocol/tests/HUnit/Trustee/Indispensable.hs +++ b/hjugement-protocol/tests/HUnit/Trustee/Indispensable.hs @@ -109,7 +109,8 @@ encryptTallyResult :: Reifies v Version => Reifies c crypto => Group crypto => - Multiplicative (FieldElement crypto c) => + Multiplicative (G crypto c) => + Invertible (G crypto c) => Monad m => RandomGen r => PublicKey crypto c -> [[Natural]] -> StateT r m (EncryptedTally crypto v c, Natural) encryptTallyResult pubKey countByChoiceByQuest = diff --git a/hjugement-protocol/tests/QuickCheck/Election.hs b/hjugement-protocol/tests/QuickCheck/Election.hs index 10ea694..07d4352 100644 --- a/hjugement-protocol/tests/QuickCheck/Election.hs +++ b/hjugement-protocol/tests/QuickCheck/Election.hs @@ -49,12 +49,15 @@ quickcheckElection (_v::Proxy v) crypto = lift $ throwE $ ErrorBallot_Wrong ] +{- instance Reifies c FFC => Arbitrary (F c) where arbitrary = F <$> choose (zero, fromJust $ fieldCharac @c `minusNaturalMaybe` one) +-} instance ( Reifies c crypto , Group crypto - , Multiplicative (FieldElement crypto c) + , Multiplicative (G crypto c) + , Invertible (G crypto c) ) => Arbitrary (G crypto c) where arbitrary = do m <- arbitrary @@ -98,9 +101,10 @@ instance , Reifies c crypto , Group crypto , Key crypto - , Multiplicative (FieldElement crypto c) + , Multiplicative (G crypto c) + , Invertible (G crypto c) , JSON.ToJSON crypto - , JSON.ToJSON (FieldElement crypto c) + , JSON.ToJSON (G crypto c) ) => Arbitrary (Election crypto v c) where arbitrary = do let election_name = "election" @@ -150,8 +154,9 @@ instance , Group crypto , Key crypto , JSON.ToJSON crypto - , JSON.ToJSON (FieldElement crypto c) - , Multiplicative (FieldElement crypto c) + , JSON.ToJSON (G crypto c) + , Multiplicative (G crypto c) + , Invertible (G crypto c) ) => Arbitrary (Election crypto v c :> [[Bool]]) where arbitrary = do elec@Election{..} <- arbitrary diff --git a/hjugement-protocol/tests/QuickCheck/Trustee.hs b/hjugement-protocol/tests/QuickCheck/Trustee.hs index 2b7838b..72b1ba3 100644 --- a/hjugement-protocol/tests/QuickCheck/Trustee.hs +++ b/hjugement-protocol/tests/QuickCheck/Trustee.hs @@ -40,7 +40,8 @@ instance ( Reifies v Version , Reifies c crypto , Group crypto - , Multiplicative (FieldElement crypto c) + , Multiplicative (G crypto c) + , Invertible (G crypto c) ) => Arbitrary (TrusteePublicKey crypto v c) where arbitrary = do trustee_PublicKey <- arbitrary -- 2.44.1 From 4ece36d277ddb11bc7dc1fe34a4d4604f13be04f Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Wed, 30 Oct 2019 00:28:03 +0000 Subject: [PATCH 14/16] protocol: replace reifyCrypto by groupDict --- .../src/Voting/Protocol/Election.hs | 136 ++++-------------- hjugement-protocol/src/Voting/Protocol/FFC.hs | 34 +++-- hjugement-protocol/tests/HUnit/Credential.hs | 12 +- hjugement-protocol/tests/HUnit/Election.hs | 41 +++--- hjugement-protocol/tests/HUnit/FFC.hs | 10 +- .../tests/HUnit/Trustee/Indispensable.hs | 70 ++++----- .../tests/QuickCheck/Election.hs | 23 ++- .../tests/QuickCheck/Trustee.hs | 16 +-- 8 files changed, 127 insertions(+), 215 deletions(-) diff --git a/hjugement-protocol/src/Voting/Protocol/Election.hs b/hjugement-protocol/src/Voting/Protocol/Election.hs index f851526..0e3f706 100644 --- a/hjugement-protocol/src/Voting/Protocol/Election.hs +++ b/hjugement-protocol/src/Voting/Protocol/Election.hs @@ -53,7 +53,6 @@ import qualified Text.Read as Read import Voting.Protocol.Utils import Voting.Protocol.Arith import Voting.Protocol.Credential -import Voting.Protocol.FFC (FFC) -- * Type 'Encryption' -- | ElGamal-like encryption. @@ -341,6 +340,7 @@ commit Proof{..} base basePowSec = -- when Helios-C specifications will be fixed. commitQuicker :: Reifies c crypto => + Group crypto => Multiplicative (G crypto c) => Proof crypto v c -> G crypto c -> @@ -360,7 +360,6 @@ booleanDisjunctions :: forall crypto c. Reifies c crypto => Group crypto => - Multiplicative (G crypto c) => Invertible (G crypto c) => [Disjunction crypto c] booleanDisjunctions = List.take 2 $ groupGenInverses @crypto @@ -369,7 +368,6 @@ intervalDisjunctions :: forall crypto c. Reifies c crypto => Group crypto => - Multiplicative (G crypto c) => Invertible (G crypto c) => Natural -> Natural -> [Disjunction crypto c] intervalDisjunctions mini maxi = @@ -389,19 +387,6 @@ type Opinion = E newtype DisjProof crypto v c = DisjProof [Proof crypto v c] deriving (Eq,Show,Generic) deriving newtype (NFData,ToJSON,FromJSON) -{- -deriving instance Eq (GroupExponent crypto c) => Eq (DisjProof crypto v c) -deriving instance Show (GroupExponent crypto c) => Show (DisjProof crypto v c) -deriving newtype instance NFData (GroupExponent crypto c) => NFData (DisjProof crypto v c) -deriving newtype instance - ( Reifies c crypto - , ToJSON (GroupExponent crypto c) - ) => ToJSON (DisjProof crypto v c) -deriving newtype instance - ( Reifies c crypto - , FromJSON (GroupExponent crypto c) - ) => FromJSON (DisjProof crypto v c) --} -- | @('proveEncryption' elecPubKey voterZKP (prevDisjs,nextDisjs) (encNonce,enc))@ -- returns a 'DisjProof' that 'enc' 'encrypt's @@ -594,16 +579,12 @@ instance -- unless an 'ErrorAnswer' is returned. encryptAnswer :: Reifies v Version => - Reifies c crypto => - Group crypto => - Multiplicative (G crypto c) => - Invertible (G crypto c) => - ToNatural (G crypto c) => + Reifies c crypto => Group crypto => Monad m => RandomGen r => PublicKey crypto c -> ZKP -> Question v -> [Bool] -> S.StateT r (ExceptT ErrorAnswer m) (Answer crypto v c) -encryptAnswer elecPubKey zkp Question{..} opinionByChoice +encryptAnswer (elecPubKey::PublicKey crypto c) zkp Question{..} opinionByChoice | not (question_mini <= opinionsSum && opinionsSum <= question_maxi) = lift $ throwE $ ErrorAnswer_WrongSumOfOpinions opinionsSum question_mini question_maxi @@ -612,7 +593,7 @@ encryptAnswer elecPubKey zkp Question{..} opinionByChoice ErrorAnswer_WrongNumberOfOpinions (fromIntegral $ List.length opinions) (fromIntegral $ List.length question_choices) - | otherwise = do + | otherwise, Dict <- groupDict (Proxy @c) = do encryptions <- encrypt elecPubKey `mapM` opinions individualProofs <- zipWithM (\opinion -> proveEncryption elecPubKey zkp $ @@ -639,24 +620,21 @@ encryptAnswer elecPubKey zkp Question{..} opinionByChoice verifyAnswer :: Reifies v Version => - Reifies c crypto => - Group crypto => - Multiplicative (G crypto c) => - Invertible (G crypto c) => - ToNatural (G crypto c) => + Reifies c crypto => Group crypto => PublicKey crypto c -> ZKP -> Question v -> Answer crypto v c -> Bool -verifyAnswer elecPubKey zkp Question{..} Answer{..} +verifyAnswer (elecPubKey::PublicKey crypto c) 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) + | otherwise, Dict <- groupDict (Proxy @c) = + 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'. @@ -715,13 +693,13 @@ instance maybe mempty ("version" .=) election_version readElection :: - ReifyCrypto crypto => FromJSON crypto => + Group crypto => FilePath -> (forall v c. Reifies v Version => Reifies c crypto => - GConstraints crypto c => + GroupDict crypto c => Election crypto v c -> r) -> ExceptT String IO r readElection filePath k = do @@ -742,7 +720,8 @@ readElection filePath k = do pubKey :: JSON.Value <- obj .: "y" return (crypto, pubKey) ) o "public_key" - reifyCrypto election_crypto $ \(_c::Proxy c) -> do + reify election_crypto $ \case + (c::Proxy c) | Dict <- groupDict c -> do election_name <- o .: "name" election_description <- o .: "description" election_questions <- o .: "questions" :: JSON.Parser [Question v] @@ -763,54 +742,6 @@ hashElection :: Election crypto v c -> Base64SHA256 hashElection = base64SHA256 . BSL.toStrict . JSON.encode --- ** Class 'ReifyCrypto' --- | @('reifyCrypto' crypto k)@ is like @('reify' crypto k)@ --- but gives to @(k)@ more constraints than just @('Reifies' c crypto)@, --- which is used when defining classes on @(crypto)@ --- where @(c)@ (the type variable guarantying the same --- @crypto@graphic parameters are used throughout) --- is not yet in scope and thus where one cannot --- add those constraints requiring to have @(c)@ in scope. --- See for instance the 'QuickcheckElection' class, in the tests. --- --- For convenience, the 'ReifyCrypto' class also implies the pervasive --- constraint 'Group'. -class - ( Group crypto - , Key crypto - , Show crypto - , NFData crypto - , JSON.ToJSON crypto - , JSON.FromJSON crypto - ) => ReifyCrypto crypto where - reifyCrypto :: - crypto -> (forall c. - Reifies c crypto => - GConstraints crypto c => - Proxy c -> r) -> r -instance ReifyCrypto FFC where - reifyCrypto = reify - --- ** Class 'GConstraints' --- | List the 'Constraint's on the element of the field --- when the @(crypto)@ has not been instantiated to a specific type yet. --- It concerns only 'Constraint's whose method act on @(a)@, --- not @(x c)@ (eg. 'Group'). -type GConstraints crypto c = - ( Multiplicative (G crypto c) - , Invertible (G crypto c) - , FromNatural (G crypto c) - , ToNatural (G crypto c) - , Eq (G crypto c) - , Ord (G crypto c) - , Show (G crypto c) - , NFData (G crypto c) - , FromJSON (G crypto c) - , ToJSON (G crypto c) - , FromJSON (G crypto c) - , ToJSON (G crypto c) - ) - -- * Type 'Ballot' data Ballot crypto v c = Ballot { ballot_answers :: ![Answer crypto v c] @@ -857,25 +788,19 @@ instance -- where 'opinionsByQuest' is a list of 'Opinion's -- on each 'question_choices' of each 'election_questions'. encryptBallot :: - forall crypto m v c r. - Reifies c crypto => Reifies v Version => - Group crypto => - Key crypto => - Multiplicative (G crypto c) => - Invertible (G crypto c) => - ToNatural (G crypto c) => + Reifies c crypto => Group crypto => Key crypto => Monad m => RandomGen r => Election crypto v c -> Maybe (SecretKey crypto c) -> [[Bool]] -> S.StateT r (ExceptT ErrorBallot m) (Ballot crypto v c) -encryptBallot Election{..} ballotSecKeyMay opinionsByQuest +encryptBallot (Election{..}::Election crypto v c) ballotSecKeyMay opinionsByQuest | List.length election_questions /= List.length opinionsByQuest = lift $ throwE $ ErrorBallot_WrongNumberOfAnswers (fromIntegral $ List.length opinionsByQuest) (fromIntegral $ List.length election_questions) - | otherwise = do + | otherwise, Dict <- groupDict (Proxy @c) = do let (voterKeys, voterZKP) = case ballotSecKeyMay of Nothing -> (Nothing, ZKP "") @@ -908,16 +833,12 @@ encryptBallot Election{..} ballotSecKeyMay opinionsByQuest } verifyBallot :: - forall crypto v c. Reifies v Version => - Reifies c crypto => - Group crypto => - Multiplicative (G crypto c) => - Invertible (G crypto c) => - ToNatural (G crypto c) => + Reifies c crypto => Group crypto => Election crypto v c -> Ballot crypto v c -> Bool -verifyBallot Election{..} Ballot{..} = +verifyBallot (Election{..}::Election crypto v c) Ballot{..} + | Dict <- groupDict (Proxy @c) = ballot_election_uuid == election_uuid && ballot_election_hash == election_hash && List.length election_questions == List.length ballot_answers && @@ -946,10 +867,7 @@ data Signature crypto v c = Signature -- ^ Verification key. , signature_proof :: !(Proof crypto v c) } deriving (Generic) -deriving instance - ( NFData crypto - , NFData (G crypto c) - ) => NFData (Signature crypto v c) +deriving instance (NFData crypto, NFData (G crypto c)) => NFData (Signature crypto v c) instance ( Reifies c crypto , Reifies v Version diff --git a/hjugement-protocol/src/Voting/Protocol/FFC.hs b/hjugement-protocol/src/Voting/Protocol/FFC.hs index 29acc05..2d49579 100644 --- a/hjugement-protocol/src/Voting/Protocol/FFC.hs +++ b/hjugement-protocol/src/Voting/Protocol/FFC.hs @@ -57,7 +57,7 @@ import Voting.Protocol.Credential -- is encoded at the type-level by including @c@ -- as a phantom type of 'F', 'G' and 'E'. data FFC = FFC - { ffc_name :: Text + { ffc_name :: !Text , ffc_fieldCharac :: !Natural -- ^ The prime number characteristic of a Finite Prime Field. -- @@ -121,6 +121,21 @@ instance Group FFC where groupGen = G $ ffc_groupGen $ reflect (Proxy::Proxy c) groupOrder :: forall c. Reifies c FFC => Proxy c -> Natural groupOrder c = ffc_groupOrder $ reflect c + groupDict Proxy = Dict +instance Key FFC where + cryptoType _ = "FFC" + cryptoName = ffc_name + randomSecretKey = random + credentialSecretKey (UUID uuid) (Credential cred) = + fromNatural $ decodeBigEndian $ + Crypto.fastPBKDF2_SHA256 + Crypto.Parameters + { Crypto.iterCounts = 1000 + , Crypto.outputLength = 32 -- bytes, ie. 256 bits + } + (Text.encodeUtf8 cred) + (Text.encodeUtf8 uuid) + publicKey = (groupGen @FFC ^) fieldCharac :: forall c. Reifies c FFC => Natural fieldCharac = ffc_fieldCharac $ reflect (Proxy::Proxy c) @@ -217,20 +232,3 @@ instance Reifies c FFC => Random.Random (G FFC c) where instance Reifies c FFC => Invertible (G FFC c) where -- | NOTE: add 'groupOrder' so the exponent given to (^) is positive. inv = (^ E (fromJust $ groupOrder @FFC (Proxy @c)`minusNaturalMaybe`1)) - --- * Conversions - -instance Key FFC where - cryptoType _ = "FFC" - cryptoName = ffc_name - randomSecretKey = random - credentialSecretKey (UUID uuid) (Credential cred) = - fromNatural $ decodeBigEndian $ - Crypto.fastPBKDF2_SHA256 - Crypto.Parameters - { Crypto.iterCounts = 1000 - , Crypto.outputLength = 32 -- bytes, ie. 256 bits - } - (Text.encodeUtf8 cred) - (Text.encodeUtf8 uuid) - publicKey = (groupGen @FFC ^) diff --git a/hjugement-protocol/tests/HUnit/Credential.hs b/hjugement-protocol/tests/HUnit/Credential.hs index 12ea5ad..a47531e 100644 --- a/hjugement-protocol/tests/HUnit/Credential.hs +++ b/hjugement-protocol/tests/HUnit/Credential.hs @@ -35,7 +35,7 @@ hunit _v = testGroup "Credential" , "xLcs7ev6Jy6FHHE" ==> Right (Credential "xLcs7ev6Jy6FHHE") ] , testGroup "credentialSecretKey" $ - [ testSecretKey beleniosFFC + [ reify beleniosFFC $ testSecretKey (UUID "xLcs7ev6Jy6FHH") (Credential "xLcs7ev6Jy6FHHE") 24202898752499029126606335829564687069186982035759723128887013101942425902424 @@ -43,10 +43,10 @@ hunit _v = testGroup "Credential" ] testSecretKey :: - ReifyCrypto crypto => - Key crypto => - crypto -> UUID -> Credential -> Natural -> TestTree -testSecretKey crypto uuid cred exp = - reifyCrypto crypto $ \(Proxy::Proxy c) -> + Reifies c crypto => Group crypto => Key crypto => + UUID -> Credential -> Natural -> + Proxy c -> TestTree +testSecretKey uuid cred exp (c::Proxy c) + | Dict <- groupDict c = testCase (show (uuid,cred)) $ credentialSecretKey @_ @c uuid cred @?= E exp diff --git a/hjugement-protocol/tests/HUnit/Election.hs b/hjugement-protocol/tests/HUnit/Election.hs index 6715544..924d042 100644 --- a/hjugement-protocol/tests/HUnit/Election.hs +++ b/hjugement-protocol/tests/HUnit/Election.hs @@ -32,9 +32,7 @@ hunit v = testGroup "Election" $ ] hunitsEncryptBallot :: - ReifyCrypto crypto => - JSON.ToJSON crypto => - Key crypto => + Group crypto => Key crypto => JSON.ToJSON crypto => Reifies v Version => Proxy v -> crypto -> TestTree hunitsEncryptBallot v crypto = @@ -81,31 +79,30 @@ hunitsEncryptBallot v crypto = ] hunitEncryptBallot :: - ReifyCrypto crypto => - JSON.ToJSON crypto => - Key crypto => + Group crypto => Key crypto => JSON.ToJSON crypto => Reifies v Version => Proxy v -> crypto -> Int -> [Question v] -> [[Bool]] -> Either ErrorBallot Bool -> TestTree hunitEncryptBallot v election_crypto seed election_questions opins exp = let got = - reifyCrypto election_crypto $ \(Proxy::Proxy c) -> - runExcept $ - (`evalStateT` Random.mkStdGen seed) $ do - election_uuid <- randomUUID - cred <- randomCredential - let ballotSecKey = credentialSecretKey @_ @c election_uuid cred - election_public_key <- publicKey <$> randomSecretKey - let elec = Election - { election_name = "election" - , election_description = "description" - , election_hash = hashElection elec - , election_version = Just (reflect v) - , .. - } - verifyBallot elec - <$> encryptBallot elec (Just ballotSecKey) opins + reify election_crypto $ \case + (c::Proxy c) | Dict <- groupDict c -> + runExcept $ + (`evalStateT` Random.mkStdGen seed) $ do + election_uuid <- randomUUID + cred <- randomCredential + let ballotSecKey = credentialSecretKey @_ @c election_uuid cred + election_public_key <- publicKey <$> randomSecretKey + let elec = Election + { election_name = "election" + , election_description = "description" + , election_hash = hashElection elec + , election_version = Just (reflect v) + , .. + } + verifyBallot elec + <$> encryptBallot elec (Just ballotSecKey) opins in testCase (show opins) $ got @?= exp diff --git a/hjugement-protocol/tests/HUnit/FFC.hs b/hjugement-protocol/tests/HUnit/FFC.hs index 0d68469..2bef3d3 100644 --- a/hjugement-protocol/tests/HUnit/FFC.hs +++ b/hjugement-protocol/tests/HUnit/FFC.hs @@ -38,13 +38,13 @@ hunit _v = testGroup "FFC" hunitInv :: forall crypto. - ReifyCrypto crypto => - Key crypto => + Group crypto => Key crypto => crypto -> TestTree hunitInv crypto = testGroup (Text.unpack $ cryptoName crypto) [ testCase "groupGen" $ - reifyCrypto crypto $ \(_c::Proxy c) -> - inv (groupGen :: G crypto c) @?= - groupGen ^ E (fromJust $ groupOrder (Proxy @c) `minusNaturalMaybe` one) + reify crypto $ \case + (c::Proxy c) | Dict <- groupDict c -> + inv (groupGen :: G crypto c) @?= + groupGen ^ E (fromJust $ groupOrder (Proxy @c) `minusNaturalMaybe` one) ] diff --git a/hjugement-protocol/tests/HUnit/Trustee/Indispensable.hs b/hjugement-protocol/tests/HUnit/Trustee/Indispensable.hs index b654f4e..45109c8 100644 --- a/hjugement-protocol/tests/HUnit/Trustee/Indispensable.hs +++ b/hjugement-protocol/tests/HUnit/Trustee/Indispensable.hs @@ -24,7 +24,7 @@ hunit v = testGroup "Indispensable" $ ] testsVerifyIndispensableTrusteePublicKey :: - ReifyCrypto crypto => + Group crypto => Key crypto => Reifies v Version => Proxy v -> crypto -> TestTree testsVerifyIndispensableTrusteePublicKey v crypto = @@ -34,23 +34,24 @@ testsVerifyIndispensableTrusteePublicKey v crypto = testVerifyIndispensableTrusteePublicKey :: forall crypto v. - ReifyCrypto crypto => + Group crypto => Key crypto => Reifies v Version => Proxy v -> crypto -> Int -> Either ErrorTrusteePublicKey () -> TestTree testVerifyIndispensableTrusteePublicKey (_v::Proxy v) crypto seed exp = - reifyCrypto crypto $ \(Proxy::Proxy c) -> - let got = - runExcept $ - (`evalStateT` Random.mkStdGen seed) $ do - trusteeSecKey :: SecretKey crypto c <- randomSecretKey - trusteePubKey :: TrusteePublicKey crypto v c <- proveIndispensableTrusteePublicKey trusteeSecKey - lift $ verifyIndispensableTrusteePublicKey trusteePubKey - in - testCase (Text.unpack $ cryptoName crypto) $ - got @?= exp + reify crypto $ \case + (c::Proxy c) | Dict <- groupDict c -> + let got = + runExcept $ + (`evalStateT` Random.mkStdGen seed) $ do + trusteeSecKey :: SecretKey crypto c <- randomSecretKey + trusteePubKey :: TrusteePublicKey crypto v c <- proveIndispensableTrusteePublicKey trusteeSecKey + lift $ verifyIndispensableTrusteePublicKey trusteePubKey + in + testCase (Text.unpack $ cryptoName @crypto crypto) $ + got @?= exp testsVerifyTally :: - ReifyCrypto crypto => + Group crypto => Key crypto => Reifies v Version => Proxy v -> crypto -> TestTree testsVerifyTally v crypto = @@ -63,33 +64,34 @@ testsVerifyTally v crypto = ] testVerifyTally :: - ReifyCrypto crypto => + Group crypto => Key crypto => Reifies v Version => Proxy v -> crypto -> Int -> Natural -> Natural -> Natural -> TestTree testVerifyTally (_v::Proxy v) crypto seed nTrustees nQuests nChoices = let clearTallyResult = dummyTallyResult nQuests nChoices in let decryptedTallyResult :: Either ErrorTally [[Natural]] = - reifyCrypto crypto $ \(Proxy::Proxy c) -> - runExcept $ - (`evalStateT` Random.mkStdGen seed) $ do - secKeyByTrustee :: [SecretKey crypto c] <- - replicateM (fromIntegral nTrustees) $ randomSecretKey - trusteePubKeys - :: [TrusteePublicKey crypto v c] - <- forM secKeyByTrustee $ proveIndispensableTrusteePublicKey - let pubKeyByTrustee = trustee_PublicKey <$> trusteePubKeys - let elecPubKey = combineIndispensableTrusteePublicKeys trusteePubKeys - (encTally, countMax) <- encryptTallyResult elecPubKey clearTallyResult - decShareByTrustee - :: [DecryptionShare crypto v c] - <- forM secKeyByTrustee $ proveDecryptionShare encTally - lift $ verifyDecryptionShareByTrustee encTally pubKeyByTrustee decShareByTrustee - tally@Tally{..} <- lift $ - proveTally (encTally, countMax) decShareByTrustee $ + reify crypto $ \case + (c::Proxy c) | Dict <- groupDict c -> + runExcept $ + (`evalStateT` Random.mkStdGen seed) $ do + secKeyByTrustee :: [SecretKey crypto c] <- + replicateM (fromIntegral nTrustees) $ randomSecretKey + trusteePubKeys + :: [TrusteePublicKey crypto v c] + <- forM secKeyByTrustee $ proveIndispensableTrusteePublicKey + let pubKeyByTrustee = trustee_PublicKey <$> trusteePubKeys + let elecPubKey = combineIndispensableTrusteePublicKeys trusteePubKeys + (encTally, countMax) <- encryptTallyResult elecPubKey clearTallyResult + decShareByTrustee + :: [DecryptionShare crypto v c] + <- forM secKeyByTrustee $ proveDecryptionShare encTally + lift $ verifyDecryptionShareByTrustee encTally pubKeyByTrustee decShareByTrustee + tally@Tally{..} <- lift $ + proveTally (encTally, countMax) decShareByTrustee $ + combineIndispensableDecryptionShares pubKeyByTrustee + lift $ verifyTally tally $ combineIndispensableDecryptionShares pubKeyByTrustee - lift $ verifyTally tally $ - combineIndispensableDecryptionShares pubKeyByTrustee - return tally_countByChoiceByQuest + return tally_countByChoiceByQuest in testCase (Printf.printf "#T=%i,#Q=%i,#C=%i (%i maxCount)" nTrustees nQuests nChoices diff --git a/hjugement-protocol/tests/QuickCheck/Election.hs b/hjugement-protocol/tests/QuickCheck/Election.hs index 07d4352..9a1875c 100644 --- a/hjugement-protocol/tests/QuickCheck/Election.hs +++ b/hjugement-protocol/tests/QuickCheck/Election.hs @@ -27,19 +27,19 @@ maxArbitraryQuestions = 2 quickcheck :: Reifies v Version => Proxy v -> TestTree quickcheck v = testGroup "Election" - [ testGroup "verifyBallot" $ - [ quickcheckElection v weakFFC - , quickcheckElection v beleniosFFC + [ testGroup "verifyBallot" $ + [ reify weakFFC $ quickcheckElection v + , reify beleniosFFC $ quickcheckElection v ] ] quickcheckElection :: - ReifyCrypto crypto => + Reifies c crypto => Group crypto => Key crypto => JSON.ToJSON crypto => Show crypto => Reifies v Version => Proxy v -> - crypto -> TestTree -quickcheckElection (_v::Proxy v) crypto = - reifyCrypto crypto $ \(Proxy::Proxy c) -> - testGroup (Text.unpack $ cryptoName crypto) + Proxy c -> TestTree +quickcheckElection (_v::Proxy v) (c::Proxy c) + | Dict <- groupDict c = + testGroup (Text.unpack $ cryptoName (reflect c)) [ testProperty "verifyBallot" $ \(seed, (elec::Election crypto v c) :> votes) -> isRight $ runExcept $ (`evalStateT` mkStdGen seed) $ do @@ -154,11 +154,8 @@ instance , Group crypto , Key crypto , JSON.ToJSON crypto - , JSON.ToJSON (G crypto c) - , Multiplicative (G crypto c) - , Invertible (G crypto c) ) => Arbitrary (Election crypto v c :> [[Bool]]) where - arbitrary = do + arbitrary | Dict <- groupDict (Proxy @c) = do elec@Election{..} <- arbitrary votes <- forM election_questions $ \Question{..} -> do let numChoices = List.length question_choices @@ -166,7 +163,7 @@ instance rank <- choose (0, nCk numChoices numTrue - 1) return $ boolsOfCombin numChoices numTrue rank return (elec :> votes) - shrink (elec :> votes) = + shrink | Dict <- groupDict (Proxy @c) = \(elec :> votes) -> [ e :> List.zipWith shrinkVotes (election_questions e :: [Question v]) votes | e <- shrink elec ] diff --git a/hjugement-protocol/tests/QuickCheck/Trustee.hs b/hjugement-protocol/tests/QuickCheck/Trustee.hs index 72b1ba3..8c1e90d 100644 --- a/hjugement-protocol/tests/QuickCheck/Trustee.hs +++ b/hjugement-protocol/tests/QuickCheck/Trustee.hs @@ -15,18 +15,18 @@ quickcheck :: Reifies v Version => Proxy v -> TestTree quickcheck v = testGroup "Trustee" $ [ testGroup "verifyIndispensableTrusteePublicKey" $ - [ testIndispensableTrusteePublicKey v weakFFC - , testIndispensableTrusteePublicKey v beleniosFFC + [ reify weakFFC $ testIndispensableTrusteePublicKey v + , reify beleniosFFC $ testIndispensableTrusteePublicKey v ] ] testIndispensableTrusteePublicKey :: - ReifyCrypto crypto => - Reifies v Version => Proxy v -> - crypto -> TestTree -testIndispensableTrusteePublicKey (_v::Proxy v) crypto = - reifyCrypto crypto $ \(Proxy::Proxy c) -> - testGroup (Text.unpack $ cryptoName crypto) + Reifies v Version => + Reifies c crypto => Group crypto => Key crypto => + Proxy v -> Proxy c -> TestTree +testIndispensableTrusteePublicKey (_v::Proxy v) (c::Proxy c) + | Dict <- groupDict (Proxy @c) = + testGroup (Text.unpack $ cryptoName (reflect c)) [ testProperty "Right" $ \seed -> isRight $ runExcept $ (`evalStateT` mkStdGen seed) $ do -- 2.44.1 From 064b4c11cc49d595039393b6771e27ab67066065 Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Wed, 30 Oct 2019 00:57:55 +0000 Subject: [PATCH 15/16] protocol: work around to avoid ConstraintKinds NOTE: in the hope to keep the Haskell code as close as possible to the (future) PureScript code. --- hjugement-protocol/hjugement-protocol.cabal | 2 +- hjugement-protocol/src/Voting/Protocol/Election.hs | 12 +++++------- hjugement-protocol/src/Voting/Protocol/FFC.hs | 5 +++-- hjugement-protocol/tests/HUnit/Credential.hs | 3 +-- hjugement-protocol/tests/HUnit/Election.hs | 3 +-- hjugement-protocol/tests/HUnit/FFC.hs | 3 +-- .../tests/HUnit/Trustee/Indispensable.hs | 6 ++---- hjugement-protocol/tests/QuickCheck/Election.hs | 7 +++---- hjugement-protocol/tests/QuickCheck/Trustee.hs | 3 +-- 9 files changed, 18 insertions(+), 26 deletions(-) diff --git a/hjugement-protocol/hjugement-protocol.cabal b/hjugement-protocol/hjugement-protocol.cabal index 452ee6e..20282c5 100644 --- a/hjugement-protocol/hjugement-protocol.cabal +++ b/hjugement-protocol/hjugement-protocol.cabal @@ -72,7 +72,7 @@ Library default-language: Haskell2010 default-extensions: AllowAmbiguousTypes - ConstraintKinds + -- ConstraintKinds DefaultSignatures FlexibleContexts FlexibleInstances diff --git a/hjugement-protocol/src/Voting/Protocol/Election.hs b/hjugement-protocol/src/Voting/Protocol/Election.hs index 0e3f706..471a81f 100644 --- a/hjugement-protocol/src/Voting/Protocol/Election.hs +++ b/hjugement-protocol/src/Voting/Protocol/Election.hs @@ -593,7 +593,7 @@ encryptAnswer (elecPubKey::PublicKey crypto c) zkp Question{..} opinionByChoice ErrorAnswer_WrongNumberOfOpinions (fromIntegral $ List.length opinions) (fromIntegral $ List.length question_choices) - | otherwise, Dict <- groupDict (Proxy @c) = do + | otherwise = groupReify (Proxy @c) $ do encryptions <- encrypt elecPubKey `mapM` opinions individualProofs <- zipWithM (\opinion -> proveEncryption elecPubKey zkp $ @@ -625,7 +625,7 @@ verifyAnswer :: Question v -> Answer crypto v c -> Bool verifyAnswer (elecPubKey::PublicKey crypto c) zkp Question{..} Answer{..} | List.length question_choices /= List.length answer_opinions = False - | otherwise, Dict <- groupDict (Proxy @c) = + | otherwise = groupReify (Proxy @c) $ do either (const False) id $ runExcept $ do validOpinions <- verifyEncryption elecPubKey zkp booleanDisjunctions @@ -720,8 +720,7 @@ readElection filePath k = do pubKey :: JSON.Value <- obj .: "y" return (crypto, pubKey) ) o "public_key" - reify election_crypto $ \case - (c::Proxy c) | Dict <- groupDict c -> do + reify election_crypto $ \(c::Proxy c) -> groupReify c $ do election_name <- o .: "name" election_description <- o .: "description" election_questions <- o .: "questions" :: JSON.Parser [Question v] @@ -800,7 +799,7 @@ encryptBallot (Election{..}::Election crypto v c) ballotSecKeyMay opinionsByQues ErrorBallot_WrongNumberOfAnswers (fromIntegral $ List.length opinionsByQuest) (fromIntegral $ List.length election_questions) - | otherwise, Dict <- groupDict (Proxy @c) = do + | otherwise = groupReify (Proxy @c) $ do let (voterKeys, voterZKP) = case ballotSecKeyMay of Nothing -> (Nothing, ZKP "") @@ -837,8 +836,7 @@ verifyBallot :: Reifies c crypto => Group crypto => Election crypto v c -> Ballot crypto v c -> Bool -verifyBallot (Election{..}::Election crypto v c) Ballot{..} - | Dict <- groupDict (Proxy @c) = +verifyBallot (Election{..}::Election crypto v c) Ballot{..} = groupReify (Proxy @c) $ ballot_election_uuid == election_uuid && ballot_election_hash == election_hash && List.length election_questions == List.length ballot_answers && diff --git a/hjugement-protocol/src/Voting/Protocol/FFC.hs b/hjugement-protocol/src/Voting/Protocol/FFC.hs index 2d49579..e4d6ddd 100644 --- a/hjugement-protocol/src/Voting/Protocol/FFC.hs +++ b/hjugement-protocol/src/Voting/Protocol/FFC.hs @@ -45,7 +45,7 @@ import Voting.Protocol.Arith import Voting.Protocol.Credential -- * Type 'FFC' --- | Mutiplicative Sub-Group of a Finite Prime Field. +-- | Mutiplicative subgroup of a Finite Prime Field. -- -- NOTE: an 'FFC' term-value is brought into the context of many functions -- through a type-variable @c@ whose 'Reifies' constraint enables to 'reflect' @@ -121,7 +121,8 @@ instance Group FFC where groupGen = G $ ffc_groupGen $ reflect (Proxy::Proxy c) groupOrder :: forall c. Reifies c FFC => Proxy c -> Natural groupOrder c = ffc_groupOrder $ reflect c - groupDict Proxy = Dict + -- groupDict Proxy = Dict + groupReify c k = k instance Key FFC where cryptoType _ = "FFC" cryptoName = ffc_name diff --git a/hjugement-protocol/tests/HUnit/Credential.hs b/hjugement-protocol/tests/HUnit/Credential.hs index a47531e..f899e79 100644 --- a/hjugement-protocol/tests/HUnit/Credential.hs +++ b/hjugement-protocol/tests/HUnit/Credential.hs @@ -46,7 +46,6 @@ testSecretKey :: Reifies c crypto => Group crypto => Key crypto => UUID -> Credential -> Natural -> Proxy c -> TestTree -testSecretKey uuid cred exp (c::Proxy c) - | Dict <- groupDict c = +testSecretKey uuid cred exp (c::Proxy c) = groupReify c $ testCase (show (uuid,cred)) $ credentialSecretKey @_ @c uuid cred @?= E exp diff --git a/hjugement-protocol/tests/HUnit/Election.hs b/hjugement-protocol/tests/HUnit/Election.hs index 924d042..2f34b36 100644 --- a/hjugement-protocol/tests/HUnit/Election.hs +++ b/hjugement-protocol/tests/HUnit/Election.hs @@ -86,8 +86,7 @@ hunitEncryptBallot :: TestTree hunitEncryptBallot v election_crypto seed election_questions opins exp = let got = - reify election_crypto $ \case - (c::Proxy c) | Dict <- groupDict c -> + reify election_crypto $ \(c::Proxy c) -> groupReify c $ runExcept $ (`evalStateT` Random.mkStdGen seed) $ do election_uuid <- randomUUID diff --git a/hjugement-protocol/tests/HUnit/FFC.hs b/hjugement-protocol/tests/HUnit/FFC.hs index 2bef3d3..a687231 100644 --- a/hjugement-protocol/tests/HUnit/FFC.hs +++ b/hjugement-protocol/tests/HUnit/FFC.hs @@ -43,8 +43,7 @@ hunitInv :: hunitInv crypto = testGroup (Text.unpack $ cryptoName crypto) [ testCase "groupGen" $ - reify crypto $ \case - (c::Proxy c) | Dict <- groupDict c -> + reify crypto $ \(c::Proxy c) -> groupReify c $ inv (groupGen :: G crypto c) @?= groupGen ^ E (fromJust $ groupOrder (Proxy @c) `minusNaturalMaybe` one) ] diff --git a/hjugement-protocol/tests/HUnit/Trustee/Indispensable.hs b/hjugement-protocol/tests/HUnit/Trustee/Indispensable.hs index 45109c8..7fe3b25 100644 --- a/hjugement-protocol/tests/HUnit/Trustee/Indispensable.hs +++ b/hjugement-protocol/tests/HUnit/Trustee/Indispensable.hs @@ -38,8 +38,7 @@ testVerifyIndispensableTrusteePublicKey :: Reifies v Version => Proxy v -> crypto -> Int -> Either ErrorTrusteePublicKey () -> TestTree testVerifyIndispensableTrusteePublicKey (_v::Proxy v) crypto seed exp = - reify crypto $ \case - (c::Proxy c) | Dict <- groupDict c -> + reify crypto $ \(c::Proxy c) -> groupReify c $ let got = runExcept $ (`evalStateT` Random.mkStdGen seed) $ do @@ -70,8 +69,7 @@ testVerifyTally :: testVerifyTally (_v::Proxy v) crypto seed nTrustees nQuests nChoices = let clearTallyResult = dummyTallyResult nQuests nChoices in let decryptedTallyResult :: Either ErrorTally [[Natural]] = - reify crypto $ \case - (c::Proxy c) | Dict <- groupDict c -> + reify crypto $ \(c::Proxy c) -> groupReify c $ runExcept $ (`evalStateT` Random.mkStdGen seed) $ do secKeyByTrustee :: [SecretKey crypto c] <- diff --git a/hjugement-protocol/tests/QuickCheck/Election.hs b/hjugement-protocol/tests/QuickCheck/Election.hs index 9a1875c..9502974 100644 --- a/hjugement-protocol/tests/QuickCheck/Election.hs +++ b/hjugement-protocol/tests/QuickCheck/Election.hs @@ -37,8 +37,7 @@ quickcheckElection :: Reifies c crypto => Group crypto => Key crypto => JSON.ToJSON crypto => Show crypto => Reifies v Version => Proxy v -> Proxy c -> TestTree -quickcheckElection (_v::Proxy v) (c::Proxy c) - | Dict <- groupDict c = +quickcheckElection (_v::Proxy v) (c::Proxy c) = groupReify c $ testGroup (Text.unpack $ cryptoName (reflect c)) [ testProperty "verifyBallot" $ \(seed, (elec::Election crypto v c) :> votes) -> isRight $ runExcept $ @@ -155,7 +154,7 @@ instance , Key crypto , JSON.ToJSON crypto ) => Arbitrary (Election crypto v c :> [[Bool]]) where - arbitrary | Dict <- groupDict (Proxy @c) = do + arbitrary = groupReify (Proxy @c) $ do elec@Election{..} <- arbitrary votes <- forM election_questions $ \Question{..} -> do let numChoices = List.length question_choices @@ -163,7 +162,7 @@ instance rank <- choose (0, nCk numChoices numTrue - 1) return $ boolsOfCombin numChoices numTrue rank return (elec :> votes) - shrink | Dict <- groupDict (Proxy @c) = \(elec :> votes) -> + shrink (elec :> votes) = groupReify (Proxy @c) $ [ e :> List.zipWith shrinkVotes (election_questions e :: [Question v]) votes | e <- shrink elec ] diff --git a/hjugement-protocol/tests/QuickCheck/Trustee.hs b/hjugement-protocol/tests/QuickCheck/Trustee.hs index 8c1e90d..d7b2124 100644 --- a/hjugement-protocol/tests/QuickCheck/Trustee.hs +++ b/hjugement-protocol/tests/QuickCheck/Trustee.hs @@ -24,8 +24,7 @@ testIndispensableTrusteePublicKey :: Reifies v Version => Reifies c crypto => Group crypto => Key crypto => Proxy v -> Proxy c -> TestTree -testIndispensableTrusteePublicKey (_v::Proxy v) (c::Proxy c) - | Dict <- groupDict (Proxy @c) = +testIndispensableTrusteePublicKey (_v::Proxy v) (c::Proxy c) = groupReify c $ testGroup (Text.unpack $ cryptoName (reflect c)) [ testProperty "Right" $ \seed -> isRight $ runExcept $ -- 2.44.1 From 8c07dc63f95b5563b2742ce44f9b895588604cd2 Mon Sep 17 00:00:00 2001 From: Julien Moutinho Date: Thu, 31 Oct 2019 15:23:36 +0000 Subject: [PATCH 16/16] protocol: bring c from the method level to the class level --- hjugement-cli/hjugement-cli.cabal | 4 +- hjugement-cli/src/Hjugement/CLI/Utils.hs | 5 +- hjugement-protocol/benchmarks/Election.hs | 93 +++++------ hjugement-protocol/hjugement-protocol.cabal | 3 +- .../src/Voting/Protocol/Election.hs | 156 +++++++----------- hjugement-protocol/src/Voting/Protocol/FFC.hs | 10 +- .../src/Voting/Protocol/Tally.hs | 80 ++------- .../Voting/Protocol/Trustee/Indispensable.hs | 43 +---- hjugement-protocol/tests/HUnit/Credential.hs | 14 +- hjugement-protocol/tests/HUnit/Election.hs | 17 +- hjugement-protocol/tests/HUnit/FFC.hs | 4 +- .../tests/HUnit/Trustee/Indispensable.hs | 25 ++- .../tests/QuickCheck/Election.hs | 36 ++-- .../tests/QuickCheck/Trustee.hs | 10 +- 14 files changed, 178 insertions(+), 322 deletions(-) diff --git a/hjugement-cli/hjugement-cli.cabal b/hjugement-cli/hjugement-cli.cabal index 4fc4179..b5db1ae 100644 --- a/hjugement-cli/hjugement-cli.cabal +++ b/hjugement-cli/hjugement-cli.cabal @@ -2,7 +2,7 @@ name: hjugement-cli -- PVP: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.0.0.20191028 +version: 0.0.0.20191031 category: Politic synopsis: Majority Judgment and Helios-C command line tool description: @@ -74,7 +74,7 @@ Executable hjugement -- -fhide-source-paths build-depends: hjugement >= 2.0.2 - , hjugement-protocol >= 0.0.8 + , hjugement-protocol >= 0.0.9 , aeson >= 1.3 , base >= 4.6 && < 5 , base64-bytestring >= 1.0 diff --git a/hjugement-cli/src/Hjugement/CLI/Utils.hs b/hjugement-cli/src/Hjugement/CLI/Utils.hs index eb6071b..44deac6 100644 --- a/hjugement-cli/src/Hjugement/CLI/Utils.hs +++ b/hjugement-cli/src/Hjugement/CLI/Utils.hs @@ -95,7 +95,7 @@ instance CLI.FromSegment VP.Credential where fromSegment = return . left show . VP.readCredential . Text.pack instance IOType (VP.DecryptionShare VP.FFC () ()) instance Outputable (VP.DecryptionShare VP.FFC () ()) where - output decShare = output $ JSON.encode decShare<>"\n" + output decShare = output $ JSON.encode (decShare)<>"\n" api_help full = if full @@ -305,8 +305,7 @@ loadElection :: IO.FilePath -> (forall v c. VP.Reifies v VP.Version => - VP.Reifies c crypto => - VP.FieldElementConstraints crypto c => + VP.GroupParams crypto c => VP.Election crypto v c -> MaybeT m r) -> MaybeT m r loadElection glob filePath k = diff --git a/hjugement-protocol/benchmarks/Election.hs b/hjugement-protocol/benchmarks/Election.hs index 1386493..4186675 100644 --- a/hjugement-protocol/benchmarks/Election.hs +++ b/hjugement-protocol/benchmarks/Election.hs @@ -13,10 +13,9 @@ import Utils makeElection :: forall crypto v c. Reifies v Version => - Reifies c crypto => - JSON.ToJSON crypto => - JSON.ToJSON (G crypto c) => + GroupParams crypto c => Key crypto => + JSON.ToJSON crypto => Int -> Int -> Election crypto v c makeElection nQuests nChoices = elec where @@ -48,12 +47,7 @@ makeVotes Election{..} = makeBallot :: Reifies v Version => - Reifies c crypto => - Group crypto => - Key crypto => - Multiplicative (G crypto c) => - Invertible (G crypto c) => - ToNatural (G crypto c) => + GroupParams crypto c => Key crypto => Election crypto v c -> Ballot crypto v c makeBallot elec = case runExcept $ (`evalStateT` mkStdGen seed) $ do @@ -75,19 +69,13 @@ titleElection Election{..} = benchEncryptBallot :: forall crypto v c. + GroupParams crypto c => Reifies v Version => - Reifies c crypto => - JSON.ToJSON crypto => - Group crypto => Key crypto => + JSON.ToJSON crypto => NFData crypto => - NFData (G crypto c) => - Multiplicative (G crypto c) => - Invertible (G crypto c) => - ToNatural (G crypto c) => - JSON.ToJSON (G crypto c) => Proxy v -> Proxy c -> Int -> Int -> Benchmark -benchEncryptBallot (_v::Proxy v) (_c::Proxy c) nQuests nChoices = +benchEncryptBallot _v _c nQuests nChoices = let setupEnv = do let elec :: Election crypto v c = makeElection nQuests nChoices return elec in @@ -98,16 +86,10 @@ benchEncryptBallot (_v::Proxy v) (_c::Proxy c) nQuests nChoices = benchVerifyBallot :: forall crypto v c. Reifies v Version => - Reifies c crypto => - JSON.ToJSON crypto => - Group crypto => + GroupParams crypto c => Key crypto => + JSON.ToJSON crypto => NFData crypto => - NFData (G crypto c) => - Multiplicative (G crypto c) => - Invertible (G crypto c) => - ToNatural (G crypto c) => - JSON.ToJSON (G crypto c) => Proxy v -> Proxy c -> Int -> Int -> Benchmark benchVerifyBallot (_v::Proxy v) (_c::Proxy c) nQuests nChoices = let setupEnv = do @@ -120,31 +102,40 @@ benchVerifyBallot (_v::Proxy v) (_c::Proxy c) nQuests nChoices = benchmarks :: [Benchmark] benchmarks = - let inputs = - [ (nQ,nC) - | nQ <- [1,5,10,15,20,25] - , nC <- [5,7] - ] in - [ bgroup "stableVersion" $ reify stableVersion $ \v -> - [ bgroup "weakFFC" $ reify weakFFC $ \c -> - [ bgroup "encryptBallot" - [ benchEncryptBallot v c nQuests nChoices - | (nQuests,nChoices) <- inputs - ] - , bgroup "verifyBallot" - [ benchVerifyBallot v c nQuests nChoices - | (nQuests,nChoices) <- inputs - ] + [ benchsByVersion stableVersion + -- , benchsByVersion experimentalVersion + ] + +benchsByVersion :: Version -> Benchmark +benchsByVersion version = + reify version $ \v -> + bgroup ("v"<>show version) + [ benchsByCrypto v weakFFC + , benchsByCrypto v beleniosFFC + ] + +benchsByCrypto :: + Reifies v Version => + ReifyCrypto crypto => + Key crypto => + JSON.ToJSON crypto => + NFData crypto => + Proxy v -> crypto -> Benchmark +benchsByCrypto v crypto = + reifyCrypto crypto $ \c -> + bgroup (Text.unpack (cryptoName crypto)) + [ bgroup "encryptBallot" + [ benchEncryptBallot v c nQuests nChoices + | (nQuests,nChoices) <- inputs ] - , bgroup "beleniosFFC" $ reify beleniosFFC $ \c -> - [ bgroup "encryptBallot" - [ benchEncryptBallot v c nQuests nChoices - | (nQuests,nChoices) <- inputs - ] - , bgroup "verifyBallot" - [ benchVerifyBallot v c nQuests nChoices - | (nQuests,nChoices) <- inputs - ] + , bgroup "verifyBallot" + [ benchVerifyBallot v c nQuests nChoices + | (nQuests,nChoices) <- inputs ] ] - ] + where + inputs = + [ (nQ,nC) + | nQ <- [1,5,10,15,20,25] + , nC <- [5,7] + ] diff --git a/hjugement-protocol/hjugement-protocol.cabal b/hjugement-protocol/hjugement-protocol.cabal index 20282c5..7223a21 100644 --- a/hjugement-protocol/hjugement-protocol.cabal +++ b/hjugement-protocol/hjugement-protocol.cabal @@ -2,7 +2,7 @@ name: hjugement-protocol -- PVP: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.0.8.20191027 +version: 0.0.9.20191031 category: Politic synopsis: A cryptographic protocol for the Majority Judgment. description: @@ -211,6 +211,7 @@ Benchmark hjugement-protocol-benchmark build-depends: base >= 4.6 && < 5 , hjugement-protocol + , aeson >= 1.3 , containers >= 0.5 , criterion >= 1.4 , deepseq >= 1.4 diff --git a/hjugement-protocol/src/Voting/Protocol/Election.hs b/hjugement-protocol/src/Voting/Protocol/Election.hs index 471a81f..dabf4be 100644 --- a/hjugement-protocol/src/Voting/Protocol/Election.hs +++ b/hjugement-protocol/src/Voting/Protocol/Election.hs @@ -79,8 +79,7 @@ deriving instance (Show (G crypto c), Show (G crypto c)) => Show (Encryption cry deriving instance NFData (G crypto c) => NFData (Encryption crypto v c) instance ( Reifies v Version - , Reifies c crypto - , ToJSON (G crypto c) + , GroupParams crypto c ) => ToJSON (Encryption crypto v c) where toJSON Encryption{..} = JSON.object @@ -94,8 +93,7 @@ instance ) instance ( Reifies v Version - , Reifies c crypto - , FromJSON (G crypto c) + , GroupParams crypto c ) => FromJSON (Encryption crypto v c) where parseJSON = JSON.withObject "Encryption" $ \o -> do encryption_nonce <- o .: "alpha" @@ -104,10 +102,7 @@ instance -- | Additive homomorphism. -- Using the fact that: @'groupGen' '^'x '*' 'groupGen' '^'y '==' 'groupGen' '^'(x'+'y)@. -instance - ( Reifies c crypto - , Multiplicative (G crypto c) - ) => Additive (Encryption crypto v c) where +instance GroupParams crypto c => Additive (Encryption crypto v c) where zero = Encryption one one x+y = Encryption (encryption_nonce x * encryption_nonce y) @@ -126,9 +121,7 @@ type EncryptionNonce = E -- without the 'SecretKey' associated with 'pubKey'. encrypt :: Reifies v Version => - Reifies c crypto => - Group crypto => - Multiplicative (G crypto c) => + GroupParams crypto c => Monad m => RandomGen r => PublicKey crypto c -> E crypto c -> S.StateT r m (EncryptionNonce crypto c, Encryption crypto v c) @@ -176,7 +169,7 @@ data Proof crypto v c = Proof -- to ensure that each 'prove' does not reveal any information -- about its secret. } deriving (Eq,Show,NFData,Generic) -instance Group crypto => ToJSON (Proof crypto v c) where +instance ToJSON (Proof crypto v c) where toJSON Proof{..} = JSON.object [ "challenge" .= proof_challenge @@ -187,7 +180,7 @@ instance Group crypto => ToJSON (Proof crypto v c) where ( "challenge" .= proof_challenge <> "response" .= proof_response ) -instance (Reifies c crypto, Group crypto) => FromJSON (Proof crypto v c) where +instance GroupParams crypto c => FromJSON (Proof crypto v c) where parseJSON = JSON.withObject "TrusteePublicKey" $ \o -> do proof_challenge <- o .: "challenge" proof_response <- o .: "response" @@ -240,10 +233,8 @@ type Oracle list crypto c = list (Commitment crypto c) -> Challenge crypto c -- can be used to deduce @sec@ (using the special-soundness). prove :: forall crypto v c list m r. - Reifies c crypto => Reifies v Version => - Group crypto => - Multiplicative (G crypto c) => + GroupParams crypto c => Monad m => RandomGen r => Functor list => E crypto c -> list (G crypto c) -> @@ -267,10 +258,8 @@ prove sec commitmentBases oracle = do -- | Like 'prove' but quicker. It chould replace 'prove' entirely -- when Helios-C specifications will be fixed. proveQuicker :: - Reifies c crypto => Reifies v Version => - Group crypto => - Multiplicative (G crypto c) => + GroupParams crypto c => Monad m => RandomGen r => Functor list => E crypto c -> list (G crypto c) -> @@ -294,8 +283,7 @@ proveQuicker sec commitmentBases oracle = do -- Used in 'proveEncryption' to fill the returned 'DisjProof' -- with fake 'Proof's for all 'Disjunction's but the encrypted one. fakeProof :: - Reifies c crypto => - Group crypto => + GroupParams crypto c => Monad m => RandomGen r => S.StateT r m (Proof crypto v c) fakeProof = do @@ -314,10 +302,7 @@ type Commitment = G commit :: forall crypto v c. Reifies v Version => - Reifies c crypto => - Group crypto => - Multiplicative (G crypto c) => - Invertible (G crypto c) => + GroupParams crypto c => Proof crypto v c -> G crypto c -> G crypto c -> @@ -339,9 +324,7 @@ commit Proof{..} base basePowSec = -- | Like 'commit' but quicker. It chould replace 'commit' entirely -- when Helios-C specifications will be fixed. commitQuicker :: - Reifies c crypto => - Group crypto => - Multiplicative (G crypto c) => + GroupParams crypto c => Proof crypto v c -> G crypto c -> G crypto c -> @@ -358,17 +341,13 @@ type Disjunction = G booleanDisjunctions :: forall crypto c. - Reifies c crypto => - Group crypto => - Invertible (G crypto c) => + GroupParams crypto c => [Disjunction crypto c] booleanDisjunctions = List.take 2 $ groupGenInverses @crypto intervalDisjunctions :: forall crypto c. - Reifies c crypto => - Group crypto => - Invertible (G crypto c) => + GroupParams crypto c => Natural -> Natural -> [Disjunction crypto c] intervalDisjunctions mini maxi = List.genericTake (fromJust $ (nat maxi + 1)`minusNaturalMaybe`nat mini) $ @@ -400,11 +379,7 @@ newtype DisjProof crypto v c = DisjProof [Proof crypto v c] -- DOC: Pierrick Gaudry. , 2017. proveEncryption :: Reifies v Version => - Reifies c crypto => - Group crypto => - ToNatural (G crypto c) => - Multiplicative (G crypto c) => - Invertible (G crypto c) => + GroupParams crypto c => Monad m => RandomGen r => PublicKey crypto c -> ZKP -> ([Disjunction crypto c],[Disjunction crypto c]) -> @@ -434,11 +409,7 @@ proveEncryption elecPubKey voterZKP (prevDisjs,nextDisjs) (encNonce,enc) = do verifyEncryption :: Reifies v Version => - Reifies c crypto => - Group crypto => - ToNatural (G crypto c) => - Multiplicative (G crypto c) => - Invertible (G crypto c) => + GroupParams crypto c => Monad m => PublicKey crypto c -> ZKP -> [Disjunction crypto c] -> (Encryption crypto v c, DisjProof crypto v c) -> @@ -457,8 +428,7 @@ verifyEncryption elecPubKey voterZKP disjs (enc, DisjProof proofs) = -- ** Hashing encryptionStatement :: - Reifies c crypto => - ToNatural (G crypto c) => + GroupParams crypto c => ZKP -> Encryption crypto v c -> BS.ByteString encryptionStatement (ZKP voterZKP) Encryption{..} = "prove|"<>voterZKP<>"|" @@ -472,9 +442,7 @@ encryptionStatement (ZKP voterZKP) Encryption{..} = -- and for the verifier the 'Proof' comes from the prover. encryptionCommitments :: Reifies v Version => - Reifies c crypto => - Group crypto => - Invertible (G crypto c) => + GroupParams crypto c => PublicKey crypto c -> Encryption crypto v c -> Disjunction crypto c -> Proof crypto v c -> [G crypto c] encryptionCommitments elecPubKey Encryption{..} disj proof = @@ -541,9 +509,7 @@ deriving instance (Show (G crypto c), Show (G crypto c)) => Show (Answer crypto deriving instance NFData (G crypto c) => NFData (Answer crypto v c) instance ( Reifies v Version - , Reifies c crypto - , ToJSON (G crypto c) - , Group crypto + , GroupParams crypto c ) => ToJSON (Answer crypto v c) where toJSON Answer{..} = let (answer_choices, answer_individual_proofs) = @@ -563,9 +529,7 @@ instance ) instance ( Reifies v Version - , Reifies c crypto - , FromJSON (G crypto c) - , Group crypto + , GroupParams crypto c ) => FromJSON (Answer crypto v c) where parseJSON = JSON.withObject "Answer" $ \o -> do answer_choices <- o .: "choices" @@ -579,7 +543,7 @@ instance -- unless an 'ErrorAnswer' is returned. encryptAnswer :: Reifies v Version => - Reifies c crypto => Group crypto => + GroupParams crypto c => Monad m => RandomGen r => PublicKey crypto c -> ZKP -> Question v -> [Bool] -> @@ -593,7 +557,7 @@ encryptAnswer (elecPubKey::PublicKey crypto c) zkp Question{..} opinionByChoice ErrorAnswer_WrongNumberOfOpinions (fromIntegral $ List.length opinions) (fromIntegral $ List.length question_choices) - | otherwise = groupReify (Proxy @c) $ do + | otherwise = do encryptions <- encrypt elecPubKey `mapM` opinions individualProofs <- zipWithM (\opinion -> proveEncryption elecPubKey zkp $ @@ -620,12 +584,12 @@ encryptAnswer (elecPubKey::PublicKey crypto c) zkp Question{..} opinionByChoice verifyAnswer :: Reifies v Version => - Reifies c crypto => Group crypto => + GroupParams crypto c => PublicKey crypto c -> ZKP -> Question v -> Answer crypto v c -> Bool verifyAnswer (elecPubKey::PublicKey crypto c) zkp Question{..} Answer{..} | List.length question_choices /= List.length answer_opinions = False - | otherwise = groupReify (Proxy @c) $ do + | otherwise = do either (const False) id $ runExcept $ do validOpinions <- verifyEncryption elecPubKey zkp booleanDisjunctions @@ -662,10 +626,9 @@ deriving instance (Eq crypto, Eq (G crypto c)) => Eq (Election crypto v c) deriving instance (Show crypto, Show (G crypto c)) => Show (Election crypto v c) deriving instance (NFData crypto, NFData (G crypto c)) => NFData (Election crypto v c) instance - ( ToJSON crypto - , ToJSON (G crypto c) - , Reifies v Version - , Reifies c crypto + ( Reifies v Version + , GroupParams crypto c + , ToJSON crypto ) => ToJSON (Election crypto v c) where toJSON Election{..} = JSON.object $ @@ -692,15 +655,22 @@ instance ) <> maybe mempty ("version" .=) election_version +hashElection :: + Reifies v Version => + GroupParams crypto c => + ToJSON crypto => + Election crypto v c -> Base64SHA256 +hashElection = base64SHA256 . BSL.toStrict . JSON.encode + readElection :: + forall crypto r. FromJSON crypto => - Group crypto => + ReifyCrypto crypto => FilePath -> (forall v c. - Reifies v Version => - Reifies c crypto => - GroupDict crypto c => - Election crypto v c -> r) -> + Reifies v Version => + GroupParams crypto c => + Election crypto v c -> r) -> ExceptT String IO r readElection filePath k = do fileData <- lift $ BS.readFile filePath @@ -720,7 +690,7 @@ readElection filePath k = do pubKey :: JSON.Value <- obj .: "y" return (crypto, pubKey) ) o "public_key" - reify election_crypto $ \(c::Proxy c) -> groupReify c $ do + reifyCrypto election_crypto $ \(_c::Proxy c) -> do election_name <- o .: "name" election_description <- o .: "description" election_questions <- o .: "questions" :: JSON.Parser [Question v] @@ -733,14 +703,6 @@ readElection filePath k = do , .. } -hashElection :: - ToJSON crypto => - Reifies c crypto => - Reifies v Version => - ToJSON (G crypto c) => - Election crypto v c -> Base64SHA256 -hashElection = base64SHA256 . BSL.toStrict . JSON.encode - -- * Type 'Ballot' data Ballot crypto v c = Ballot { ballot_answers :: ![Answer crypto v c] @@ -751,8 +713,7 @@ data Ballot crypto v c = Ballot deriving instance (NFData (G crypto c), NFData crypto) => NFData (Ballot crypto v c) instance ( Reifies v Version - , Reifies c crypto - , Group crypto + , GroupParams crypto c , ToJSON (G crypto c) ) => ToJSON (Ballot crypto v c) where toJSON Ballot{..} = @@ -771,9 +732,7 @@ instance maybe mempty ("signature" .=) ballot_signature instance ( Reifies v Version - , Reifies c crypto - , Group crypto - , FromJSON (G crypto c) + , GroupParams crypto c ) => FromJSON (Ballot crypto v c) where parseJSON = JSON.withObject "Ballot" $ \o -> do ballot_answers <- o .: "answers" @@ -788,7 +747,7 @@ instance -- on each 'question_choices' of each 'election_questions'. encryptBallot :: Reifies v Version => - Reifies c crypto => Group crypto => Key crypto => + GroupParams crypto c => Key crypto => Monad m => RandomGen r => Election crypto v c -> Maybe (SecretKey crypto c) -> [[Bool]] -> @@ -799,7 +758,7 @@ encryptBallot (Election{..}::Election crypto v c) ballotSecKeyMay opinionsByQues ErrorBallot_WrongNumberOfAnswers (fromIntegral $ List.length opinionsByQuest) (fromIntegral $ List.length election_questions) - | otherwise = groupReify (Proxy @c) $ do + | otherwise = do let (voterKeys, voterZKP) = case ballotSecKeyMay of Nothing -> (Nothing, ZKP "") @@ -817,12 +776,12 @@ encryptBallot (Election{..}::Election crypto v c) ballotSecKeyMay opinionsByQues signature_proof <- proveQuicker ballotSecKey (Identity groupGen) $ \(Identity commitment) -> - hash @_ @crypto + hash @crypto -- 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 @_ @crypto voterZKP commitment) - (signatureStatement @_ @crypto ballot_answers) + (signatureCommitments @crypto voterZKP commitment) + (signatureStatement @crypto ballot_answers) return $ Just Signature{..} return Ballot { ballot_answers @@ -833,10 +792,10 @@ encryptBallot (Election{..}::Election crypto v c) ballotSecKeyMay opinionsByQues verifyBallot :: Reifies v Version => - Reifies c crypto => Group crypto => + GroupParams crypto c => Election crypto v c -> Ballot crypto v c -> Bool -verifyBallot (Election{..}::Election crypto v c) Ballot{..} = groupReify (Proxy @c) $ +verifyBallot (Election{..}::Election crypto v c) Ballot{..} = ballot_election_uuid == election_uuid && ballot_election_hash == election_hash && List.length election_questions == List.length ballot_answers && @@ -847,8 +806,8 @@ verifyBallot (Election{..}::Election crypto v c) Ballot{..} = groupReify (Proxy let zkp = ZKP (bytesNat signature_publicKey) in (, zkp) $ proof_challenge signature_proof == hash - (signatureCommitments @_ @crypto zkp (commitQuicker signature_proof groupGen signature_publicKey)) - (signatureStatement @_ @crypto ballot_answers) + (signatureCommitments @crypto zkp (commitQuicker signature_proof groupGen signature_publicKey)) + (signatureStatement @crypto ballot_answers) in and $ isValidSign : List.zipWith (verifyAnswer election_public_key zkpSign) @@ -867,9 +826,8 @@ data Signature crypto v c = Signature } deriving (Generic) deriving instance (NFData crypto, NFData (G crypto c)) => NFData (Signature crypto v c) instance - ( Reifies c crypto - , Reifies v Version - , ToJSON (G crypto c) + ( Reifies v Version + , GroupParams crypto c ) => ToJSON (Signature crypto v c) where toJSON (Signature pubKey Proof{..}) = JSON.object @@ -884,10 +842,8 @@ instance <> "response" .= proof_response ) instance - ( Reifies c crypto - , Reifies v Version - , Group crypto - , FromJSON (PublicKey crypto c) + ( Reifies v Version + , GroupParams crypto c ) => FromJSON (Signature crypto v c) where parseJSON = JSON.withObject "Signature" $ \o -> do signature_publicKey <- o .: "public_key" @@ -901,7 +857,7 @@ instance -- | @('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 crypto => Foldable f => f (Answer crypto v c) -> [G crypto c] +signatureStatement :: GroupParams crypto c => Foldable f => f (Answer crypto v c) -> [G crypto c] signatureStatement = foldMap $ \Answer{..} -> (`foldMap` answer_opinions) $ \(Encryption{..}, _proof) -> @@ -909,7 +865,7 @@ signatureStatement = -- | @('signatureCommitments' voterZKP commitment)@ signatureCommitments :: - Reifies c crypto => + GroupParams crypto c => ToNatural (G crypto c) => ZKP -> Commitment crypto c -> BS.ByteString signatureCommitments (ZKP voterZKP) commitment = diff --git a/hjugement-protocol/src/Voting/Protocol/FFC.hs b/hjugement-protocol/src/Voting/Protocol/FFC.hs index e4d6ddd..f61a7ad 100644 --- a/hjugement-protocol/src/Voting/Protocol/FFC.hs +++ b/hjugement-protocol/src/Voting/Protocol/FFC.hs @@ -24,7 +24,7 @@ import Data.Maybe (Maybe(..), fromMaybe, fromJust) import Data.Monoid (Monoid(..)) import Data.Ord (Ord(..)) import Data.Proxy (Proxy(..)) -import Data.Reflection (Reifies(..)) +import Data.Reflection (Reifies(..), reify) import Data.Semigroup (Semigroup(..)) import Data.Text (Text) import GHC.Generics (Generic) @@ -116,13 +116,11 @@ instance FromJSON FFC where unless (fromJust (ffc_fieldCharac`minusNaturalMaybe`one) `rem` ffc_groupOrder == 0) $ JSON.typeMismatch "FFC: groupOrder does not divide fieldCharac-1" (JSON.Object o) return FFC{..} -instance Group FFC where - groupGen :: forall c. Reifies c FFC => G FFC c +instance Reifies c FFC => GroupParams FFC c where groupGen = G $ ffc_groupGen $ reflect (Proxy::Proxy c) - groupOrder :: forall c. Reifies c FFC => Proxy c -> Natural groupOrder c = ffc_groupOrder $ reflect c - -- groupDict Proxy = Dict - groupReify c k = k +instance ReifyCrypto FFC where + reifyCrypto = reify instance Key FFC where cryptoType _ = "FFC" cryptoName = ffc_name diff --git a/hjugement-protocol/src/Voting/Protocol/Tally.hs b/hjugement-protocol/src/Voting/Protocol/Tally.hs index 172f831..10fdf3e 100644 --- a/hjugement-protocol/src/Voting/Protocol/Tally.hs +++ b/hjugement-protocol/src/Voting/Protocol/Tally.hs @@ -14,7 +14,6 @@ import Data.Function (($), (.)) import Data.Functor ((<$>)) import Data.Maybe (maybe) import Data.Semigroup (Semigroup(..)) -import Data.Ord (Ord(..)) import Data.Reflection (Reifies(..)) import Data.Tuple (fst, snd) import GHC.Generics (Generic) @@ -55,9 +54,7 @@ deriving instance (Show (G crypto c), Show (G crypto c)) => Show (Tally crypto v deriving instance NFData (G crypto c) => NFData (Tally crypto v c) instance ( Reifies v Version - , Reifies c crypto - , Group crypto - , ToJSON (G crypto c) + , GroupParams crypto c ) => ToJSON (Tally crypto v c) where toJSON Tally{..} = JSON.object @@ -75,9 +72,7 @@ instance ) instance ( Reifies v Version - , Reifies c crypto - , Group crypto - , FromJSON (G crypto c) + , GroupParams crypto c ) => FromJSON (Tally crypto v c) where parseJSON = JSON.withObject "Tally" $ \o -> do tally_countMax <- o .: "num_tallied" @@ -94,17 +89,13 @@ type EncryptedTally crypto v c = [[Encryption crypto v c]] -- returns the sum of the 'Encryption's of the given @ballots@, -- along with the number of 'Ballot's. encryptedTally :: - Reifies c crypto => - Multiplicative (G crypto c) => - Invertible (G crypto c) => + GroupParams crypto c => [Ballot crypto v c] -> (EncryptedTally crypto v c, Natural) encryptedTally = List.foldr insertEncryptedTally emptyEncryptedTally -- | The initial 'EncryptedTally' which tallies no 'Ballot'. emptyEncryptedTally :: - Reifies c crypto => - Multiplicative (G crypto c) => - Invertible (G crypto c) => + GroupParams crypto c => (EncryptedTally crypto v c, Natural) emptyEncryptedTally = (List.repeat (List.repeat zero), 0) @@ -112,10 +103,10 @@ emptyEncryptedTally = (List.repeat (List.repeat zero), 0) -- returns the 'EncryptedTally' adding the votes of the given @(ballot)@ -- to those of the given @(encTally)@. insertEncryptedTally :: - Reifies c crypto => - Multiplicative (G crypto c) => - Invertible (G crypto c) => - Ballot crypto v c -> (EncryptedTally crypto v c, Natural) -> (EncryptedTally crypto v c, Natural) + GroupParams crypto c => + Ballot crypto v c -> + (EncryptedTally crypto v c, Natural) -> + (EncryptedTally crypto v c, Natural) insertEncryptedTally Ballot{..} (encTally, numBallots) = ( List.zipWith (\Answer{..} -> List.zipWith (+) (fst <$> answer_opinions)) @@ -131,14 +122,9 @@ type DecryptionShareCombinator crypto v c = Except ErrorTally [[DecryptionFactor crypto c]] proveTally :: - Reifies c crypto => - Group crypto => - Multiplicative (G crypto c) => - Invertible (G crypto c) => - Ord (G crypto c) => + GroupParams crypto c => (EncryptedTally crypto v c, Natural) -> [DecryptionShare crypto v c] -> - DecryptionShareCombinator crypto v c -> - Except ErrorTally (Tally crypto v c) + DecryptionShareCombinator crypto v c -> Except ErrorTally (Tally crypto v c) proveTally (tally_encByChoiceByQuest, tally_countMax) tally_decShareByTrustee @@ -160,11 +146,7 @@ proveTally return Tally{..} verifyTally :: - Reifies c crypto => - Group crypto => - Multiplicative (G crypto c) => - Invertible (G crypto c) => - Eq (G crypto c) => + GroupParams crypto c => Tally crypto v c -> DecryptionShareCombinator crypto v c -> Except ErrorTally () @@ -189,10 +171,7 @@ newtype DecryptionShare crypto v c = DecryptionShare deriving instance Eq (G crypto c) => Eq (DecryptionShare crypto v c) deriving instance Show (G crypto c) => Show (DecryptionShare crypto v c) deriving newtype instance NFData (G crypto c) => NFData (DecryptionShare crypto v c) -instance - ( Group crypto - , ToJSON (G crypto c) - ) => ToJSON (DecryptionShare crypto v c) where +instance ToJSON (G crypto c) => ToJSON (DecryptionShare crypto v c) where toJSON (DecryptionShare decByChoiceByQuest) = JSON.object [ "decryption_factors" .= @@ -206,11 +185,7 @@ instance (JSON.list (JSON.list (toEncoding . fst)) decByChoiceByQuest) <> JSON.pair "decryption_proofs" (JSON.list (JSON.list (toEncoding . snd)) decByChoiceByQuest) -instance - ( Reifies c crypto - , Group crypto - , FromJSON (G crypto c) - ) => FromJSON (DecryptionShare crypto v c) where +instance GroupParams crypto c => FromJSON (DecryptionShare crypto v c) where parseJSON = JSON.withObject "DecryptionShare" $ \o -> do decFactors <- o .: "decryption_factors" decProofs <- o .: "decryption_proofs" @@ -228,12 +203,8 @@ type DecryptionFactor = G -- @('proveDecryptionShare' encByChoiceByQuest trusteeSecKey)@ proveDecryptionShare :: Reifies v Version => - Reifies c crypto => - Group crypto => - Multiplicative (G crypto c) => - Invertible (G crypto c) => + GroupParams crypto c => Key crypto => - ToNatural (G crypto c) => Monad m => RandomGen r => EncryptedTally crypto v c -> SecretKey crypto c -> S.StateT r m (DecryptionShare crypto v c) proveDecryptionShare encByChoiceByQuest trusteeSecKey = @@ -242,12 +213,8 @@ proveDecryptionShare encByChoiceByQuest trusteeSecKey = proveDecryptionFactor :: Reifies v Version => - Reifies c crypto => - Group crypto => - Multiplicative (G crypto c) => - Invertible (G crypto c) => + GroupParams crypto c => Key crypto => - ToNatural (G crypto c) => Monad m => RandomGen r => SecretKey crypto c -> Encryption crypto v c -> S.StateT r m (DecryptionFactor crypto c, Proof crypto v c) proveDecryptionFactor trusteeSecKey Encryption{..} = do @@ -255,10 +222,7 @@ proveDecryptionFactor trusteeSecKey Encryption{..} = do return (encryption_nonce^trusteeSecKey, proof) where zkp = decryptionShareStatement (publicKey trusteeSecKey) -decryptionShareStatement :: - Reifies c crypto => - ToNatural (G crypto c) => - PublicKey crypto c -> BS.ByteString +decryptionShareStatement :: GroupParams crypto c => PublicKey crypto c -> BS.ByteString decryptionShareStatement pubKey = "decrypt|"<>bytesNat pubKey<>"|" @@ -284,11 +248,7 @@ data ErrorTally -- is valid with respect to the 'EncryptedTally' 'encTally'. verifyDecryptionShare :: Reifies v Version => - Reifies c crypto => - Group crypto => - Multiplicative (G crypto c) => - Invertible (G crypto c) => - ToNatural (G crypto c) => + GroupParams crypto c => Monad m => EncryptedTally crypto v c -> PublicKey crypto c -> DecryptionShare crypto v c -> ExceptT ErrorTally m () @@ -306,11 +266,7 @@ verifyDecryptionShare encByChoiceByQuest trusteePubKey (DecryptionShare decShare verifyDecryptionShareByTrustee :: Reifies v Version => - Reifies c crypto => - Group crypto => - Multiplicative (G crypto c) => - Invertible (G crypto c) => - ToNatural (G crypto c) => + GroupParams crypto c => Monad m => EncryptedTally crypto v c -> [PublicKey crypto c] -> [DecryptionShare crypto v c] -> ExceptT ErrorTally m () diff --git a/hjugement-protocol/src/Voting/Protocol/Trustee/Indispensable.hs b/hjugement-protocol/src/Voting/Protocol/Trustee/Indispensable.hs index 3c26f98..7abc903 100644 --- a/hjugement-protocol/src/Voting/Protocol/Trustee/Indispensable.hs +++ b/hjugement-protocol/src/Voting/Protocol/Trustee/Indispensable.hs @@ -50,10 +50,7 @@ data TrusteePublicKey crypto v c = TrusteePublicKey deriving instance Eq (G crypto c) => Eq (TrusteePublicKey crypto v c) deriving instance (Show (G crypto c), Show (PublicKey crypto c)) => Show (TrusteePublicKey crypto v c) deriving instance NFData (G crypto c) => NFData (TrusteePublicKey crypto v c) -instance - ( Group crypto - , ToJSON (G crypto c) - ) => ToJSON (TrusteePublicKey crypto v c) where +instance ToJSON (G crypto c) => ToJSON (TrusteePublicKey crypto v c) where toJSON TrusteePublicKey{..} = JSON.object [ "pok" .= trustee_SecretKeyProof @@ -64,11 +61,7 @@ instance ( "pok" .= trustee_SecretKeyProof <> "public_key" .= trustee_PublicKey ) -instance - ( Reifies c crypto - , Group crypto - , FromJSON (PublicKey crypto c) - ) => FromJSON (TrusteePublicKey crypto v c) where +instance GroupParams crypto c => FromJSON (TrusteePublicKey crypto v c) where parseJSON = JSON.withObject "TrusteePublicKey" $ \o -> do trustee_PublicKey <- o .: "public_key" trustee_SecretKeyProof <- o .: "pok" @@ -81,12 +74,8 @@ instance -- and a 'Proof' of its knowledge. proveIndispensableTrusteePublicKey :: Reifies v Version => - Reifies c crypto => - Group crypto => + GroupParams crypto c => Key crypto => - Multiplicative (G crypto c) => - Invertible (G crypto c) => - ToNatural (G crypto c) => Monad m => RandomGen r => SecretKey crypto c -> S.StateT r m (TrusteePublicKey crypto v c) proveIndispensableTrusteePublicKey trustSecKey = do @@ -104,11 +93,7 @@ proveIndispensableTrusteePublicKey trustSecKey = do -- the given 'trustee_PublicKey' is known by the trustee. verifyIndispensableTrusteePublicKey :: Reifies v Version => - Reifies c crypto => - Group crypto => - Multiplicative (G crypto c) => - Invertible (G crypto c) => - ToNatural (G crypto c) => + GroupParams crypto c => Monad m => TrusteePublicKey crypto v c -> ExceptT ErrorTrusteePublicKey m () @@ -128,8 +113,7 @@ data ErrorTrusteePublicKey -- ** Hashing indispensableTrusteePublicKeyStatement :: - Reifies c crypto => - ToNatural (G crypto c) => + GroupParams crypto c => PublicKey crypto c -> BS.ByteString indispensableTrusteePublicKeyStatement trustPubKey = "pok|"<>bytesNat trustPubKey<>"|" @@ -139,10 +123,7 @@ indispensableTrusteePublicKeyStatement trustPubKey = -- ** Generating an 'Election''s 'PublicKey' from multiple 'TrusteePublicKey's. combineIndispensableTrusteePublicKeys :: - Reifies c crypto => - Multiplicative (G crypto c) => - Invertible (G crypto c) => - ToNatural (G crypto c) => + GroupParams crypto c => [TrusteePublicKey crypto v c] -> PublicKey crypto c combineIndispensableTrusteePublicKeys = List.foldr (\TrusteePublicKey{..} -> (trustee_PublicKey *)) one @@ -151,11 +132,7 @@ combineIndispensableTrusteePublicKeys = verifyIndispensableDecryptionShareByTrustee :: Reifies v Version => - Reifies c crypto => - Group crypto => - Multiplicative (G crypto c) => - Invertible (G crypto c) => - ToNatural (G crypto c) => + GroupParams crypto c => Monad m => EncryptedTally crypto v c -> [PublicKey crypto c] -> [DecryptionShare crypto v c] -> ExceptT ErrorTally m () @@ -169,11 +146,7 @@ verifyIndispensableDecryptionShareByTrustee encByChoiceByQuest = -- returns the 'DecryptionFactor's by choice by 'Question' combineIndispensableDecryptionShares :: Reifies v Version => - Reifies c crypto => - Group crypto => - Multiplicative (G crypto c) => - Invertible (G crypto c) => - ToNatural (G crypto c) => + GroupParams crypto c => [PublicKey crypto c] -> DecryptionShareCombinator crypto v c combineIndispensableDecryptionShares pubKeyByTrustee diff --git a/hjugement-protocol/tests/HUnit/Credential.hs b/hjugement-protocol/tests/HUnit/Credential.hs index f899e79..08ccbb5 100644 --- a/hjugement-protocol/tests/HUnit/Credential.hs +++ b/hjugement-protocol/tests/HUnit/Credential.hs @@ -35,7 +35,7 @@ hunit _v = testGroup "Credential" , "xLcs7ev6Jy6FHHE" ==> Right (Credential "xLcs7ev6Jy6FHHE") ] , testGroup "credentialSecretKey" $ - [ reify beleniosFFC $ testSecretKey + [ testSecretKey beleniosFFC (UUID "xLcs7ev6Jy6FHH") (Credential "xLcs7ev6Jy6FHHE") 24202898752499029126606335829564687069186982035759723128887013101942425902424 @@ -43,9 +43,9 @@ hunit _v = testGroup "Credential" ] testSecretKey :: - Reifies c crypto => Group crypto => Key crypto => - UUID -> Credential -> Natural -> - Proxy c -> TestTree -testSecretKey uuid cred exp (c::Proxy c) = groupReify c $ - testCase (show (uuid,cred)) $ - credentialSecretKey @_ @c uuid cred @?= E exp + ReifyCrypto crypto => Key crypto => + crypto -> UUID -> Credential -> Natural -> TestTree +testSecretKey crypto uuid cred exp = + reifyCrypto crypto $ \(_c::Proxy c) -> + testCase (show (uuid,cred)) $ + credentialSecretKey @_ @c uuid cred @?= E exp diff --git a/hjugement-protocol/tests/HUnit/Election.hs b/hjugement-protocol/tests/HUnit/Election.hs index 2f34b36..ea1fbed 100644 --- a/hjugement-protocol/tests/HUnit/Election.hs +++ b/hjugement-protocol/tests/HUnit/Election.hs @@ -32,9 +32,9 @@ hunit v = testGroup "Election" $ ] hunitsEncryptBallot :: - Group crypto => Key crypto => JSON.ToJSON crypto => - Reifies v Version => Proxy v -> - crypto -> TestTree + Reifies v Version => + ReifyCrypto crypto => Key crypto => JSON.ToJSON crypto => + Proxy v -> crypto -> TestTree hunitsEncryptBallot v crypto = testGroup (Text.unpack $ cryptoName crypto) [ hunitEncryptBallot v crypto 0 @@ -79,14 +79,13 @@ hunitsEncryptBallot v crypto = ] hunitEncryptBallot :: - Group crypto => Key crypto => JSON.ToJSON crypto => - Reifies v Version => Proxy v -> - crypto -> Int -> [Question v] -> [[Bool]] -> - Either ErrorBallot Bool -> - TestTree + Reifies v Version => + ReifyCrypto crypto => Key crypto => JSON.ToJSON crypto => + Proxy v -> crypto -> Int -> [Question v] -> [[Bool]] -> + Either ErrorBallot Bool -> TestTree hunitEncryptBallot v election_crypto seed election_questions opins exp = let got = - reify election_crypto $ \(c::Proxy c) -> groupReify c $ + reifyCrypto election_crypto $ \(_c::Proxy c) -> runExcept $ (`evalStateT` Random.mkStdGen seed) $ do election_uuid <- randomUUID diff --git a/hjugement-protocol/tests/HUnit/FFC.hs b/hjugement-protocol/tests/HUnit/FFC.hs index a687231..a0d2972 100644 --- a/hjugement-protocol/tests/HUnit/FFC.hs +++ b/hjugement-protocol/tests/HUnit/FFC.hs @@ -38,12 +38,12 @@ hunit _v = testGroup "FFC" hunitInv :: forall crypto. - Group crypto => Key crypto => + ReifyCrypto crypto => Key crypto => crypto -> TestTree hunitInv crypto = testGroup (Text.unpack $ cryptoName crypto) [ testCase "groupGen" $ - reify crypto $ \(c::Proxy c) -> groupReify c $ + reifyCrypto crypto $ \(_c::Proxy c) -> inv (groupGen :: G crypto c) @?= groupGen ^ E (fromJust $ groupOrder (Proxy @c) `minusNaturalMaybe` one) ] diff --git a/hjugement-protocol/tests/HUnit/Trustee/Indispensable.hs b/hjugement-protocol/tests/HUnit/Trustee/Indispensable.hs index 7fe3b25..07e7052 100644 --- a/hjugement-protocol/tests/HUnit/Trustee/Indispensable.hs +++ b/hjugement-protocol/tests/HUnit/Trustee/Indispensable.hs @@ -24,9 +24,9 @@ hunit v = testGroup "Indispensable" $ ] testsVerifyIndispensableTrusteePublicKey :: - Group crypto => Key crypto => - Reifies v Version => Proxy v -> - crypto -> TestTree + Reifies v Version => + ReifyCrypto crypto => Key crypto => + Proxy v -> crypto -> TestTree testsVerifyIndispensableTrusteePublicKey v crypto = testGroup (Text.unpack $ cryptoName crypto) [ testVerifyIndispensableTrusteePublicKey v crypto 0 (Right ()) @@ -34,11 +34,11 @@ testsVerifyIndispensableTrusteePublicKey v crypto = testVerifyIndispensableTrusteePublicKey :: forall crypto v. - Group crypto => Key crypto => + ReifyCrypto crypto => Key crypto => Reifies v Version => Proxy v -> crypto -> Int -> Either ErrorTrusteePublicKey () -> TestTree testVerifyIndispensableTrusteePublicKey (_v::Proxy v) crypto seed exp = - reify crypto $ \(c::Proxy c) -> groupReify c $ + reifyCrypto crypto $ \(_c::Proxy c) -> let got = runExcept $ (`evalStateT` Random.mkStdGen seed) $ do @@ -50,7 +50,7 @@ testVerifyIndispensableTrusteePublicKey (_v::Proxy v) crypto seed exp = got @?= exp testsVerifyTally :: - Group crypto => Key crypto => + ReifyCrypto crypto => Key crypto => Reifies v Version => Proxy v -> crypto -> TestTree testsVerifyTally v crypto = @@ -63,13 +63,13 @@ testsVerifyTally v crypto = ] testVerifyTally :: - Group crypto => Key crypto => - Reifies v Version => Proxy v -> - crypto -> Int -> Natural -> Natural -> Natural -> TestTree + Reifies v Version => + ReifyCrypto crypto => Key crypto => + Proxy v -> crypto -> Int -> Natural -> Natural -> Natural -> TestTree testVerifyTally (_v::Proxy v) crypto seed nTrustees nQuests nChoices = let clearTallyResult = dummyTallyResult nQuests nChoices in let decryptedTallyResult :: Either ErrorTally [[Natural]] = - reify crypto $ \(c::Proxy c) -> groupReify c $ + reifyCrypto crypto $ \(_c::Proxy c) -> runExcept $ (`evalStateT` Random.mkStdGen seed) $ do secKeyByTrustee :: [SecretKey crypto c] <- @@ -107,10 +107,7 @@ dummyTallyResult nQuests nChoices = encryptTallyResult :: Reifies v Version => - Reifies c crypto => - Group crypto => - Multiplicative (G crypto c) => - Invertible (G crypto c) => + GroupParams crypto c => Monad m => RandomGen r => PublicKey crypto c -> [[Natural]] -> StateT r m (EncryptedTally crypto v c, Natural) encryptTallyResult pubKey countByChoiceByQuest = diff --git a/hjugement-protocol/tests/QuickCheck/Election.hs b/hjugement-protocol/tests/QuickCheck/Election.hs index 9502974..c0f8606 100644 --- a/hjugement-protocol/tests/QuickCheck/Election.hs +++ b/hjugement-protocol/tests/QuickCheck/Election.hs @@ -34,10 +34,11 @@ quickcheck v = ] quickcheckElection :: - Reifies c crypto => Group crypto => Key crypto => JSON.ToJSON crypto => Show crypto => - Reifies v Version => Proxy v -> - Proxy c -> TestTree -quickcheckElection (_v::Proxy v) (c::Proxy c) = groupReify c $ + Reifies v Version => + GroupParams crypto c => + Key crypto => JSON.ToJSON crypto => Show crypto => + Proxy v -> Proxy c -> TestTree +quickcheckElection (_v::Proxy v) (c::Proxy c) = testGroup (Text.unpack $ cryptoName (reflect c)) [ testProperty "verifyBallot" $ \(seed, (elec::Election crypto v c) :> votes) -> isRight $ runExcept $ @@ -52,19 +53,11 @@ quickcheckElection (_v::Proxy v) (c::Proxy c) = groupReify c $ instance Reifies c FFC => Arbitrary (F c) where arbitrary = F <$> choose (zero, fromJust $ fieldCharac @c `minusNaturalMaybe` one) -} -instance - ( Reifies c crypto - , Group crypto - , Multiplicative (G crypto c) - , Invertible (G crypto c) - ) => Arbitrary (G crypto c) where +instance GroupParams crypto c => Arbitrary (G crypto c) where arbitrary = do m <- arbitrary return (groupGen ^ m) -instance - ( Reifies c crypto - , Group crypto - ) => Arbitrary (E crypto c) where +instance GroupParams crypto c => Arbitrary (E crypto c) where arbitrary = E <$> choose (zero, fromJust $ groupOrder @crypto (Proxy @c) `minusNaturalMaybe` one) instance Arbitrary UUID where arbitrary = do @@ -73,7 +66,7 @@ instance Arbitrary UUID where randomUUID instance ( Reifies v Version - , Reifies c crypto + , GroupParams crypto c , Arbitrary (E crypto c) ) => Arbitrary (Proof crypto v c) where arbitrary = do @@ -97,13 +90,9 @@ instance Reifies v Version => Arbitrary (Question v) where ] instance ( Reifies v Version - , Reifies c crypto - , Group crypto + , GroupParams crypto c , Key crypto - , Multiplicative (G crypto c) - , Invertible (G crypto c) , JSON.ToJSON crypto - , JSON.ToJSON (G crypto c) ) => Arbitrary (Election crypto v c) where arbitrary = do let election_name = "election" @@ -149,12 +138,11 @@ instance Reifies v Version => Arbitrary (Question v :> [Bool]) where ] instance ( Reifies v Version - , Reifies c crypto - , Group crypto + , GroupParams crypto c , Key crypto , JSON.ToJSON crypto ) => Arbitrary (Election crypto v c :> [[Bool]]) where - arbitrary = groupReify (Proxy @c) $ do + arbitrary = do elec@Election{..} <- arbitrary votes <- forM election_questions $ \Question{..} -> do let numChoices = List.length question_choices @@ -162,7 +150,7 @@ instance rank <- choose (0, nCk numChoices numTrue - 1) return $ boolsOfCombin numChoices numTrue rank return (elec :> votes) - shrink (elec :> votes) = groupReify (Proxy @c) $ + shrink (elec :> votes) = [ e :> List.zipWith shrinkVotes (election_questions e :: [Question v]) votes | e <- shrink elec ] diff --git a/hjugement-protocol/tests/QuickCheck/Trustee.hs b/hjugement-protocol/tests/QuickCheck/Trustee.hs index d7b2124..b6673e4 100644 --- a/hjugement-protocol/tests/QuickCheck/Trustee.hs +++ b/hjugement-protocol/tests/QuickCheck/Trustee.hs @@ -22,9 +22,10 @@ quickcheck v = testIndispensableTrusteePublicKey :: Reifies v Version => - Reifies c crypto => Group crypto => Key crypto => + GroupParams crypto c => + Key crypto => Proxy v -> Proxy c -> TestTree -testIndispensableTrusteePublicKey (_v::Proxy v) (c::Proxy c) = groupReify c $ +testIndispensableTrusteePublicKey (_v::Proxy v) (c::Proxy c) = testGroup (Text.unpack $ cryptoName (reflect c)) [ testProperty "Right" $ \seed -> isRight $ runExcept $ @@ -37,10 +38,7 @@ testIndispensableTrusteePublicKey (_v::Proxy v) (c::Proxy c) = groupReify c $ instance ( Reifies v Version - , Reifies c crypto - , Group crypto - , Multiplicative (G crypto c) - , Invertible (G crypto c) + , GroupParams crypto c ) => Arbitrary (TrusteePublicKey crypto v c) where arbitrary = do trustee_PublicKey <- arbitrary -- 2.44.1