hjugement-protocol-0.0.7.20190815: 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 = 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
		 }
	 }

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
		 ]
	 ]
 ]