Registrar.hs

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

import Control.Arrow (left)
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.Either (Either(..))
import Data.Function (($), (.))
import Data.Functor ((<$>))
import Data.Maybe (Maybe(..))
import Data.Proxy (Proxy(..))
import Data.Semigroup (Semigroup(..))
import GHC.Natural (minusNatural)
import Numeric.Natural (Natural)
import Pipes ((>->))
import Prelude (logBase, ceiling, Num(..), (/), (^), fromIntegral, Double)
import Symantic.CLI as CLI
import Text.Show (Show(..))
import qualified Data.List as List
import qualified Data.Text as T
import qualified Data.Time as Time
import qualified Lens.Family as Lens
import qualified Pipes as Pip
import qualified Pipes.ByteString as PipBS
import qualified Pipes.Group as Pip
import qualified Pipes.Prelude as Pip
import qualified Pipes.Safe.Prelude as Pip
import qualified Pipes.Text as PipText
import qualified Pipes.Text.Encoding as PipText
import qualified Symantic.Document as Doc
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 Hjugement.CLI.Utils

-- ** Type 'Registrar_Params'
data Registrar_Params = Registrar_Params
 {   registrar_election_crypto  :: VP.FFC
 ,   registrar_election_version :: VP.Version
 ,   registrar_election_uuid    :: VP.UUID
 } deriving (Show)

api_registrar =
	"Commands for a registrar."
	`helps`
	command "registrar" $
		rule "PARAMS"
		 (Registrar_Params
			 <$> api_param_crypto
			 <*> api_param_version
			 <*> api_param_uuid)
		<?> (
			api_registrar_credentials <!>
			api_registrar_pubkey)
		<!> api_help False
run_registrar globParams =
	(\params ->
		run_registrar_credentials globParams params :!:
		run_registrar_pubkey globParams params
	) :!:
	run_help api_registrar

api_registrar_pubkey =
	"Derive the public key associated to a specific "<>ref"PRIVATE_CRED"<>"."
	`helps`
	command "pubkey" $
		var "PRIVATE_CRED"
		<.> response @Natural
run_registrar_pubkey
 Global_Params{..}
 Registrar_Params{..}
 cred =
	return $
		VP.reify registrar_election_crypto $ \(_::Proxy c) ->
			VP.nat $ VP.publicKey $
				VP.credentialSecretKey @VP.FFC @c registrar_election_uuid cred

api_registrar_credentials =
	"Generate voters' credentials, either "<>ref "COUNT"<>" sequential identities\
 \ or for all identities on each line of "<>ref "FILE"<>".\
 \\nThree files are created:\n"<>
 Doc.ul
  [ ref"<timestamp>.privcreds" <>
    " listing the secret key of each voter,\
    \ each line formatted as: <Registrar>"<>Doc.space<>"<Credential>.\
    \ It "<>Doc.bold "must be destroyed"<>" after dispatching\
    \ the credentials to the voters."
  , ref"<timestamp>.pubcreds" <>
    " listing the public key of each voter,\
    \ each line formatted as: <PublicKey>.\
    \ It "<>Doc.bold "must be sent"<>" to the election administrator.\
    \ Note that the entries are numerically sorted\
    \ which forgets whose credential the key belongs to."
  , ref"<timestamp>.hashcreds" <>
    " listing the hash of the credential of each voter,\
    \ each line formatted as: <Registrar>"<>Doc.space<>"<SHA256>.\
    \ It is used by the hotline to update the public key on the web server."
  ] `helps`
	command "credentials" $
		(var @Natural "COUNT" <!>
		var @IO.FilePath "FILE")
		<.> response @(Maybe ())
run_registrar_credentials
 glob@Global_Params{..}
 Registrar_Params{..} =
	run_count :!:
	run_file
	where
	run_count count = do
		outputInfo glob $ "generating credentials for "<>Doc.from count<>" voters"
		run_credentials $
			let i0 = firstIdentity count in
			(Right <$>) $ Pip.each $
				T.pack . show
				 <$> [i0 .. (i0+count)`minusNatural`1]
	run_file file = do
		outputInfo glob $ "generating credentials for voters listed in "<>Doc.from file
		run_credentials $
			let bytes = Pip.withFile file IO.ReadMode PipBS.fromHandle in
			let idents =
				Lens.view PipText.lines $
				Lens.view (PipText.utf8 . PipText.eof) bytes in
			Pip.concats idents
	run_credentials identsProd =
		VP.reify registrar_election_crypto $ \(_crypto::Proxy c) -> runMaybeT $ do
			now <- Pip.liftIO $ Time.getCurrentTime
			let timestamp = Time.formatTime Time.defaultTimeLocale "%s" now
			let baseFile = global_dir FP.</> timestamp
			pubKeys <- runPipeWithError glob $
				((left (\_p -> "UTF-8 decoding failed") <$>) <$>) $
				Pip.toListM' $
					identsProd
					 >-> Pip.mapM (\ident -> do
						cred <- Pip.liftIO $
							Rand.getStdRandom $ runState $
							VP.randomCredential
						return (ident, cred)
					 )
					 >-> Pip.tee (
						Pip.map (\(ident, VP.Credential cred) -> [ident, " ", cred])
						 >-> writeFileLn glob 0o400 (baseFile FP.<.>"privcreds")
					 )
					 >-> Pip.mapM (\(ident, cred) ->
						let secKey = VP.credentialSecretKey @VP.FFC @c registrar_election_uuid cred in
						let pubKey = VP.publicKey secKey in
						return (ident, pubKey))
					 >-> Pip.tee (
						Pip.map (\(ident, pubKey) ->
							[ident, " ", VP.hexSHA256 $ VP.bytesNat pubKey]
						 )
						 >-> writeFileLn glob 0o444 (baseFile FP.<.>"hashcreds")
					 )
					 >-> Pip.map (\(_ident, pubKey) -> pubKey)
			runPipe $
				Pip.each (List.sort pubKeys)
				 -- NOTE: numerical sort on Natural (not lexicographic on String)
				 -- which forgets in this file the relationship between
				 -- the voters' identity and public key.
				 -- Unfortunately this requires to accumulates all the pubKey in memory.
				 >-> Pip.map (\pubKey -> [T.pack (show (VP.nat pubKey))])
				 >-> writeFileLn glob 0o444 (baseFile FP.<.>"pubcreds")
			return ()

-- | @('firstIdentity' numIdentities)@ returns @(10'^'i0)@ such that
-- @(10'^'i0 '+' numIdentities '<=' 10'^'(i0'+'1))@,
-- that is to say it returns the lowest identity such that
-- the next @numIdentities@ identities
-- all have the same number of digits.
firstIdentity :: Natural -> Natural
firstIdentity n =
	((10::Natural) ^) $ (ceiling::Double -> Natural) $
	logBase 10 $ (fromIntegral n) / 9