]> Git — Sourcephile - majurity.git/blob - hjugement-cli/src/Hjugement/CLI/Voter.hs
web: impl: continue to transcode Voting.Protocol.Cryptography
[majurity.git] / hjugement-cli / src / Hjugement / CLI / Voter.hs
1 {-# LANGUAGE NoMonomorphismRestriction #-}
2 {-# LANGUAGE OverloadedStrings #-}
3 {-# LANGUAGE StrictData #-}
4 {-# LANGUAGE TypeApplications #-}
5 {-# OPTIONS_GHC -Wno-missing-signatures #-}
6 module Hjugement.CLI.Voter where
7
8 import Control.Applicative (Applicative(..), Alternative(..))
9 import Control.Monad (Monad(..), join, unless, void, when)
10 import Control.Monad.Trans.Maybe (MaybeT(..))
11 import Control.Monad.Trans.Except (runExcept)
12 import Control.Monad.Trans.State.Strict (runStateT)
13 import Data.Bool
14 import Data.Either (Either(..))
15 import Data.Eq (Eq(..))
16 import Data.Foldable (sum)
17 import Data.Function (($))
18 import Data.Functor ((<$>))
19 import Data.Maybe (Maybe(..))
20 import Data.Ord (Ord(..))
21 import Data.Semigroup (Semigroup(..))
22 import Data.String (String)
23 import Data.Text (Text)
24 import Numeric.Natural (Natural)
25 import Prelude (Num(..))
26 import Symantic.CLI as CLI
27 import System.IO (FilePath)
28 import Text.Show (Show(..))
29 import qualified Data.Aeson as JSON
30 import qualified Data.ByteString.Lazy.Char8 as BSL8
31 import qualified Data.List as List
32 import qualified Data.Text as Text
33 import qualified Pipes as Pip
34 import qualified Pipes.Prelude as Pip
35 import qualified Symantic.Document as Doc
36 import qualified System.Directory as IO
37 import qualified System.FilePath as FP
38 import qualified System.IO as IO
39 import qualified System.Random as Rand
40 import qualified Voting.Protocol as VP
41 import qualified Voting.Protocol.Utils as VP
42
43 import Hjugement.CLI.Utils
44
45 -- * administrator
46 data Voter_Params = Voter_Params
47 {
48 } deriving (Show)
49
50 api_voter =
51 "Commands for a voter."
52 `helps`
53 command "voter" $
54 api_voter_vote
55 <!> api_voter_verify
56 <!> api_help False
57 run_voter globParams =
58 run_voter_vote globParams
59 :!: run_voter_verify globParams
60 :!: run_help api_voter
61
62 -- ** vote
63 data VoterVote_Params = VoterVote_Params
64 { voterVote_privcred :: VP.Credential
65 , voterVote_url :: FilePath
66 , voterVote_grades :: [Text]
67 } deriving (Show)
68
69 api_voter_vote =
70 "Cast a vote on an election."
71 `helps`
72 command "vote" $
73 rule "PARAMS"
74 (VoterVote_Params
75 <$> api_param_privcred
76 <*> api_param_url
77 <*> api_param_grades)
78 <?> response @(Maybe ())
79 where
80 api_param_privcred =
81 "Voter's private credential."
82 `helps`
83 requiredTag "privcred" (var "CREDENTIAL")
84 api_param_grades =
85 "The grades to evaluate the choices, from the lowest to the highest."
86 `helps`
87 many1Tag (TagLong "grade") $
88 var @Text "STRING"
89
90 run_voter_vote
91 glob@Global_Params{..}
92 VoterVote_Params{..} = runMaybeT $ do
93 loadElection glob (voterVote_url FP.</> "election.json") $
94 \(elec@VP.Election{..} :: VP.Election VP.FFC v c) -> do
95 outputInfo glob $ "Voted"<>Doc.from (show voterVote_grades)
96 votes <- VP.isoZipWithM
97 (outputError glob $ "Mismatching number of cast grades ("<>
98 Doc.from (List.length voterVote_grades)<>
99 ") and choices ("<>
100 Doc.from (List.length election_questions)<>
101 ")")
102 (\VP.Question{..} grade -> do
103 let bools = (grade ==) <$> question_choices
104 let boolSum = sum $ (<$> bools) $ \b -> if b then 1 else 0 :: Natural
105 unless (boolSum == 1) $
106 outputError glob $
107 "The election does not allow to cast a grade named: "<>Doc.from grade<>"\n"<>
108 "Allowed grades are: "<>Doc.from (Text.intercalate ", " question_choices)
109 return bools)
110 election_questions
111 voterVote_grades
112 outputInfo glob $ Doc.from (show votes)
113 let (secKey :: VP.SecretKey VP.FFC c) =
114 VP.credentialSecretKey election_uuid voterVote_privcred
115 ballot <- join $ Pip.liftIO $
116 Rand.getStdRandom $ \gen ->
117 case runExcept $ (`runStateT` gen) $
118 VP.encryptBallot elec (Just secKey) votes of
119 Left err -> (outputError glob $ Doc.from (show err), gen)
120 Right (ballot, gen') -> (return ballot, gen')
121 Pip.liftIO $ BSL8.putStrLn $ JSON.encode ballot
122
123 -- ** verify
124 data VoterVerify_Params = VoterVerify_Params
125 { voterVerify_url :: FilePath
126 } deriving (Show)
127
128 api_voter_verify =
129 "Cast a vote on an election."
130 `helps`
131 command "verify" $
132 rule "PARAMS"
133 (VoterVerify_Params
134 <$> api_param_url)
135 <?> response @(Maybe ())
136
137 run_voter_verify
138 glob@Global_Params{..}
139 VoterVerify_Params{..} = runMaybeT $ do
140 loadElection glob (voterVerify_url FP.</> "election.json") $
141 \(elec@VP.Election{..} :: VP.Election VP.FFC v c) -> do
142 outputInfo glob $ "verifying ballots"
143 (fails :: Natural, (encTally :: VP.EncryptedTally VP.FFC v c, _numBallots))
144 <- runPipeWithError glob $
145 Pip.foldM'
146 (\(fails, acc@(_, numBallots)) ballot@VP.Ballot{..} -> do
147 let ballotNum = numBallots + fails
148 outputDebug glob
149 { global_stderr_prepend_carriage = True
150 , global_stderr_append_newline = False
151 } $
152 "checking ballot #"<>Doc.from ballotNum
153 let globError = glob{global_stderr_prepend_newline = Verbosity_Debug <= global_verbosity}
154 case ballot_signature of
155 Nothing -> do
156 void $ runMaybeT $ outputError globError $
157 "ballot #"<>Doc.from ballotNum<>" has no signature"
158 return (fails+1, acc)
159 Just{} ->
160 if VP.verifyBallot elec ballot
161 then return (fails, VP.insertEncryptedTally ballot acc)
162 else do
163 void $ runMaybeT $ outputError globError $
164 "ballot #"<>Doc.from ballotNum<>" has an invalid signature"
165 return (fails+1, acc)
166 )
167 (return (0, VP.emptyEncryptedTally))
168 return $
169 readJSON glob $ voterVerify_url FP.</> "ballots.jsons"
170 when (Verbosity_Debug <= global_verbosity) $
171 Pip.liftIO $ output $ OnHandle IO.stderr (Doc.newline::String)
172 when (0 < fails) empty
173 let resultPath = voterVerify_url FP.</> "result.json"
174 hasResult <- Pip.liftIO $ IO.doesPathExist resultPath
175 if not hasResult
176 then do
177 outputWarning glob "no tally to check"
178 else do
179 tally :: VP.Tally VP.FFC v c <- loadJSON glob resultPath
180 outputInfo glob $ "decrypting tally using trustees' decryption shares"
181 trustees :: [VP.TrusteePublicKey VP.FFC v c]
182 <- runPipeWithError glob $ Pip.toListM' $
183 readJSON glob $ voterVerify_url FP.</> "public_keys.jsons"
184 let trustPubKeys = VP.trustee_PublicKey <$> trustees
185 decs <- runPipeWithError glob $ Pip.toListM' $
186 readJSON glob $ voterVerify_url FP.</> "partial_decryptions.jsons"
187 outputInfo glob $ "verifying tally"
188 case runExcept $ do
189 VP.verifyDecryptionShareByTrustee encTally trustPubKeys decs
190 VP.verifyTally tally (VP.combineIndispensableDecryptionShares trustPubKeys)
191 of
192 Left err -> outputError glob $ Doc.from (show err)
193 Right () -> return ()