Administrator.hs

{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StrictData #-}
{-# OPTIONS_GHC -Wno-missing-signatures #-}
module Hjugement.CLI.Administrator where

import Control.Applicative (Applicative(..))
import Control.Monad (Monad(..), forM_, unless)
import Control.Monad.Trans.Except (runExcept)
import Control.Monad.Trans.Maybe (MaybeT(..))
import Control.Monad.Trans.State.Strict (runState)
import Data.Bool
import Data.Either (Either(..))
import Data.Eq (Eq(..))
import Data.Function (($), id, flip)
import Data.Functor ((<$>))
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Ord (Ord(..))
import Data.Proxy (Proxy(..))
import Data.Semigroup (Semigroup(..))
import Data.Text (Text)
import Symantic.CLI as CLI
import Text.Show (Show(..))
import qualified Data.Aeson as JSON
import qualified Data.ByteString.Lazy as BSL
import qualified Data.List as List
import qualified Data.Text as Text
import qualified Pipes as Pip
import qualified Pipes.Prelude as Pip
import qualified Symantic.Document as Doc
import qualified System.FilePath as FP
import qualified System.Random as Rand
import qualified Voting.Protocol as VP

import Hjugement.CLI.Utils

-- * administrator
data Administrator_Params = Administrator_Params
 {
 } deriving (Show)

api_administrator =
	"Commands for an administrator."
	`helps`
	command "administrator" $
		api_administrator_election
		<!> api_administrator_tally
		<!> api_help False
run_administrator globParams =
	run_administrator_election globParams
	:!: run_administrator_tally globParams
	:!: run_help api_administrator

-- ** election
data AdministratorElection_Params = AdministratorElection_Params
 {   administratorElection_crypto       :: VP.FFC
 ,   administratorElection_name         :: Text
 ,   administratorElection_description  :: Text
 ,   administratorElection_uuid         :: Maybe Text
 ,   administratorElection_grades       :: [Text]
 ,   administratorElection_defaultGrade :: Maybe Text
 } deriving (Show)

api_administrator_election =
	"This command reads and checks the trustees' public keys in "<>fileRef"public_keys.jsons"<>".\
 \ From which it computes the global election public key\
 \ put it into an "<>fileRef"election.json"<>" file \
 \ with the infos of the vote given here."
	`helps`
	command "election" $
		rule "PARAMS"
		 (AdministratorElection_Params
			 <$> api_param_crypto
			 <*> api_param_name
			 <*> api_param_description
			 <*> api_option_uuid
			 <*> api_param_grades
			 <*> api_param_defaultGrade)
		<?> api_quests
		<.> response @(Maybe ())
	where
	api_param_name =
		"Name of the election."
		`help`
		defaultTag "name" "" (var "STRING")
	api_param_description =
		"Description of the election."
		`help`
		defaultTag "description" "" (var "STRING")
	api_option_uuid =
		"UUID of the election."
		`help`
		optionalTag "uuid" $
			var "UUID"
	api_quests =
		"Some questions."
		`help`
		many1 (var @Text "STRING")
	api_param_grades =
		"The grades to evaluate the choices, from the lowest to the highest."
		`helps`
		many1Tag (TagLong "grade") $
			var @Text "STRING"
	api_param_defaultGrade =
		"The grade used when no grade is given by a voter.\n"<>
		"Defaults to the lowest grade."
		`helps`
		optionalTag (TagLong "default-grade") $
			var @Text "STRING"

run_administrator_election
 glob@Global_Params{..}
 AdministratorElection_Params{..}
 quests =
	VP.reify administratorElection_crypto $ \(_crypto::Proxy c) -> runMaybeT $ do
		election_uuid <-
			case administratorElection_uuid of
			 Nothing -> Pip.liftIO $ Rand.getStdRandom $ runState $ VP.randomUUID
			 Just u ->
				case VP.readUUID u of
				 Left err -> outputError glob $ Doc.from (show err)
				 Right uuid -> return uuid
		let trusteeKeysPath = global_dir FP.</> "public_keys.jsons"
		trusteeKeys :: [VP.TrusteePublicKey c] <- runPipeWithError glob $
			Pip.toListM' $ readJSON glob trusteeKeysPath
		forM_ trusteeKeys $ \trusteeKey ->
			case runExcept $ VP.verifyIndispensableTrusteePublicKey trusteeKey of
			 Left err -> outputError glob $ Doc.from (show err)
			 Right () -> return ()
		let grades = List.nub administratorElection_grades
		unless (List.length grades > 1) $
			outputError glob $ "at least two distinct grades are needed"
		unless (List.length grades == List.length administratorElection_grades) $
			outputError glob $ "indistinct grades: " <>
				Doc.from (Text.intercalate ", " $ List.nub $
					administratorElection_grades List.\\ grades)
		let defaultGrade =
			fromMaybe (grades List.!!0)
			 administratorElection_defaultGrade
		 -- FIXME: put defaultGrade into election.json
		let elec =
			VP.Election
			 { VP.election_name        = administratorElection_name
			 , VP.election_description = administratorElection_description
			 , VP.election_crypto      = VP.ElectionCrypto_FFC
				 { electionCrypto_FFC_params    = administratorElection_crypto
				 , electionCrypto_FFC_PublicKey = VP.combineIndispensableTrusteePublicKeys trusteeKeys
				 }
			 , VP.election_questions = (<$> quests) $ \quest -> VP.Question
				 { question_text    = quest
				 , question_choices = grades
				 , question_mini    = 1
				 , question_maxi    = 1
				 }
			 , VP.election_uuid
			 , VP.election_hash = VP.Base64SHA256 ""
			 }
		saveJSON glob (global_dir FP.</> "election.json") elec
		outputInfo glob $
			"created election with "<>Doc.from (show election_uuid)<>
			" and "<>Doc.from (show (VP.base64SHA256 (BSL.toStrict (JSON.encode elec))))

-- ** tally
api_administrator_tally =
 "Tally an election using the decryption shares gathered from trustees\
 \ in "<>fileRef "partial_decryptions.jsons"<>".\
 \ The result is saved in "<>fileRef "result.json"<>".\n\
 \ It contains the decryption shares,\
 \ so "<>fileRef "partial_decryptions.jsons"<>" can be discarded afterwards."
	`helps`
	command "tally" $
		response @(Maybe ())

run_administrator_tally
 glob@Global_Params{..} = runMaybeT $ do
	rawElec <- loadElection glob $ global_dir FP.</> "election.json"
	VP.reifyElection rawElec $ \(_elec :: VP.Election c) -> do
		keys <- runPipeWithError glob $ Pip.toListM' $
			readJSON glob $ global_dir FP.</> "public_keys.jsons"
		decs <- runPipeWithError glob $ Pip.toListM' $
			readJSON glob $ global_dir FP.</> "partial_decryptions.jsons"
		outputInfo glob $ "computing encrypted tally from ballots"
		(encTally, numBallots) <- runPipeWithError glob $
			Pip.fold'
			 (flip VP.insertEncryptedTally)
			 VP.emptyEncryptedTally id $
				readJSON glob $ global_dir FP.</> "ballots.jsons"
		outputInfo glob $ "decrypting tally using trustees' decryption shares"
		case runExcept $ VP.proveTally
			 (encTally :: VP.EncryptedTally c, numBallots) decs
			 (VP.combineIndispensableDecryptionShares (VP.trustee_PublicKey <$> keys)) of
		 Left err -> outputError glob $ Doc.from (show err)
		 Right tally -> do
			let resultPath = global_dir FP.</> "result.json"
			saveJSON glob resultPath tally
			outputInfo glob $ "tally generated in " <> Doc.from resultPath