hjugement-cli/src/Hjugement/CLI/Administrator.hs

   1 {-# LANGUAGE NoMonomorphismRestriction #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 {-# LANGUAGE StrictData #-}
   4 {-# OPTIONS_GHC -Wno-missing-signatures #-}
   5 module Hjugement.CLI.Administrator where
   6
   7 import Control.Applicative (Applicative(..))
   8 import Control.Monad (Monad(..), forM_, unless)
   9 import Control.Monad.Trans.Except (runExcept)
  10 import Control.Monad.Trans.Maybe (MaybeT(..))
  11 import Control.Monad.Trans.State.Strict (runState)
  12 import Data.Bool
  13 import Data.Either (Either(..))
  14 import Data.Eq (Eq(..))
  15 import Data.Function (($), id, flip)
  16 import Data.Functor ((<$>))
  17 import Data.Maybe (Maybe(..), fromMaybe)
  18 import Data.Ord (Ord(..))
  19 import Data.Proxy (Proxy(..))
  20 import Data.Semigroup (Semigroup(..))
  21 import Data.Text (Text)
  22 import Symantic.CLI as CLI
  23 import Text.Show (Show(..))
  24 import qualified Data.Aeson as JSON
  25 import qualified Data.ByteString.Lazy as BSL
  26 import qualified Data.List as List
  27 import qualified Data.Text as Text
  28 import qualified Pipes as Pip
  29 import qualified Pipes.Prelude as Pip
  30 import qualified Symantic.Document as Doc
  31 import qualified System.FilePath as FP
  32 import qualified System.Random as Rand
  33 import qualified Voting.Protocol as VP
  34
  35 import Hjugement.CLI.Utils
  36
  37 -- * administrator
  38 data Administrator_Params = Administrator_Params
  39  {
  40  } deriving (Show)
  41
  42 api_administrator =
  43         "Commands for an administrator."
  44         `helps`
  45         command "administrator" $
  46                 api_administrator_election
  47                 <!> api_administrator_tally
  48                 <!> api_help False
  49 run_administrator globParams =
  50         run_administrator_election globParams
  51         :!: run_administrator_tally globParams
  52         :!: run_help api_administrator
  53
  54 -- ** election
  55 data AdministratorElection_Params = AdministratorElection_Params
  56  {   administratorElection_crypto       :: VP.FFC
  57  ,   administratorElection_name         :: Text
  58  ,   administratorElection_description  :: Text
  59  ,   administratorElection_uuid         :: Maybe Text
  60  ,   administratorElection_grades       :: [Text]
  61  ,   administratorElection_defaultGrade :: Maybe Text
  62  } deriving (Show)
  63
  64 api_administrator_election =
  65         "This command reads and checks the trustees' public keys in "<>fileRef"public_keys.jsons"<>".\
  66  \ From which it computes the global election public key\
  67  \ put it into an "<>fileRef"election.json"<>" file \
  68  \ with the infos of the vote given here."
  69         `helps`
  70         command "election" $
  71                 rule "PARAMS"
  72                  (AdministratorElection_Params
  73                          <$> api_param_crypto
  74                          <*> api_param_name
  75                          <*> api_param_description
  76                          <*> api_option_uuid
  77                          <*> api_param_grades
  78                          <*> api_param_defaultGrade)
  79                 <?> api_quests
  80                 <.> response @(Maybe ())
  81         where
  82         api_param_name =
  83                 "Name of the election."
  84                 `help`
  85                 defaultTag "name" "" (var "STRING")
  86         api_param_description =
  87                 "Description of the election."
  88                 `help`
  89                 defaultTag "description" "" (var "STRING")
  90         api_option_uuid =
  91                 "UUID of the election."
  92                 `help`
  93                 optionalTag "uuid" $
  94                         var "UUID"
  95         api_quests =
  96                 "Some questions."
  97                 `help`
  98                 many1 (var @Text "STRING")
  99         api_param_grades =
 100                 "The grades to evaluate the choices, from the lowest to the highest."
 101                 `helps`
 102                 many1Tag (TagLong "grade") $
 103                         var @Text "STRING"
 104         api_param_defaultGrade =
 105                 "The grade used when no grade is given by a voter.\n"<>
 106                 "Defaults to the lowest grade."
 107                 `helps`
 108                 optionalTag (TagLong "default-grade") $
 109                         var @Text "STRING"
 110
 111 run_administrator_election
 112  glob@Global_Params{..}
 113  AdministratorElection_Params{..}
 114  quests =
 115         VP.reify administratorElection_crypto $ \(_crypto::Proxy c) -> runMaybeT $ do
 116                 election_uuid <-
 117                         case administratorElection_uuid of
 118                          Nothing -> Pip.liftIO $ Rand.getStdRandom $ runState $ VP.randomUUID
 119                          Just u ->
 120                                 case VP.readUUID u of
 121                                  Left err -> outputError glob $ Doc.from (show err)
 122                                  Right uuid -> return uuid
 123                 let trusteeKeysPath = global_dir FP.</> "public_keys.jsons"
 124                 trusteeKeys :: [VP.TrusteePublicKey c] <- runPipeWithError glob $
 125                         Pip.toListM' $ readJSON glob trusteeKeysPath
 126                 forM_ trusteeKeys $ \trusteeKey ->
 127                         case runExcept $ VP.verifyIndispensableTrusteePublicKey trusteeKey of
 128                          Left err -> outputError glob $ Doc.from (show err)
 129                          Right () -> return ()
 130                 let grades = List.nub administratorElection_grades
 131                 unless (List.length grades > 1) $
 132                         outputError glob $ "at least two distinct grades are needed"
 133                 unless (List.length grades == List.length administratorElection_grades) $
 134                         outputError glob $ "indistinct grades: " <>
 135                                 Doc.from (Text.intercalate ", " $ List.nub $
 136                                         administratorElection_grades List.\\ grades)
 137                 let defaultGrade =
 138                         fromMaybe (grades List.!!0)
 139                          administratorElection_defaultGrade
 140                  -- FIXME: put defaultGrade into election.json
 141                 let elec =
 142                         VP.Election
 143                          { VP.election_name        = administratorElection_name
 144                          , VP.election_description = administratorElection_description
 145                          , VP.election_crypto      = VP.ElectionCrypto_FFC
 146                                  { electionCrypto_FFC_params    = administratorElection_crypto
 147                                  , electionCrypto_FFC_PublicKey = VP.combineIndispensableTrusteePublicKeys trusteeKeys
 148                                  }
 149                          , VP.election_questions = (<$> quests) $ \quest -> VP.Question
 150                                  { question_text    = quest
 151                                  , question_choices = grades
 152                                  , question_mini    = 1
 153                                  , question_maxi    = 1
 154                                  }
 155                          , VP.election_uuid
 156                          , VP.election_hash = VP.Base64SHA256 ""
 157                          }
 158                 saveJSON glob (global_dir FP.</> "election.json") elec
 159                 outputInfo glob $
 160                         "created election with "<>Doc.from (show election_uuid)<>
 161                         " and "<>Doc.from (show (VP.base64SHA256 (BSL.toStrict (JSON.encode elec))))
 162
 163 -- ** tally
 164 api_administrator_tally =
 165  "Tally an election using the decryption shares gathered from trustees\
 166  \ in "<>fileRef "partial_decryptions.jsons"<>".\
 167  \ The result is saved in "<>fileRef "result.json"<>".\n\
 168  \ It contains the decryption shares,\
 169  \ so "<>fileRef "partial_decryptions.jsons"<>" can be discarded afterwards."
 170         `helps`
 171         command "tally" $
 172                 response @(Maybe ())
 173
 174 run_administrator_tally
 175  glob@Global_Params{..} = runMaybeT $ do
 176         rawElec <- loadElection glob $ global_dir FP.</> "election.json"
 177         VP.reifyElection rawElec $ \(_elec :: VP.Election c) -> do
 178                 keys <- runPipeWithError glob $ Pip.toListM' $
 179                         readJSON glob $ global_dir FP.</> "public_keys.jsons"
 180                 decs <- runPipeWithError glob $ Pip.toListM' $
 181                         readJSON glob $ global_dir FP.</> "partial_decryptions.jsons"
 182                 outputInfo glob $ "computing encrypted tally from ballots"
 183                 (encTally, numBallots) <- runPipeWithError glob $
 184                         Pip.fold'
 185                          (flip VP.insertEncryptedTally)
 186                          VP.emptyEncryptedTally id $
 187                                 readJSON glob $ global_dir FP.</> "ballots.jsons"
 188                 outputInfo glob $ "decrypting tally using trustees' decryption shares"
 189                 case runExcept $ VP.proveTally
 190                          (encTally :: VP.EncryptedTally c, numBallots) decs
 191                          (VP.combineIndispensableDecryptionShares (VP.trustee_PublicKey <$> keys)) of
 192                  Left err -> outputError glob $ Doc.from (show err)
 193                  Right tally -> do
 194                         let resultPath = global_dir FP.</> "result.json"
 195                         saveJSON glob resultPath tally
 196                         outputInfo glob $ "tally generated in " <> Doc.from resultPath