Trustee.hs

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

import Control.Applicative (Applicative(..))
import Control.Monad (Monad(..))
import Control.Monad.Trans.Maybe (MaybeT(..))
import Control.Monad.Trans.State.Strict (runState)
import Data.Bool
import Data.Eq (Eq(..))
import Data.Foldable (null)
import Data.Function (($), (.), id, flip)
import Data.Functor ((<$>))
import Data.Maybe (Maybe(..))
import Data.Ord (Ord(..))
import Data.Proxy (Proxy(..))
import Data.Semigroup (Semigroup(..))
import GHC.Prim (coerce)
import Pipes ((>->))
import Symantic.CLI as CLI
import Text.Show (Show(..))
import System.IO (FilePath)
import qualified Data.List as List
import qualified Data.Text as T
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

-- * trustee
data Trustee_Params = Trustee_Params
 { trustee_crypto  :: VP.FFC
 , trustee_version :: VP.Version
 } deriving (Show)

api_trustee =
	"Commands for a trustee."
	`helps`
	command "trustee" $
		rule "TrusteeParams"
		 (Trustee_Params
			 <$> api_param_crypto
			 <*> api_param_version
		 ) <?> (
			api_trustee_generate <!>
			api_trustee_decrypt
		 )
		<!> api_help False

run_trustee globParams =
	(\params ->
		run_trustee_generate globParams params :!:
		run_trustee_decrypt  globParams params
	 ) :!:
	run_help api_trustee

-- ** generate
api_trustee_generate =
 "Run by a trustee to generate a share of an election key.\
 \ Such a share consists of a private key and a public key with a certificate.\
 \ Generated files are stored in the current directory with\
 \ a name that starts with "<>fileRef "ID"<>",\
 \ where "<>fileRef "ID"<>" is a short fingerprint of the public key.\
 \ The private key is stored in "<>fileRef "ID.privkey"<>" and must be\
 \ secured by the trustee. The public key is stored in "<>fileRef "ID.pubkey"<>" and must\
 \ be sent to the election administrator."
	`helps`
	command "generate" $
		response @()
run_trustee_generate
 glob@Global_Params{..}
 Trustee_Params{..} =
	VP.reify trustee_version $ \(_v::Proxy v) -> do
	VP.reify trustee_crypto $ \(_c::Proxy c) -> do
		(secKey, pubKey) <- Pip.liftIO $ Rand.getStdRandom $ runState $ do
			secKey <- VP.randomSecretKey @VP.FFC @c
			pubKey :: VP.TrusteePublicKey VP.FFC v c
			 <- VP.proveIndispensableTrusteePublicKey secKey
			return (secKey, pubKey)
		let pubIdent =
			T.unpack $ T.toUpper $ T.take 8 $
			VP.hexSHA256 $ VP.bytesNat $
			VP.trustee_PublicKey pubKey
		runPipe $ do
			Pip.each [pubIdent] >-> pipeInfo glob (\ident ->
				Doc.from $
				"generated trustee keypair "<>ident<>
				" in "<>(global_dir FP.</> ident)<>".{privkey,pubkey}"
			 ) >-> Pip.drain
			Pip.each [secKey] >-> writeJSON glob 0o400 (global_dir FP.</> pubIdent FP.<.>"privkey")
			Pip.each [pubKey] >-> writeJSON glob 0o444 (global_dir FP.</> pubIdent FP.<.>"pubkey")
		return ()

-- ** decrypt
data TrusteeDecrypt_Params = TrusteeDecrypt_Params
 {   trusteeDecrypt_privkey :: FilePath
 ,   trusteeDecrypt_url     :: FilePath
 } deriving (Show)

api_trustee_decrypt =
	"This command is run by each trustee to perform a partial decryption."
	`helps`
	command "decrypt" $
		rule "TrusteeDecryptParams"
		 (TrusteeDecrypt_Params
			 <$> api_param_privkey
			 <*> api_param_url)
		<?> response @(Maybe (VP.DecryptionShare VP.FFC VP.StableVersion ()))
	where
	api_param_privkey =
		"Read private key from file "<>ref"FILE"<>"."
		`helps`
		requiredTag "privkey" (var "FILE")

run_trustee_decrypt
 glob@Global_Params{..}
 Trustee_Params{..}
 TrusteeDecrypt_Params{..} =
	VP.reify trustee_version $ \(_v::Proxy v) -> do
	VP.reify trustee_crypto $ \(_crypto::Proxy c) -> runMaybeT $ do
		(secKey::VP.E VP.FFC c) <- loadJSON glob trusteeDecrypt_privkey
		let pubKey = VP.publicKey secKey
		let trusteeKeysPath = trusteeDecrypt_url FP.</> "public_keys.jsons"
		outputInfo glob "check that the public key is amongst the public keys of the election"
		keys :: [VP.TrusteePublicKey VP.FFC v c] <- runPipeWithError glob $
			Pip.toListM' $
				readJSON glob trusteeKeysPath
				 >-> Pip.filter ((pubKey ==) . VP.trustee_PublicKey)
		case () of
		 () | null keys -> outputError glob $
			"the public key associated with the given secret key "<>
			"is not within the list of public trustee keys of the election.\n"<>
			Doc.ul
			 [ "List of trustees' public keys: "<>Doc.from trusteeKeysPath
			 , "Trustee's public key: "<>Doc.from (show (VP.nat pubKey))
			 ]<>"\n"
		 () | List.length keys > 1 -> outputError glob $
			"the public key associated with the given secret key "<>
			"appears more than one time in the list of public trustee keys of the election.\n"<>
			Doc.ul
			 [ "List of trustees' public keys: "<>Doc.from trusteeKeysPath
			 , "Trustee's public key: "<>Doc.from (show (VP.nat pubKey))
			 ]<>"\n"
		 () -> do
			outputInfo glob "tally the encrypted ballots"
			-- FIXME: actually support fetching through an URL
			let ballotsPath = trusteeDecrypt_url FP.</> "ballots.jsons"
			(encTally, _numBallots) <- runPipeWithError glob $
				Pip.fold'
				 (flip VP.insertEncryptedTally)
				 VP.emptyEncryptedTally id $
					readJSON glob ballotsPath
			decShare :: VP.DecryptionShare VP.FFC v c
			 <- Pip.liftIO $
				Rand.getStdRandom $ runState $
					VP.proveDecryptionShare encTally secKey
			return (coerce decShare :: VP.DecryptionShare VP.FFC VP.StableVersion ())