Registrar.hs

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

import Control.Arrow (left)
import Control.Applicative (Applicative(..))
import Control.Monad (Monad(..), forM, forM_, join, void)
import Control.Monad.Trans.Class (MonadTrans(..))
import Control.Monad.Trans.Maybe (MaybeT(..))
import Control.Monad.Trans.State.Strict (runState, runStateT)
import Data.Bool
import Data.ByteString (ByteString)
import Data.Either (Either(..))
import Data.Foldable (Foldable, foldMap, length)
import Data.Function (($), (.), flip)
import Data.Functor ((<$>))
import Data.Int (Int)
import Data.Maybe (Maybe(..), maybe, fromMaybe)
import Data.Ord (Ord(..))
import Data.Proxy (Proxy(..))
import Data.Semigroup (Semigroup(..))
import Data.String (String)
import Data.Text (Text)
import GHC.Natural (minusNatural, minusNaturalMaybe)
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.ByteString as BS
import qualified Data.ByteString.Char8 as BS8
import qualified Data.ByteString.Lazy as BSL
import qualified Data.List as List
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TL
import qualified Data.Text.Lazy.IO as TL
import qualified Data.Time as Time
import qualified Lens.Family as Lens
import qualified Lens.Family.State.Strict 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 as Pip
import qualified Pipes.Safe.Prelude as Pip
import qualified Pipes.Text as PipText
import qualified Pipes.Text.Encoding as PipText
import qualified Pipes.Text.IO as PipText
import qualified Symantic.Document as Doc
import qualified System.FilePath as FP
import qualified System.IO as IO
import qualified System.Posix as Posix
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_uuid   :: VP.UUID
 } deriving (Show)

api_registrar =
	"Commands for a registrar."
	`helps`
	command "registrar" $
		rule "PARAMS"
		 (Registrar_Params
			 <$> api_param_crypto
			 <*> 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{..} o@Registrar_Params{..} cred =
	return $
		VP.reify registrar_election_crypto $ \(_::Proxy c) ->
			VP.nat $ VP.publicKey $
				VP.credentialSecretKey @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
 Global_Params{..}
 o@Registrar_Params{..} =
	run_count :!:
	run_file
	where
	run_count count =
		run_credentials $
			let i0 = firstIdentity count in
			(Right <$>) $ Pip.each $
				T.pack . show
				 <$> [i0 .. (i0+count)`minusNatural`1]
	run_file 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 $
				((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 0o400 (baseFile FP.<.>"privcreds")
					 )
					 >-> Pip.mapM (\(ident, cred) ->
						let secKey = VP.credentialSecretKey @c registrar_election_uuid cred in
						let pubKey = VP.publicKey secKey in
						return (ident, pubKey))
					 >-> Pip.tee (
						Pip.map (\(ident, pubKey) ->
							[ident, " ", VP.hexHash $ VP.bytesNat pubKey]
						 )
						 >-> writeFileLn 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 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