]> Git — Sourcephile - majurity.git/blob - hjugement-protocol/benchmarks/Election.hs
protocol: work around to avoid ConstraintKinds
[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 Reifies c crypto =>
17 JSON.ToJSON crypto =>
18 JSON.ToJSON (G crypto c) =>
19 Key crypto =>
20 Int -> Int -> Election crypto v c
21 makeElection nQuests nChoices = elec
22 where
23 election_uuid = UUID "xLcs7ev6Jy6FHH"
24 elec = Election
25 { election_name = Text.pack $ "elec"<>show nQuests<>show nChoices
26 , election_description = "benchmarkable election"
27 , election_uuid
28 , election_crypto = reflect (Proxy @c)
29 , election_public_key =
30 let secKey = credentialSecretKey election_uuid (Credential "xLcs7ev6Jy6FHHE") in
31 publicKey secKey
32 , election_hash = hashElection elec
33 , election_version = Just (reflect (Proxy @v))
34 , election_questions =
35 (<$> [1..nQuests]) $ \quest -> Question
36 { question_text = Text.pack $ "quest"<>show quest
37 , question_choices = (<$> [1..nChoices]) $ \choice -> Text.pack $ "choice"<>show choice
38 , question_mini = one
39 , question_maxi = one -- sum $ List.replicate nChoices one
40 }
41 }
42
43 makeVotes :: Election crypto v c -> [[Bool]]
44 makeVotes Election{..} =
45 [ True : List.tail [ False | _choice <- question_choices quest ]
46 | quest <- election_questions
47 ]
48
49 makeBallot ::
50 Reifies v Version =>
51 Reifies c crypto =>
52 Group crypto =>
53 Key crypto =>
54 Multiplicative (G crypto c) =>
55 Invertible (G crypto c) =>
56 ToNatural (G crypto c) =>
57 Election crypto v c -> Ballot crypto v c
58 makeBallot elec =
59 case runExcept $ (`evalStateT` mkStdGen seed) $ do
60 ballotSecKey <- randomSecretKey
61 encryptBallot elec (Just ballotSecKey) $
62 makeVotes elec of
63 Right ballot -> ballot
64 Left err -> error ("encryptBallot: "<>show err)
65 where
66 seed = 0
67
68 titleElection :: Election crypto v c -> String
69 titleElection Election{..} =
70 Printf.printf "(questions=%i)×(choices=%i)==%i"
71 nQuests nChoices (nQuests * nChoices)
72 where
73 nQuests = List.length election_questions
74 nChoices = List.foldr max 0 $ List.length . question_choices <$> election_questions
75
76 benchEncryptBallot ::
77 forall crypto v c.
78 Reifies v Version =>
79 Reifies c crypto =>
80 JSON.ToJSON crypto =>
81 Group crypto =>
82 Key crypto =>
83 NFData crypto =>
84 NFData (G crypto c) =>
85 Multiplicative (G crypto c) =>
86 Invertible (G crypto c) =>
87 ToNatural (G crypto c) =>
88 JSON.ToJSON (G crypto c) =>
89 Proxy v -> Proxy c -> Int -> Int -> Benchmark
90 benchEncryptBallot (_v::Proxy v) (_c::Proxy c) nQuests nChoices =
91 let setupEnv = do
92 let elec :: Election crypto v c = makeElection nQuests nChoices
93 return elec in
94 env setupEnv $ \ ~(elec) ->
95 bench (titleElection elec) $
96 nf makeBallot elec
97
98 benchVerifyBallot ::
99 forall crypto v c.
100 Reifies v Version =>
101 Reifies c crypto =>
102 JSON.ToJSON crypto =>
103 Group crypto =>
104 Key crypto =>
105 NFData crypto =>
106 NFData (G crypto c) =>
107 Multiplicative (G crypto c) =>
108 Invertible (G crypto c) =>
109 ToNatural (G crypto c) =>
110 JSON.ToJSON (G crypto c) =>
111 Proxy v -> Proxy c -> Int -> Int -> Benchmark
112 benchVerifyBallot (_v::Proxy v) (_c::Proxy c) nQuests nChoices =
113 let setupEnv = do
114 let elec :: Election crypto v c = makeElection nQuests nChoices
115 let ballot = makeBallot elec
116 return (elec,ballot) in
117 env setupEnv $ \ ~(elec, ballot) ->
118 bench (titleElection elec) $
119 nf (verifyBallot elec) ballot
120
121 benchmarks :: [Benchmark]
122 benchmarks =
123 let inputs =
124 [ (nQ,nC)
125 | nQ <- [1,5,10,15,20,25]
126 , nC <- [5,7]
127 ] in
128 [ bgroup "stableVersion" $ reify stableVersion $ \v ->
129 [ bgroup "weakFFC" $ reify weakFFC $ \c ->
130 [ bgroup "encryptBallot"
131 [ benchEncryptBallot v c nQuests nChoices
132 | (nQuests,nChoices) <- inputs
133 ]
134 , bgroup "verifyBallot"
135 [ benchVerifyBallot v c nQuests nChoices
136 | (nQuests,nChoices) <- inputs
137 ]
138 ]
139 , bgroup "beleniosFFC" $ reify beleniosFFC $ \c ->
140 [ bgroup "encryptBallot"
141 [ benchEncryptBallot v c nQuests nChoices
142 | (nQuests,nChoices) <- inputs
143 ]
144 , bgroup "verifyBallot"
145 [ benchVerifyBallot v c nQuests nChoices
146 | (nQuests,nChoices) <- inputs
147 ]
148 ]
149 ]
150 ]