hjugement-protocol-0.0.8.20191027: benchmarks/Election.hs

{-# 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 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"
	elec = Election
	 { election_name = Text.pack $ "elec"<>show nQuests<>show nChoices
	 , election_description = "benchmarkable election"
	 , election_uuid
	 , 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
		 , question_choices = (<$> [1..nChoices]) $ \choice -> Text.pack $ "choice"<>show choice
		 , question_mini = one
		 , question_maxi = one -- sum $ List.replicate nChoices one
		 }
	 }

makeVotes :: Election crypto v c -> [[Bool]]
makeVotes Election{..} =
	[ True : List.tail [ False | _choice <- question_choices quest ]
	| quest <- election_questions
	]

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
		encryptBallot elec (Just ballotSecKey) $
			makeVotes elec of
	 Right ballot -> ballot
	 Left err -> error ("encryptBallot: "<>show err)
	where
	seed = 0

titleElection :: Election crypto v c -> String
titleElection Election{..} =
	Printf.printf "(questions=%i)×(choices=%i)==%i"
	 nQuests nChoices (nQuests * nChoices)
	where
	nQuests  = List.length election_questions
	nChoices = List.foldr max 0 $ List.length . question_choices <$> election_questions

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 ::
 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 =
 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
			 ]
		 ]
	 , 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
			 ]
		 ]
	 ]
 ]