hjugement-protocol-0.0.0.20190511: benchmarks/Election.hs

{-# LANGUAGE OverloadedStrings #-}
module Election where

import qualified Data.List as List
import qualified Data.Text as Text
import qualified Text.Printf as Printf

import Voting.Protocol
import Utils

makeElection :: SubGroup q => Int -> Int -> Election q
makeElection nQuests nChoices = Election
 { election_name = Text.pack $ "elec"<>show nQuests<>show nChoices
 , election_description = "benchmarkable election"
 , election_uuid
 , election_publicKey =
	let secKey = credentialSecretKey election_uuid (Credential "xLcs7ev6Jy6FHHE") in
	publicKey secKey
 , election_hash = Hash "" -- FIXME: when implemented
 , 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 q -> [[Bool]]
makeVotes Election{..} =
	[ True : List.tail [ False | _choice <- question_choices quest ]
	| quest <- election_questions
	]

makeBallot :: forall q. SubGroup q => Election q -> Ballot q
makeBallot elec =
	case runExcept $ (`evalStateT` mkStdGen seed) $ do
		ballotSecKey :: SecretKey q <- randomSecretKey
		encryptBallot elec (Just ballotSecKey) $
			makeVotes elec of
	 Right ballot -> ballot
	 Left err -> error ("encryptBallot: "<>show err)
	where
	seed = 0

titleElection :: Election q -> 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 q. Params q => Int -> Int -> Benchmark
benchEncryptBallot nQuests nChoices =
	env setupEnv $ \ ~elec ->
		bench (titleElection elec) $
			nf makeBallot elec
	where
	setupEnv = do
		let elec :: Election q = makeElection nQuests nChoices
		return elec

benchVerifyBallot :: forall q. Params q => Int -> Int -> Benchmark
benchVerifyBallot nQuests nChoices =
	env setupEnv $ \ ~(elec,ballot) ->
		bench (titleElection elec) $
			nf (verifyBallot elec) ballot
	where
	setupEnv = do
		let elec :: Election q = makeElection nQuests nChoices
		let ballot = makeBallot elec
		return (elec,ballot)

benchmarks :: [Benchmark]
benchmarks =
 let inputs =
	 [ (nQ,nC)
	 | nQ <- [1,5,10,15,20,25]
	 , nC <- [5,7]
	 ] in
 [ bgroup "WeakParams"
	 [ bgroup "encryptBallot"
		 [ benchEncryptBallot @WeakParams nQuests nChoices
		 | (nQuests,nChoices) <- inputs
		 ]
	 , bgroup "verifyBallot"
		 [ benchVerifyBallot @BeleniosParams nQuests nChoices
		 | (nQuests,nChoices) <- inputs
		 ]
	 ]
 , bgroup "BeleniosParams"
	 [ bgroup "encryptBallot"
		 [ benchEncryptBallot @BeleniosParams nQuests nChoices
		 | (nQuests,nChoices) <- inputs
		 ]
	 , bgroup "verifyBallot"
		 [ benchVerifyBallot @BeleniosParams nQuests nChoices
		 | (nQuests,nChoices) <- inputs
		 ]
	 ]
 ]