1 {-# LANGUAGE NoMonomorphismRestriction #-}
2 {-# LANGUAGE OverloadedStrings #-}
3 {-# LANGUAGE StrictData #-}
4 {-# OPTIONS_GHC -Wno-missing-signatures #-}
5 module Hjugement.CLI.Administrator where
7 import Control.Applicative (Applicative(..), Alternative(..))
8 import Control.Monad (Monad(..), forM, forM_, join, unless, void)
9 import Control.Monad.Trans.Class (MonadTrans(..))
10 import Control.Monad.Trans.Except (runExcept)
11 import Control.Monad.Trans.Maybe (MaybeT(..))
12 import Control.Monad.Trans.State.Strict (runState, runStateT)
13 import Data.Bits (setBit)
15 import Data.ByteString (ByteString)
16 import Data.Either (Either(..))
17 import Data.Eq (Eq(..))
18 import Data.Foldable (Foldable, foldMap, length, null)
19 import Data.Function (($), (.), id, flip)
20 import Data.Functor ((<$>), (<$))
22 import Data.Maybe (Maybe(..), maybe, fromMaybe, fromJust)
23 import Data.Monoid (Monoid(..))
24 import Data.Ord (Ord(..))
25 import Data.Proxy (Proxy(..))
26 import Data.Semigroup (Semigroup(..))
27 import Data.String (String)
28 import Data.Text (Text)
29 import GHC.Natural (minusNatural, minusNaturalMaybe)
30 import GHC.Prim (coerce)
31 import Numeric.Natural (Natural)
33 import Prelude (logBase, ceiling, Num(..), (/), (^), fromIntegral, Double)
34 import Symantic.CLI as CLI
35 import System.IO (IO, FilePath)
36 import Text.Show (Show(..))
37 import qualified Crypto.Hash as Crypto
38 import qualified Data.Aeson as JSON
39 import qualified Data.ByteArray as ByteArray
40 import qualified Data.ByteString as BS
41 import qualified Data.ByteString.Char8 as BS8
42 import qualified Data.ByteString.Lazy as BSL
43 import qualified Data.List as List
44 import qualified Data.Text as Text
45 import qualified Data.Text.Encoding as Text
46 import qualified Data.Text.Lazy as TL
47 import qualified Data.Text.Lazy.Builder as TLB
48 import qualified Data.Text.Lazy.Builder.Int as TLB
49 import qualified Data.Text.Lazy.Encoding as TL
50 import qualified Data.Text.Lazy.IO as TL
51 import qualified Data.Time as Time
52 import qualified Lens.Family as Lens
53 import qualified Lens.Family.State.Strict as Lens
54 import qualified Pipes as Pip
55 import qualified Pipes.ByteString as PipBS
56 import qualified Pipes.Group as Pip
57 import qualified Pipes.Prelude as Pip
58 import qualified Pipes.Aeson as PipJSON (DecodingError(..))
59 import qualified Pipes.Aeson.Unchecked as PipJSON
60 import qualified Pipes.Safe as Pip
61 import qualified Pipes.Safe.Prelude as Pip
62 import qualified Pipes.Text as PipText
63 import qualified Pipes.Text.Encoding as PipText
64 import qualified Pipes.Text.IO as PipText
65 import qualified Symantic.Document as Doc
66 import qualified System.FilePath as FP
67 import qualified System.IO as IO
68 import qualified System.Posix as Posix
69 import qualified System.Random as Rand
70 import qualified Voting.Protocol as VP
72 import Hjugement.CLI.Utils
75 data Administrator_Params = Administrator_Params
80 "Commands for an administrator."
82 command "administrator" $
83 api_administrator_election
84 <!> api_administrator_tally
86 run_administrator globParams =
87 run_administrator_election globParams
88 :!: run_administrator_tally globParams
89 :!: run_help api_administrator
92 data AdministratorElection_Params = AdministratorElection_Params
93 { administratorElection_crypto :: VP.FFC
94 , administratorElection_name :: Text
95 , administratorElection_description :: Text
96 , administratorElection_uuid :: Maybe Text
97 , administratorElection_grades :: [Text]
98 , administratorElection_defaultGrade :: Maybe Text
101 api_administrator_election =
102 "This command reads and checks the trustees' public keys in "<>fileRef"public_keys.jsons"<>".\
103 \ From which it computes the global election public key\
104 \ put it into an "<>fileRef"election.json"<>" file \
105 \ with the infos of the vote given here."
109 (AdministratorElection_Params
112 <*> api_param_description
115 <*> api_param_defaultGrade)
117 <.> response @(Maybe ())
120 "Name of the election."
122 defaultTag "name" "" (var "STRING")
123 api_param_description =
124 "Description of the election."
126 defaultTag "description" "" (var "STRING")
128 "UUID of the election."
135 many1 (var @Text "STRING")
137 "The grades to evaluate the choices, from the lowest to the highest."
139 many1Tag (TagLong "grade") $
141 api_param_defaultGrade =
142 "The grade used when no grade is given by a voter.\n"<>
143 "Defaults to the lowest grade."
145 optionalTag (TagLong "default-grade") $
148 run_administrator_election
149 glob@Global_Params{..}
150 AdministratorElection_Params{..}
152 VP.reify administratorElection_crypto $ \(_crypto::Proxy c) -> runMaybeT $ do
154 case administratorElection_uuid of
155 Nothing -> Pip.liftIO $ Rand.getStdRandom $ runState $ VP.randomUUID
157 case VP.readUUID u of
158 Left err -> outputError glob $ Doc.from (show err)
159 Right uuid -> return uuid
160 let trusteeKeysPath = global_dir FP.</> "public_keys.jsons"
161 trusteeKeys :: [VP.TrusteePublicKey c] <- runPipeWithError glob $
162 Pip.toListM' $ readJSON glob trusteeKeysPath
163 forM_ trusteeKeys $ \trusteeKey ->
164 case runExcept $ VP.verifyIndispensableTrusteePublicKey trusteeKey of
165 Left err -> outputError glob $ Doc.from (show err)
166 Right () -> return ()
167 let grades = List.nub administratorElection_grades
168 unless (List.length grades > 1) $
169 outputError glob $ "at least two distinct grades are needed"
170 unless (List.length grades == List.length administratorElection_grades) $
171 outputError glob $ "indistinct grades: " <>
172 Doc.from (Text.intercalate ", " $ List.nub $
173 administratorElection_grades List.\\ grades)
174 let defaultGrade = fromMaybe (grades List.!!0) administratorElection_defaultGrade
175 -- FIXME: put defaultGrade into election.json
176 saveJSON glob (global_dir FP.</> "election.json") $
177 VP.hashElection VP.Election
178 { VP.election_name = administratorElection_name
179 , VP.election_description = administratorElection_description
180 , VP.election_crypto = VP.ElectionCrypto_FFC
181 { electionCrypto_FFC_params = administratorElection_crypto
182 , electionCrypto_FFC_PublicKey = VP.combineIndispensableTrusteePublicKeys trusteeKeys
184 , VP.election_questions = (<$> quests) $ \quest -> VP.Question
185 { question_text = quest
186 , question_choices = grades
191 , VP.election_hash = VP.hashJSON JSON.Null
193 outputInfo glob $ "created election with "<>Doc.from (show election_uuid)
196 api_administrator_tally =
197 "Tally an election using the decryption shares gathered from trustees\
198 \ in "<>fileRef "partial_decryptions.jsons"<>".\
199 \ The result is saved in "<>fileRef "result.json"<>".\n\
200 \ It contains the decryption shares,\
201 \ so "<>fileRef "partial_decryptions.jsons"<>" can be discarded afterwards."
206 run_administrator_tally
207 glob@Global_Params{..} = runMaybeT $ do
208 rawElec <- loadJSON glob $ global_dir FP.</> "election.json"
209 VP.reifyElection rawElec $ \(_elec :: VP.Election c) -> do
210 keys <- runPipeWithError glob $ Pip.toListM' $
211 readJSON glob $ global_dir FP.</> "public_keys.jsons"
212 decs <- runPipeWithError glob $ Pip.toListM' $
213 readJSON glob $ global_dir FP.</> "partial_decryptions.jsons"
214 outputInfo glob $ "computing encrypted tally from ballots"
215 (encTally, numBallots) <- runPipeWithError glob $
217 (flip VP.insertEncryptedTally)
218 VP.emptyEncryptedTally id $
219 readJSON glob $ global_dir FP.</> "ballots.jsons"
220 outputInfo glob $ "decrypting tally using trustees' decryption shares"
221 case runExcept $ VP.proveTally
222 (encTally :: VP.EncryptedTally c, numBallots) decs
223 (VP.combineIndispensableDecryptionShares (VP.trustee_PublicKey <$> keys)) of
224 Left err -> outputError glob $ Doc.from (show err)
226 let resultPath = global_dir FP.</> "result.json"
227 saveJSON glob resultPath tally
228 outputInfo glob $ "tally generated in " <> Doc.from resultPath