hjugement-protocol/benchmarks/Election.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 module Election where
   3
   4 import Control.DeepSeq (NFData)
   5 import qualified Data.List as List
   6 import qualified Data.Text as Text
   7 import qualified Text.Printf as Printf
   8 import qualified Data.Aeson as JSON
   9
  10 import Voting.Protocol
  11 import Utils
  12
  13 makeElection ::
  14  forall crypto v c.
  15  Reifies v Version =>
  16  CryptoParams crypto c =>
  17  Key crypto =>
  18  JSON.ToJSON crypto =>
  19  Int -> Int -> Election crypto v c
  20 makeElection nQuests nChoices = elec
  21         where
  22         election_uuid = UUID "xLcs7ev6Jy6FHH"
  23         elec = Election
  24          { election_name = Text.pack $ "elec"<>show nQuests<>show nChoices
  25          , election_description = "benchmarkable election"
  26          , election_uuid
  27          , election_crypto = reflect (Proxy @c)
  28          , election_public_key =
  29                 let secKey = credentialSecretKey election_uuid (Credential "xLcs7ev6Jy6FHHE") in
  30                 publicKey secKey
  31          , election_hash = hashElection elec
  32          , election_version = Just (reflect (Proxy @v))
  33          , election_questions =
  34                 (<$> [1..nQuests]) $ \quest -> Question
  35                  { question_text = Text.pack $ "quest"<>show quest
  36                  , question_choices = (<$> [1..nChoices]) $ \choice -> Text.pack $ "choice"<>show choice
  37                  , question_mini = one
  38                  , question_maxi = one -- sum $ List.replicate nChoices one
  39                  }
  40          }
  41
  42 makeVotes :: Election crypto v c -> [[Bool]]
  43 makeVotes Election{..} =
  44         [ True : List.tail [ False | _choice <- question_choices quest ]
  45         | quest <- election_questions
  46         ]
  47
  48 makeBallot ::
  49  Reifies v Version =>
  50  CryptoParams crypto c => Key crypto =>
  51  Election crypto v c -> Ballot crypto v c
  52 makeBallot elec =
  53         case runExcept $ (`evalStateT` mkStdGen seed) $ do
  54                 ballotSecKey <- randomSecretKey
  55                 encryptBallot elec (Just ballotSecKey) $
  56                         makeVotes elec of
  57          Right ballot -> ballot
  58          Left err -> error ("encryptBallot: "<>show err)
  59         where
  60         seed = 0
  61
  62 titleElection :: Election crypto v c -> String
  63 titleElection Election{..} =
  64         Printf.printf "(questions=%i)×(choices=%i)==%i"
  65          nQuests nChoices (nQuests * nChoices)
  66         where
  67         nQuests  = List.length election_questions
  68         nChoices = List.foldr max 0 $ List.length . question_choices <$> election_questions
  69
  70 benchEncryptBallot ::
  71  forall crypto v c.
  72  CryptoParams crypto c =>
  73  Reifies v Version =>
  74  Key crypto =>
  75  JSON.ToJSON crypto =>
  76  NFData crypto =>
  77  Proxy v -> Proxy c -> Int -> Int -> Benchmark
  78 benchEncryptBallot _v _c nQuests nChoices =
  79         let setupEnv = do
  80                 let elec :: Election crypto v c = makeElection nQuests nChoices
  81                 return elec in
  82         env setupEnv $ \ ~(elec) ->
  83                 bench (titleElection elec) $
  84                         nf makeBallot elec
  85
  86 benchVerifyBallot ::
  87  forall crypto v c.
  88  Reifies v Version =>
  89  CryptoParams crypto c =>
  90  Key crypto =>
  91  JSON.ToJSON crypto =>
  92  NFData crypto =>
  93  Proxy v -> Proxy c -> Int -> Int -> Benchmark
  94 benchVerifyBallot (_v::Proxy v) (_c::Proxy c) nQuests nChoices =
  95         let setupEnv = do
  96                 let elec :: Election crypto v c = makeElection nQuests nChoices
  97                 let ballot = makeBallot elec
  98                 return (elec,ballot) in
  99         env setupEnv $ \ ~(elec, ballot) ->
 100                 bench (titleElection elec) $
 101                         nf (verifyBallot elec) ballot
 102
 103 benchmarks :: [Benchmark]
 104 benchmarks =
 105  [ benchsByVersion stableVersion
 106  -- , benchsByVersion experimentalVersion
 107  ]
 108
 109 benchsByVersion :: Version -> Benchmark
 110 benchsByVersion version =
 111         reify version $ \v ->
 112         bgroup ("v"<>show version)
 113                 [ benchsByCrypto v weakFFC
 114                 , benchsByCrypto v beleniosFFC
 115                 ]
 116
 117 benchsByCrypto ::
 118  Reifies v Version =>
 119  ReifyCrypto crypto =>
 120  Key crypto =>
 121  JSON.ToJSON crypto =>
 122  NFData crypto =>
 123  Proxy v -> crypto -> Benchmark
 124 benchsByCrypto v crypto =
 125         reifyCrypto crypto $ \c ->
 126         bgroup (Text.unpack (cryptoName crypto))
 127          [ bgroup "encryptBallot"
 128                  [ benchEncryptBallot v c nQuests nChoices
 129                  | (nQuests,nChoices) <- inputs
 130                  ]
 131          , bgroup "verifyBallot"
 132                  [ benchVerifyBallot v c nQuests nChoices
 133                  | (nQuests,nChoices) <- inputs
 134                  ]
 135          ]
 136         where
 137         inputs =
 138                 [ (nQ,nC)
 139                 | nQ <- [1,5,10,15,20,25]
 140                 , nC <- [5,7]
 141                 ]