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