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.List as List
  25 import qualified Data.Text as Text
  26 import qualified Pipes as Pip
  27 import qualified Pipes.Prelude as Pip
  28 import qualified Symantic.Document as Doc
  29 import qualified System.FilePath as FP
  30 import qualified System.Random as Rand
  31 import qualified Voting.Protocol as VP
  32
  33 import Hjugement.CLI.Utils
  34
  35 -- * administrator
  36 data Administrator_Params = Administrator_Params
  37  {
  38  } deriving (Show)
  39
  40 api_administrator =
  41         "Commands for an administrator."
  42         `helps`
  43         command "administrator" $
  44                 api_administrator_election
  45                 <!> api_administrator_tally
  46                 <!> api_help False
  47 run_administrator globParams =
  48         run_administrator_election globParams
  49         :!: run_administrator_tally globParams
  50         :!: run_help api_administrator
  51
  52 -- ** election
  53 data AdministratorElection_Params = AdministratorElection_Params
  54  {   administratorElection_crypto       :: VP.FFC
  55  ,   administratorElection_name         :: Text
  56  ,   administratorElection_description  :: Text
  57  ,   administratorElection_uuid         :: Maybe Text
  58  ,   administratorElection_grades       :: [Text]
  59  ,   administratorElection_defaultGrade :: Maybe Text
  60  ,   administratorElection_version      :: VP.Version
  61  } deriving (Show)
  62
  63 api_administrator_election =
  64         "This command reads and checks the trustees' public keys in "<>fileRef"public_keys.jsons"<>".\
  65  \ From which it computes the global election public key\
  66  \ put it into an "<>fileRef"election.json"<>" file \
  67  \ with the infos of the vote given here."
  68         `helps`
  69         command "election" $
  70                 rule "PARAMS"
  71                  (AdministratorElection_Params
  72                          <$> api_param_crypto
  73                          <*> api_param_name
  74                          <*> api_param_description
  75                          <*> api_option_uuid
  76                          <*> api_param_grades
  77                          <*> api_param_defaultGrade
  78                          <*> api_param_version)
  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_version $ \(_v::Proxy v) ->
 116         VP.reify administratorElection_crypto $ \(_c::Proxy c) -> runMaybeT $ do
 117                 election_uuid <-
 118                         case administratorElection_uuid of
 119                          Nothing -> Pip.liftIO $ Rand.getStdRandom $ runState $ VP.randomUUID
 120                          Just u ->
 121                                 case VP.readUUID u of
 122                                  Left err -> outputError glob $ Doc.from (show err)
 123                                  Right uuid -> return uuid
 124                 let trusteeKeysPath = global_dir FP.</> "public_keys.jsons"
 125                 trusteeKeys :: [VP.TrusteePublicKey VP.FFC v c] <- runPipeWithError glob $
 126                         Pip.toListM' $ readJSON glob trusteeKeysPath
 127                 forM_ trusteeKeys $ \trusteeKey ->
 128                         case runExcept $ VP.verifyIndispensableTrusteePublicKey trusteeKey of
 129                          Left err -> outputError glob $ Doc.from (show err)
 130                          Right () -> return ()
 131                 let grades = List.nub administratorElection_grades
 132                 unless (List.length grades > 1) $
 133                         outputError glob $ "at least two distinct grades are needed"
 134                 unless (List.length grades == List.length administratorElection_grades) $
 135                         outputError glob $ "indistinct grades: " <>
 136                                 Doc.from (Text.intercalate ", " $ List.nub $
 137                                         administratorElection_grades List.\\ grades)
 138                 let defaultGrade =
 139                         fromMaybe (grades List.!!0)
 140                          administratorElection_defaultGrade
 141                  -- FIXME: put defaultGrade into election.json
 142                 let elec :: VP.Election VP.FFC v c =
 143                         VP.Election
 144                          { VP.election_name        = administratorElection_name
 145                          , VP.election_description = administratorElection_description
 146                          , VP.election_crypto      = administratorElection_crypto
 147                          , VP.election_public_key  = VP.combineIndispensableTrusteePublicKeys trusteeKeys
 148                          , VP.election_questions   = (<$> quests) $ \quest -> VP.Question
 149                                  { question_text    = quest
 150                                  , question_choices = grades
 151                                  , question_mini    = 1
 152                                  , question_maxi    = 1
 153                                  }
 154                          , VP.election_uuid
 155                          , VP.election_version = Just administratorElection_version
 156                          , VP.election_hash    = VP.hashElection elec
 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.election_hash 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         loadElection glob (global_dir FP.</> "election.json") $
 177          \(_elec :: VP.Election VP.FFC v c) -> do
 178                 keys :: [VP.TrusteePublicKey VP.FFC v c]
 179                  <- runPipeWithError glob $ Pip.toListM' $
 180                         readJSON glob $ global_dir FP.</> "public_keys.jsons"
 181                 decs <- runPipeWithError glob $ Pip.toListM' $
 182                         readJSON glob $ global_dir FP.</> "partial_decryptions.jsons"
 183                 outputInfo glob $ "computing encrypted tally from ballots"
 184                 (encTally, numBallots) <- runPipeWithError glob $
 185                         Pip.fold'
 186                          (flip VP.insertEncryptedTally)
 187                          VP.emptyEncryptedTally id $
 188                                 readJSON glob $ global_dir FP.</> "ballots.jsons"
 189                 outputInfo glob $ "decrypting tally using trustees' decryption shares"
 190                 case runExcept $ VP.proveTally
 191                          (encTally :: VP.EncryptedTally VP.FFC v c, numBallots) decs
 192                          (VP.combineIndispensableDecryptionShares (VP.trustee_PublicKey <$> keys)) of
 193                  Left err -> outputError glob $ Doc.from (show err)
 194                  Right tally -> do
 195                         let resultPath = global_dir FP.</> "result.json"
 196                         saveJSON glob resultPath tally
 197                         outputInfo glob $ "tally generated in " <> Doc.from resultPath