Voter.hs

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

import Control.Applicative (Applicative(..), Alternative(..))
import Control.Monad (Monad(..), join, unless, void, when)
import Control.Monad.Trans.Maybe (MaybeT(..))
import Control.Monad.Trans.Except (runExcept)
import Control.Monad.Trans.State.Strict (runStateT)
import Data.Bool
import Data.Either (Either(..))
import Data.Eq (Eq(..))
import Data.Foldable (sum)
import Data.Function (($))
import Data.Functor ((<$>))
import Data.Maybe (Maybe(..))
import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
import Data.String (String)
import Data.Text (Text)
import Numeric.Natural (Natural)
import Prelude (Num(..))
import Symantic.CLI as CLI
import System.IO (FilePath)
import Text.Show (Show(..))
import qualified Data.Aeson as JSON
import qualified Data.ByteString.Lazy.Char8 as BSL8
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.Directory as IO
import qualified System.FilePath as FP
import qualified System.IO as IO
import qualified System.Random as Rand
import qualified Voting.Protocol as VP
import qualified Voting.Protocol.Utils as VP

import Hjugement.CLI.Utils

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

api_voter =
	"Commands for a voter."
	`helps`
	command "voter" $
		api_voter_vote
		<!> api_voter_verify
		<!> api_help False
run_voter globParams =
	run_voter_vote globParams
	:!: run_voter_verify globParams
	:!: run_help api_voter

-- ** vote
data VoterVote_Params = VoterVote_Params
 {   voterVote_privcred :: VP.Credential
 ,   voterVote_url      :: FilePath
 ,   voterVote_grades   :: [Text]
 } deriving (Show)

api_voter_vote =
	"Cast a vote on an election."
	`helps`
	command "vote" $
		rule "PARAMS"
		 (VoterVote_Params
			 <$> api_param_privcred
			 <*> api_param_url
			 <*> api_param_grades)
		<?> response @(Maybe ())
	where
	api_param_privcred =
		"Voter's private credential."
		`helps`
		requiredTag "privcred" (var "CREDENTIAL")
	api_param_grades =
		"The grades to evaluate the choices, from the lowest to the highest."
		`helps`
		many1Tag (TagLong "grade") $
			var @Text "STRING"

run_voter_vote
 glob@Global_Params{..}
 VoterVote_Params{..} = runMaybeT $ do
	loadElection glob (voterVote_url FP.</> "election.json") $
	 \(elec@VP.Election{..} :: VP.Election VP.FFC v c) -> do
		outputInfo glob $ "Voted"<>Doc.from (show voterVote_grades)
		votes <- VP.isoZipWithM
		 (outputError glob $ "Mismatching number of cast grades ("<>
			Doc.from (List.length voterVote_grades)<>
			") and choices ("<>
			Doc.from (List.length election_questions)<>
			")")
		 (\VP.Question{..} grade -> do
			let bools = (grade ==) <$> question_choices
			let boolSum = sum $ (<$> bools) $ \b -> if b then 1 else 0 :: Natural
			unless (boolSum == 1) $
				outputError glob $
					"The election does not allow to cast a grade named: "<>Doc.from grade<>"\n"<>
					"Allowed grades are: "<>Doc.from (Text.intercalate ", " question_choices)
			return bools)
		 election_questions
		 voterVote_grades
		outputInfo glob $ Doc.from (show votes)
		let (secKey :: VP.SecretKey VP.FFC c) =
			VP.credentialSecretKey election_uuid voterVote_privcred
		ballot <- join $ Pip.liftIO $
			Rand.getStdRandom $ \gen ->
				case runExcept $ (`runStateT` gen) $
				 VP.encryptBallot elec (Just secKey) votes of
				 Left err -> (outputError glob $ Doc.from (show err), gen)
				 Right (ballot, gen') -> (return ballot, gen')
		Pip.liftIO $ BSL8.putStrLn $ JSON.encode ballot

-- ** verify
data VoterVerify_Params = VoterVerify_Params
 {   voterVerify_url :: FilePath
 } deriving (Show)

api_voter_verify =
	"Cast a vote on an election."
	`helps`
	command "verify" $
		rule "PARAMS"
		 (VoterVerify_Params
			 <$> api_param_url)
		<?> response @(Maybe ())

run_voter_verify
 glob@Global_Params{..}
 VoterVerify_Params{..} = runMaybeT $ do
	loadElection glob (voterVerify_url FP.</> "election.json") $
	 \(elec@VP.Election{..} :: VP.Election VP.FFC v c) -> do
		outputInfo glob $ "verifying ballots"
		(fails :: Natural, (encTally :: VP.EncryptedTally VP.FFC v c, _numBallots))
		 <- runPipeWithError glob $
			Pip.foldM'
			 (\(fails, acc@(_, numBallots)) ballot@VP.Ballot{..} -> do
				let ballotNum = numBallots + fails
				outputDebug glob
				 { global_stderr_prepend_carriage = True
				 , global_stderr_append_newline   = False
				 } $
					"checking ballot #"<>Doc.from ballotNum
				let globError = glob{global_stderr_prepend_newline = Verbosity_Debug <= global_verbosity}
				case ballot_signature of
				 Nothing -> do
					void $ runMaybeT $ outputError globError $
						"ballot #"<>Doc.from ballotNum<>" has no signature"
					return (fails+1, acc)
				 Just{} ->
					if VP.verifyBallot elec ballot
					then return (fails, VP.insertEncryptedTally ballot acc)
					else do
						void $ runMaybeT $ outputError globError $
							"ballot #"<>Doc.from ballotNum<>" has an invalid signature"
						return (fails+1, acc)
			 )
			 (return (0, VP.emptyEncryptedTally))
			 return $
				readJSON glob $ voterVerify_url FP.</> "ballots.jsons"
		when (Verbosity_Debug <= global_verbosity) $
			Pip.liftIO $ output $ OnHandle IO.stderr (Doc.newline::String)
		when (0 < fails) empty
		let resultPath = voterVerify_url FP.</> "result.json"
		hasResult <- Pip.liftIO $ IO.doesPathExist resultPath
		if not hasResult
		 then do
			outputWarning glob "no tally to check"
		 else do
			tally :: VP.Tally VP.FFC v c <- loadJSON glob resultPath
			outputInfo glob $ "decrypting tally using trustees' decryption shares"
			trustees :: [VP.TrusteePublicKey VP.FFC v c]
			 <- runPipeWithError glob $ Pip.toListM' $
				readJSON glob $ voterVerify_url FP.</> "public_keys.jsons"
			let trustPubKeys = VP.trustee_PublicKey <$> trustees
			decs <- runPipeWithError glob $ Pip.toListM' $
				readJSON glob $ voterVerify_url FP.</> "partial_decryptions.jsons"
			outputInfo glob $ "verifying tally"
			case runExcept $ do
				VP.verifyDecryptionShareByTrustee encTally trustPubKeys decs
				VP.verifyTally tally (VP.combineIndispensableDecryptionShares trustPubKeys)
			 of
			 Left err -> outputError glob $ Doc.from (show err)
			 Right () -> return ()