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  ,   administratorElection_version      :: VP.Version
  63  } deriving (Show)
  64
  65 api_administrator_election =
  66         "This command reads and checks the trustees' public keys in "<>fileRef"public_keys.jsons"<>".\
  67  \ From which it computes the global election public key\
  68  \ put it into an "<>fileRef"election.json"<>" file \
  69  \ with the infos of the vote given here."
  70         `helps`
  71         command "election" $
  72                 rule "PARAMS"
  73                  (AdministratorElection_Params
  74                          <$> api_param_crypto
  75                          <*> api_param_name
  76                          <*> api_param_description
  77                          <*> api_option_uuid
  78                          <*> api_param_grades
  79                          <*> api_param_defaultGrade
  80                          <*> api_param_version)
  81                 <?> api_quests
  82                 <.> response @(Maybe ())
  83         where
  84         api_param_name =
  85                 "Name of the election."
  86                 `help`
  87                 defaultTag "name" "" (var "STRING")
  88         api_param_description =
  89                 "Description of the election."
  90                 `help`
  91                 defaultTag "description" "" (var "STRING")
  92         api_option_uuid =
  93                 "UUID of the election."
  94                 `help`
  95                 optionalTag "uuid" $
  96                         var "UUID"
  97         api_quests =
  98                 "Some questions."
  99                 `help`
 100                 many1 (var @Text "STRING")
 101         api_param_grades =
 102                 "The grades to evaluate the choices, from the lowest to the highest."
 103                 `helps`
 104                 many1Tag (TagLong "grade") $
 105                         var @Text "STRING"
 106         api_param_defaultGrade =
 107                 "The grade used when no grade is given by a voter.\n"<>
 108                 "Defaults to the lowest grade."
 109                 `helps`
 110                 optionalTag (TagLong "default-grade") $
 111                         var @Text "STRING"
 112
 113 run_administrator_election
 114  glob@Global_Params{..}
 115  AdministratorElection_Params{..}
 116  quests =
 117         VP.reify administratorElection_version $ \(_v::Proxy v) ->
 118         VP.reify administratorElection_crypto $ \(_c::Proxy c) -> runMaybeT $ do
 119                 election_uuid <-
 120                         case administratorElection_uuid of
 121                          Nothing -> Pip.liftIO $ Rand.getStdRandom $ runState $ VP.randomUUID
 122                          Just u ->
 123                                 case VP.readUUID u of
 124                                  Left err -> outputError glob $ Doc.from (show err)
 125                                  Right uuid -> return uuid
 126                 let trusteeKeysPath = global_dir FP.</> "public_keys.jsons"
 127                 trusteeKeys :: [VP.TrusteePublicKey VP.FFC v c] <- runPipeWithError glob $
 128                         Pip.toListM' $ readJSON glob trusteeKeysPath
 129                 forM_ trusteeKeys $ \trusteeKey ->
 130                         case runExcept $ VP.verifyIndispensableTrusteePublicKey trusteeKey of
 131                          Left err -> outputError glob $ Doc.from (show err)
 132                          Right () -> return ()
 133                 let grades = List.nub administratorElection_grades
 134                 unless (List.length grades > 1) $
 135                         outputError glob $ "at least two distinct grades are needed"
 136                 unless (List.length grades == List.length administratorElection_grades) $
 137                         outputError glob $ "indistinct grades: " <>
 138                                 Doc.from (Text.intercalate ", " $ List.nub $
 139                                         administratorElection_grades List.\\ grades)
 140                 let defaultGrade =
 141                         fromMaybe (grades List.!!0)
 142                          administratorElection_defaultGrade
 143                  -- FIXME: put defaultGrade into election.json
 144                 let elec :: VP.Election VP.FFC v c =
 145                         VP.Election
 146                          { VP.election_name        = administratorElection_name
 147                          , VP.election_description = administratorElection_description
 148                          , VP.election_crypto      = administratorElection_crypto
 149                          , VP.election_public_key  = VP.combineIndispensableTrusteePublicKeys trusteeKeys
 150                          , VP.election_questions   = (<$> quests) $ \quest -> VP.Question
 151                                  { question_text    = quest
 152                                  , question_choices = grades
 153                                  , question_mini    = 1
 154                                  , question_maxi    = 1
 155                                  }
 156                          , VP.election_uuid
 157                          , VP.election_version = Just administratorElection_version
 158                          , VP.election_hash    = VP.hashElection elec
 159                          }
 160                 saveJSON glob (global_dir FP.</> "election.json") elec
 161                 outputInfo glob $
 162                         "created election with "<>Doc.from (show election_uuid)<>
 163                         " and "<>Doc.from (show (VP.base64SHA256 (BSL.toStrict (JSON.encode elec))))
 164
 165 -- ** tally
 166 api_administrator_tally =
 167  "Tally an election using the decryption shares gathered from trustees\
 168  \ in "<>fileRef "partial_decryptions.jsons"<>".\
 169  \ The result is saved in "<>fileRef "result.json"<>".\n\
 170  \ It contains the decryption shares,\
 171  \ so "<>fileRef "partial_decryptions.jsons"<>" can be discarded afterwards."
 172         `helps`
 173         command "tally" $
 174                 response @(Maybe ())
 175
 176 run_administrator_tally
 177  glob@Global_Params{..} = runMaybeT $ do
 178         loadElection glob (global_dir FP.</> "election.json") $
 179          \(_elec :: VP.Election VP.FFC v c) -> do
 180                 keys <- runPipeWithError glob $ Pip.toListM' $
 181                         readJSON glob $ global_dir FP.</> "public_keys.jsons"
 182                 decs <- runPipeWithError glob $ Pip.toListM' $
 183                         readJSON glob $ global_dir FP.</> "partial_decryptions.jsons"
 184                 outputInfo glob $ "computing encrypted tally from ballots"
 185                 (encTally, numBallots) <- runPipeWithError glob $
 186                         Pip.fold'
 187                          (flip VP.insertEncryptedTally)
 188                          VP.emptyEncryptedTally id $
 189                                 readJSON glob $ global_dir FP.</> "ballots.jsons"
 190                 outputInfo glob $ "decrypting tally using trustees' decryption shares"
 191                 case runExcept $ VP.proveTally
 192                          (encTally :: VP.EncryptedTally VP.FFC v c, numBallots) decs
 193                          (VP.combineIndispensableDecryptionShares (VP.trustee_PublicKey <$> keys)) of
 194                  Left err -> outputError glob $ Doc.from (show err)
 195                  Right tally -> do
 196                         let resultPath = global_dir FP.</> "result.json"
 197                         saveJSON glob resultPath tally
 198                         outputInfo glob $ "tally generated in " <> Doc.from resultPath