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