hjugement-protocol-0.0.0.20190519: 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 :: 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
	 }
 } where election_uuid = UUID "xLcs7ev6Jy6FHH"

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

makeBallot :: Reifies c FFC => Election c -> Ballot 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 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 :: 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

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

benchmarks :: [Benchmark]
benchmarks =
 let inputs =
	 [ (nQ,nC)
	 | nQ <- [1,5,10,15,20,25]
	 , nC <- [5,7]
	 ] in
 [ bgroup "weakFFC"
	 [ bgroup "encryptBallot"
		 [ benchEncryptBallot weakFFC 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
		 ]
	 ]
 ]