]> Git — Sourcephile - majurity.git/blob - hjugement-protocol/benchmarks/Election.hs
cli: admin: directly use election_hash
[majurity.git] / 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 ]