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 :: forall c. Reifies c FFC => Int -> Int -> Election c
  12 makeElection nQuests nChoices = hashElection $ Election
  13  { election_name = Text.pack $ "elec"<>show nQuests<>show nChoices
  14  , election_description = "benchmarkable election"
  15  , election_uuid
  16  , election_crypto = ElectionCrypto_FFC (reflect (Proxy::Proxy c)) $
  17         let secKey = credentialSecretKey election_uuid (Credential "xLcs7ev6Jy6FHHE") in
  18         publicKey secKey
  19  , election_hash = Hash ""
  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 c -> [[Bool]]
  30 makeVotes Election{..} =
  31         [ True : List.tail [ False | _choice <- question_choices quest ]
  32         | quest <- election_questions
  33         ]
  34
  35 makeBallot :: Reifies c FFC => Election c -> Ballot c
  36 makeBallot elec =
  37         case runExcept $ (`evalStateT` mkStdGen seed) $ do
  38                 ballotSecKey <- 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 c -> 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 :: FFC -> Int -> Int -> Benchmark
  55 benchEncryptBallot ffc nQuests nChoices =
  56         reify ffc $ \(Proxy::Proxy c) ->
  57                 let setupEnv = do
  58                         let elec :: Election c = makeElection nQuests nChoices
  59                         return elec in
  60                 env setupEnv $ \ ~(elec) ->
  61                         bench (titleElection elec) $
  62                                 nf makeBallot elec
  63
  64 benchVerifyBallot :: FFC -> Int -> Int -> Benchmark
  65 benchVerifyBallot ffc nQuests nChoices =
  66         reify ffc $ \(Proxy::Proxy c) ->
  67                 let setupEnv = do
  68                         let elec :: Election c = makeElection nQuests nChoices
  69                         let ballot = makeBallot elec
  70                         return (elec,ballot) in
  71                 env setupEnv $ \ ~(elec, ballot) ->
  72                         bench (titleElection elec) $
  73                                 nf (verifyBallot 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 "weakFFC"
  83          [ bgroup "encryptBallot"
  84                  [ benchEncryptBallot weakFFC nQuests nChoices
  85                  | (nQuests,nChoices) <- inputs
  86                  ]
  87          , bgroup "verifyBallot"
  88                  [ benchVerifyBallot weakFFC nQuests nChoices
  89                  | (nQuests,nChoices) <- inputs
  90                  ]
  91          ]
  92  , bgroup "beleniosFFC"
  93          [ bgroup "encryptBallot"
  94                  [ benchEncryptBallot beleniosFFC nQuests nChoices
  95                  | (nQuests,nChoices) <- inputs
  96                  ]
  97          , bgroup "verifyBallot"
  98                  [ benchVerifyBallot beleniosFFC nQuests nChoices
  99                  | (nQuests,nChoices) <- inputs
 100                  ]
 101          ]
 102  ]