hjugement-protocol/benchmarks/Election.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 module Election where
   3
   4 import qualified Data.List as List
   5 import qualified Data.Text as Text
   6
   7 import Voting.Protocol
   8 import Utils
   9
  10 makeElection :: SubGroup q => Int -> Int -> Election q
  11 makeElection nQuests nChoices = Election
  12  { election_name = Text.pack $ "elec"<>show nQuests<>show nChoices
  13  , election_description = "benchmarkable election"
  14  , election_uuid
  15  , election_publicKey =
  16         let secKey = credentialSecretKey election_uuid (Credential "xLcs7ev6Jy6FHHE") in
  17         publicKey secKey
  18  , election_hash = Hash "" -- FIXME: when implemented
  19  , election_questions =
  20         (<$> [1..nQuests]) $ \quest -> Question
  21          { question_text = Text.pack $ "quest"<>show quest
  22          , question_choices = (<$> [1..nChoices]) $ \choice -> Text.pack $ "choice"<>show choice
  23          , question_mini = zero
  24          , question_maxi = sum $ List.replicate nChoices one
  25          }
  26  } where election_uuid = UUID "xLcs7ev6Jy6FHH"
  27
  28 makeVotes :: Election q -> [[Bool]]
  29 makeVotes Election{..} =
  30         [ [ True | _choice <- question_choices quest ]
  31         | quest <- election_questions
  32         ]
  33
  34 makeBallot :: forall q. SubGroup q => Election q -> Ballot q
  35 makeBallot elec =
  36         case runExcept $ (`evalStateT` mkStdGen seed) $ do
  37                 ballotSecKey :: SecretKey q <- randomSecretKey
  38                 encryptBallot elec (Just ballotSecKey) $
  39                         makeVotes elec of
  40          Right ballot -> ballot
  41          Left err -> error ("encryptBallot: "<>show err)
  42         where
  43         seed = 0
  44
  45 benchEncryptBallot :: forall q. Params q => Int -> Int -> Benchmark
  46 benchEncryptBallot nQuests nChoices =
  47         env setupEnv $ \ ~elec ->
  48                 bench ("(nQuests="<>show nQuests<>")*(nChoices="<>show nChoices<>")=="<>show (nQuests * nChoices)) $
  49                         nf makeBallot elec
  50         where
  51         setupEnv = do
  52                 let elec :: Election q = makeElection nQuests nChoices
  53                 return elec
  54
  55 benchVerifyBallot :: forall q. Params q => Int -> Int -> Benchmark
  56 benchVerifyBallot nQuests nChoices =
  57         env setupEnv $ \ ~(elec,ballot) ->
  58                 bench ("(nQuests="<>show nQuests<>")*(nChoices="<>show nChoices<>")=="<>show (nQuests * nChoices)) $
  59                         nf (verifyBallot elec) ballot
  60         where
  61         setupEnv = do
  62                 let elec :: Election q = makeElection nQuests nChoices
  63                 let ballot = makeBallot elec
  64                 return (elec,ballot)
  65
  66 benchmarks :: [Benchmark]
  67 benchmarks =
  68  -- let inputs = [(1,2), (5,5), (10,5), (5,10){-, (10,6), (10,7), (15,5)-}] in
  69  let inputs =
  70          [ (nQ,nC)
  71          | nQ <- [1,5,10,15{-,20,25-}]
  72          , nC <- [5..7]
  73          ] in
  74  [ bgroup "WeakParams"
  75          [ bgroup "encryptBallot"
  76                  [ benchEncryptBallot @WeakParams nQuests nChoices
  77                  | (nQuests,nChoices) <- inputs
  78                  ]
  79          , bgroup "verifyBallot"
  80                  [ benchVerifyBallot @BeleniosParams nQuests nChoices
  81                  | (nQuests,nChoices) <- inputs
  82                  ]
  83          ]
  84  , bgroup "BeleniosParams"
  85          [ bgroup "encryptBallot"
  86                  [ benchEncryptBallot @BeleniosParams nQuests nChoices
  87                  | (nQuests,nChoices) <- inputs
  88                  ]
  89          , bgroup "verifyBallot"
  90                  [ benchVerifyBallot @BeleniosParams nQuests nChoices
  91                  | (nQuests,nChoices) <- inputs
  92                  ]
  93          ]
  94  ]