packages feed

hjugement-cli 0.0.0.20190721 → 0.0.0.20190815

raw patch · 7 files changed

+444/−239 lines, 7 filesdep ~hjugementdep ~hjugement-protocoldep ~symantic-cli

Dependency ranges changed: hjugement, hjugement-protocol, symantic-cli

Files

hjugement-cli.cabal view
@@ -2,7 +2,7 @@ -- PVP:  +-+------- breaking API changes --       | | +----- non-breaking API additions --       | | | +--- code changes with no API change-version: 0.0.0.20190721+version: 0.0.0.20190815 category: Politic synopsis: Majority Judgment and Helios-C command line tool description:@@ -41,6 +41,7 @@     Hjugement.CLI.Registrar     Hjugement.CLI.Trustee     Hjugement.CLI.Utils+    Hjugement.CLI.Voter     Paths_hjugement_cli   autogen-modules:     Paths_hjugement_cli@@ -72,8 +73,8 @@     -fno-warn-tabs     -- -fhide-source-paths   build-depends:-      hjugement >= 2.0-    , hjugement-protocol >= 0.0.1+      hjugement >= 2.0.2+    , hjugement-protocol >= 0.0.7     , aeson >= 1.3     , base >= 4.6 && < 5     , base64-bytestring >= 1.0@@ -96,7 +97,7 @@     , pipes-text >= 0.0.2.5     , random >= 1.1     , reflection >= 2.1-    , symantic-cli >= 2.4+    , symantic-cli >= 2.4.2     , symantic-document >= 1.5     , terminal-size >= 0.3     , text >= 1.2
src/Hjugement/CLI.hs view
@@ -6,37 +6,23 @@ {-# OPTIONS_GHC -Wno-missing-signatures #-} module Hjugement.CLI where -import Control.Applicative (Applicative(..), Alternative(..)) import Control.Monad (Monad(..)) import Data.Bool-import Data.Either (Either(..))-import Data.Function (($), (.))-import Data.Functor ((<$>), (<$))-import Data.Int (Int)-import Data.List.NonEmpty (NonEmpty(..))-import Data.Maybe (Maybe(..), fromMaybe)-import Data.Ord (Ord(..))+import Data.Function (($)) import Data.Semigroup (Semigroup(..))-import Data.String (String) import Data.Text (Text) import Data.Void (Void) import Symantic.CLI as CLI-import System.Environment (getArgs)-import System.IO (IO, FilePath, print, stderr, putStrLn)-import Text.Show (Show(..))-import Type.Reflection (Typeable)-import qualified Data.Set as Set import qualified Data.Text as Text-import qualified Data.Text.Lazy.IO as TL import qualified Data.Version as Version import qualified Paths_hjugement_cli as Hjugement import qualified Symantic.Document as Doc-import qualified System.IO as IO  import Hjugement.CLI.Utils import Hjugement.CLI.Administrator import Hjugement.CLI.Registrar import Hjugement.CLI.Trustee+import Hjugement.CLI.Voter  progname :: Text progname = "hjugement"@@ -55,11 +41,13 @@ 	rule "AGENT" $ 		api_administrator <!> 		api_trustee <!>-		api_registrar+		api_registrar <!>+		api_voter run_agent params = 	run_administrator params :!: 	run_trustee params :!:-	run_registrar params+	run_registrar params :!:+	run_voter params  api_version = 	"Print the version."
src/Hjugement/CLI/Administrator.hs view
@@ -4,67 +4,31 @@ {-# OPTIONS_GHC -Wno-missing-signatures #-} module Hjugement.CLI.Administrator where -import Control.Applicative (Applicative(..), Alternative(..))-import Control.Monad (Monad(..), forM, forM_, join, unless, void)-import Control.Monad.Trans.Class (MonadTrans(..))+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, runStateT)-import Data.Bits (setBit)+import Control.Monad.Trans.State.Strict (runState) import Data.Bool-import Data.ByteString (ByteString) import Data.Either (Either(..)) import Data.Eq (Eq(..))-import Data.Foldable (Foldable, foldMap, length, null)-import Data.Function (($), (.), id, flip)-import Data.Functor ((<$>), (<$))-import Data.Int (Int)-import Data.Maybe (Maybe(..), maybe, fromMaybe, fromJust)-import Data.Monoid (Monoid(..))+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.String (String) import Data.Text (Text)-import GHC.Natural (minusNatural, minusNaturalMaybe)-import GHC.Prim (coerce)-import Numeric.Natural (Natural)-import Pipes ((>->))-import Prelude (logBase, ceiling, Num(..), (/), (^), fromIntegral, Double) import Symantic.CLI as CLI-import System.IO (IO, FilePath) import Text.Show (Show(..))-import qualified Crypto.Hash as Crypto import qualified Data.Aeson as JSON-import qualified Data.ByteArray as ByteArray-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 Text-import qualified Data.Text.Encoding as Text-import qualified Data.Text.Lazy as TL-import qualified Data.Text.Lazy.Builder as TLB-import qualified Data.Text.Lazy.Builder.Int as TLB-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.Aeson as PipJSON (DecodingError(..))-import qualified Pipes.Aeson.Unchecked as PipJSON-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 @@ -80,9 +44,11 @@ 	`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@@ -109,8 +75,7 @@ 			 <*> api_param_description 			 <*> api_option_uuid 			 <*> api_param_grades-			 <*> api_param_defaultGrade-		 )+			 <*> api_param_defaultGrade) 		<?> api_quests 		<.> response @(Maybe ()) 	where@@ -144,31 +109,37 @@ 			var @Text "STRING"  run_administrator_election- Global_Params{..}- o@AdministratorElection_Params{..}+ glob@Global_Params{..}+ AdministratorElection_Params{..}  quests =-	VP.reify administratorElection_crypto $ \(crypto::Proxy c) -> runMaybeT $ do+	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 $ Doc.from (show err)+				 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 $-			Pip.toListM' $ readJSON trusteeKeysPath+		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 $ "at least two distinct grades are needed"+			outputError glob $ "at least two distinct grades are needed" 		unless (List.length grades == List.length administratorElection_grades) $-			outputError $ "indistinct grades: " <>+			outputError glob $ "indistinct grades: " <> 				Doc.from (Text.intercalate ", " $ List.nub $ 					administratorElection_grades List.\\ grades)-		let defaultGrade = fromMaybe (grades List.!!0) administratorElection_defaultGrade+		let defaultGrade =+			fromMaybe (grades List.!!0)+			 administratorElection_defaultGrade 		 -- FIXME: put defaultGrade into election.json-		saveJSON (global_dir FP.</> "election.json") $-			VP.hashElection VP.Election+		let elec =+			VP.Election 			 { VP.election_name        = administratorElection_name 			 , VP.election_description = administratorElection_description 			 , VP.election_crypto      = VP.ElectionCrypto_FFC@@ -182,6 +153,44 @@ 				 , question_maxi    = 1 				 } 			 , VP.election_uuid-			 , VP.election_hash = VP.hashJSON JSON.Null+			 , VP.election_hash = VP.Base64SHA256 "" 			 }-		outputInfo $ "Created election with "<>Doc.from (show election_uuid)+		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
src/Hjugement/CLI/Registrar.hs view
@@ -1,59 +1,42 @@ {-# 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(..), forM, forM_, join, void)-import Control.Monad.Trans.Class (MonadTrans(..))+import Control.Monad (Monad(..)) import Control.Monad.Trans.Maybe (MaybeT(..))-import Control.Monad.Trans.State.Strict (runState, runStateT)+import Control.Monad.Trans.State.Strict (runState) import Data.Bool-import Data.ByteString (ByteString) import Data.Either (Either(..))-import Data.Foldable (Foldable, foldMap, length)-import Data.Function (($), (.), flip)+import Data.Function (($), (.)) import Data.Functor ((<$>))-import Data.Int (Int)-import Data.Maybe (Maybe(..), maybe, fromMaybe)-import Data.Ord (Ord(..))+import Data.Maybe (Maybe(..)) import Data.Proxy (Proxy(..)) import Data.Semigroup (Semigroup(..))-import Data.String (String)-import Data.Text (Text)-import GHC.Natural (minusNatural, minusNaturalMaybe)+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.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 @@ -72,12 +55,10 @@ 		rule "PARAMS" 		 (Registrar_Params 			 <$> api_param_crypto-			 <*> api_param_uuid-		 )+			 <*> api_param_uuid) 		<?> ( 			api_registrar_credentials <!>-			api_registrar_pubkey-		 )+			api_registrar_pubkey) 		<!> api_help False run_registrar globParams = 	(\params ->@@ -92,7 +73,10 @@ 	command "pubkey" $ 		var "PRIVATE_CRED" 		<.> response @Natural-run_registrar_pubkey Global_Params{..} o@Registrar_Params{..} cred =+run_registrar_pubkey+ Global_Params{..}+ Registrar_Params{..}+ cred = 	return $ 		VP.reify registrar_election_crypto $ \(_::Proxy c) -> 			VP.nat $ VP.publicKey $@@ -124,18 +108,20 @@ 		var @IO.FilePath "FILE") 		<.> response @(Maybe ()) run_registrar_credentials- Global_Params{..}- o@Registrar_Params{..} =+ glob@Global_Params{..}+ Registrar_Params{..} = 	run_count :!: 	run_file 	where-	run_count count =+	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 =+	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 =@@ -143,11 +129,11 @@ 				Lens.view (PipText.utf8 . PipText.eof) bytes in 			Pip.concats idents 	run_credentials identsProd =-		VP.reify registrar_election_crypto $ \(crypto::Proxy c) -> runMaybeT $ do+		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 $+			pubKeys <- runPipeWithError glob $ 				((left (\_p -> "UTF-8 decoding failed") <$>) <$>) $ 				Pip.toListM' $ 					identsProd@@ -159,7 +145,7 @@ 					 ) 					 >-> Pip.tee ( 						Pip.map (\(ident, VP.Credential cred) -> [ident, " ", cred])-						 >-> writeFileLn 0o400 (baseFile FP.<.>"privcreds")+						 >-> writeFileLn glob 0o400 (baseFile FP.<.>"privcreds") 					 ) 					 >-> Pip.mapM (\(ident, cred) -> 						let secKey = VP.credentialSecretKey @c registrar_election_uuid cred in@@ -167,9 +153,9 @@ 						return (ident, pubKey)) 					 >-> Pip.tee ( 						Pip.map (\(ident, pubKey) ->-							[ident, " ", VP.hexHash $ VP.bytesNat pubKey]+							[ident, " ", VP.hexSHA256 $ VP.bytesNat pubKey] 						 )-						 >-> writeFileLn 0o444 (baseFile FP.<.>"hashcreds")+						 >-> writeFileLn glob 0o444 (baseFile FP.<.>"hashcreds") 					 ) 					 >-> Pip.map (\(_ident, pubKey) -> pubKey) 			runPipe $@@ -179,7 +165,7 @@ 				 -- 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")+				 >-> writeFileLn glob 0o444 (baseFile FP.<.>"pubcreds") 			return ()  -- | @('firstIdentity' numIdentities)@ returns @(10'^'i0)@ such that
src/Hjugement/CLI/Trustee.hs view
@@ -1,73 +1,34 @@ {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StrictData #-}+{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-missing-signatures #-} module Hjugement.CLI.Trustee where --- :main --dir /tmp/elec trust --crypto demo/groups/default.json gen--- cat /tmp/elec/*.pubkey >/tmp/elec/public_keys.jsons- import Control.Applicative (Applicative(..))-import Control.Monad (Monad(..), forM, forM_, join, void)-import Control.Monad.Trans.Class (MonadTrans(..))+import Control.Monad (Monad(..)) import Control.Monad.Trans.Maybe (MaybeT(..))-import Control.Monad.Trans.State.Strict (runState, runStateT)-import Data.Bits (setBit)+import Control.Monad.Trans.State.Strict (runState) import Data.Bool-import Data.ByteString (ByteString)-import Data.Either (Either(..)) import Data.Eq (Eq(..))-import Data.Foldable (Foldable, foldMap, length, null)+import Data.Foldable (null) import Data.Function (($), (.), id, flip) import Data.Functor ((<$>))-import Data.Int (Int)-import Data.Maybe (Maybe(..), maybe, fromMaybe)-import Data.Monoid (Monoid(..))+import Data.Maybe (Maybe(..)) 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 GHC.Prim (coerce)-import Numeric.Natural (Natural) import Pipes ((>->))-import Prelude (logBase, ceiling, Num(..), (/), (^), fromIntegral, Double) import Symantic.CLI as CLI import Text.Show (Show(..))-import System.IO (IO, FilePath)-import qualified Crypto.Hash as Crypto-import qualified Data.Aeson as JSON-import qualified Data.ByteArray as ByteArray-import qualified Data.ByteString as BS-import qualified Data.ByteString.Char8 as BS8-import qualified Data.ByteString.Lazy as BSL+import System.IO (FilePath) 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.Builder as TLB-import qualified Data.Text.Lazy.Builder.Int as TLB-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.Aeson as PipJSON (DecodingError(..))-import qualified Pipes.Aeson.Unchecked as PipJSON-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 @@ -112,24 +73,25 @@ 	command "generate" $ 		response @() run_trustee_generate- Global_Params{..}- o@Trustee_Params{..} =-	VP.reify trustee_crypto $ \(crypto::Proxy c) -> do-		keys@(secKey, pubKey) <- Pip.liftIO $ Rand.getStdRandom $ runState $ do+ glob@Global_Params{..}+ Trustee_Params{..} =+	VP.reify trustee_crypto $ \(_crypto::Proxy c) -> do+		(secKey, pubKey) <- Pip.liftIO $ Rand.getStdRandom $ runState $ do 			secKey <- VP.randomSecretKey @c 			pubKey <- VP.proveIndispensableTrusteePublicKey secKey 			return (secKey, pubKey) 		let pubIdent = 			T.unpack $ T.toUpper $ T.take 8 $-			VP.hexHash $ VP.bytesNat $+			VP.hexSHA256 $ VP.bytesNat $ 			VP.trustee_PublicKey pubKey 		runPipe $ do-			Pip.each [pubIdent] >-> pipeInfo (\ident ->-				"Generated trustee keypair "<>ident<>+			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 0o400 (global_dir FP.</> pubIdent FP.<.>"privkey")-			Pip.each [pubKey] >-> writeJSON 0o444 (global_dir FP.</> pubIdent FP.<.>"pubkey")+			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@@ -152,34 +114,29 @@ 		"Read private key from file "<>ref"FILE"<>"." 		`helps` 		requiredTag "privkey" (var "FILE")-	api_param_url =-		"Download election files from "<>ref"URL"<>"."<>-		"\nDefaults to "<>fileRef "."<>"."-		`helps`-		defaultTag "url" "." (var "URL")  run_trustee_decrypt- Global_Params{..}- o@Trustee_Params{..}+ glob@Global_Params{..}+ Trustee_Params{..}  TrusteeDecrypt_Params{..} =-	VP.reify trustee_crypto $ \(crypto::Proxy c) -> runMaybeT $ do-		(secKey::VP.E c) <- loadJSON trusteeDecrypt_privkey+	VP.reify trustee_crypto $ \(_crypto::Proxy c) -> runMaybeT $ do+		(secKey::VP.E c) <- loadJSON glob trusteeDecrypt_privkey 		let pubKey = VP.publicKey secKey 		let trusteeKeysPath = trusteeDecrypt_url FP.</> "public_keys.jsons"-		-- Check that the public key is amongst the public keys of the election-		keys <- runPipeWithError $+		outputInfo glob "check that the public key is amongst the public keys of the election"+		keys <- runPipeWithError glob $ 			Pip.toListM' $-				readJSON trusteeKeysPath+				readJSON glob trusteeKeysPath 				 >-> Pip.filter ((pubKey ==) . VP.trustee_PublicKey) 		case () of-		 () | null keys -> outputError $+		 () | 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 $+		 () | 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@@ -187,14 +144,14 @@ 			 , "Trustee's public key: "<>Doc.from (show (VP.nat pubKey)) 			 ]<>"\n" 		 () -> do-			-- Tally the encrypted ballots+			outputInfo glob "tally the encrypted ballots" 			-- FIXME: actually support fetching through an URL 			let ballotsPath = trusteeDecrypt_url FP.</> "ballots.jsons"-			(encTally, numBallots) <- runPipeWithError $+			(encTally, _numBallots) <- runPipeWithError glob $ 				Pip.fold' 				 (flip VP.insertEncryptedTally) 				 VP.emptyEncryptedTally id $-					readJSON ballotsPath+					readJSON glob ballotsPath 			decShare <- Pip.liftIO $ 				Rand.getStdRandom $ runState $ 					VP.proveDecryptionShare encTally secKey
src/Hjugement/CLI/Utils.hs view
@@ -2,51 +2,43 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE StrictData #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} -- for VP.Reifies instances {-# OPTIONS_GHC -Wno-missing-signatures #-}+{-# OPTIONS_GHC -Wno-orphans #-} module Hjugement.CLI.Utils where +import Control.Applicative (Applicative(..), Alternative(..)) import Control.Arrow (left)-import Control.Applicative (Alternative(..))-import Control.Monad (Monad(..), forM_)+import Control.Monad (Monad(..), forM_, when) import Control.Monad.Trans.Maybe (MaybeT(..))-import Control.Monad.Trans.State.Strict (StateT(..), evalStateT)-import Data.Bits (setBit)+import Control.Monad.Trans.Except (runExceptT) import Data.Bool-import Data.ByteString (ByteString) import Data.Either (Either(..))+import Data.Eq (Eq(..)) import Data.Foldable (Foldable) import Data.Function (($), (.), id) import Data.Functor ((<$>)) import Data.Maybe (Maybe(..), maybe) import Data.Monoid (Monoid(..))-import Data.String (IsString(..))+import Data.Ord (Ord(..)) import Data.Semigroup (Semigroup(..)) import Data.Text (Text) import Prelude (min, max, (-)) import Symantic.CLI as CLI import System.IO (IO) import Text.Show (Show(..))-import qualified Crypto.Hash as Crypto import qualified Data.Aeson as JSON-import qualified Data.ByteArray as ByteArray-import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8 import qualified Data.ByteString.Lazy.Char8 as BSL8 import qualified Data.Text as Text import qualified Data.Text.Encoding as T-import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Builder as TLB-import qualified Data.Text.Lazy.Builder.Int as TLB import qualified Lens.Family as Lens-import qualified Lens.Family.State.Strict as Lens import qualified Pipes as Pip import qualified Pipes.Aeson as PipJSON (DecodingError(..)) import qualified Pipes.Aeson.Unchecked as PipJSON import qualified Pipes.ByteString as PipBS-import qualified Pipes.Group as Pip-import qualified Pipes.Parse as Pip-import qualified Pipes.Prelude as Pip import qualified Pipes.Safe as Pip import qualified Pipes.Safe.Prelude as Pip import qualified Symantic.Document as Doc@@ -58,6 +50,7 @@ import qualified Voting.Protocol as VP  ref = Doc.underline+con = Doc.between "\"" "\"" fileRef = ref helps = help . Doc.justify infixr 0 `helps`@@ -118,17 +111,23 @@ 				runLayout helpInh_full lay  -- * Type 'Global_Params'-data Global_Params = Global_Params- { global_dir :: IO.FilePath+data Global_Params+ =   Global_Params+ {   global_stderr_prepend_newline  :: Bool+ ,   global_stderr_prepend_carriage :: Bool+ ,   global_stderr_append_newline   :: Bool+ ,   global_dir       :: IO.FilePath+ ,   global_verbosity :: Verbosity  }  api_options = 	rule "OPTIONS" $-		Global_Params+		Global_Params False False True 		 <$> api_param_dir+		 <*> api_param_verbosity api_param_dir = 	"Use directory "<>ref"DIR"<>" for reading and writing election files.\n"<>-	"Default to "<>fileRef (Doc.from currDir)<>".\n"<>+	"Default to "<>con (Doc.from currDir)<>".\n"<> 	"Can also be set via HJUGEMENT_DIR="<>ref "DIR"<>"." 	`help` 	toPermDefault currDir $@@ -136,7 +135,41 @@ 		`alt` 		env "HJUGEMENT_DIR" 	where currDir = FP.takeDirectory "file"+api_param_url =+	"Download election files from "<>ref"URL"<>"."+	`helps`+	toPermutation $ tag "url" (var "URL") +-- * Type 'Verbosity'+data Verbosity+ =   Verbosity_Error+ |   Verbosity_Warning+ |   Verbosity_Info+ |   Verbosity_Debug+ deriving (Eq,Ord)++instance IOType Verbosity+instance FromSegment Verbosity where+	fromSegment = \case+	 "error"   -> return $ Right Verbosity_Error+	 "warning" -> return $ Right Verbosity_Warning+	 "info"    -> return $ Right Verbosity_Info+	 "debug"   -> return $ Right Verbosity_Debug+	 _ -> return $ Left "invalid verbosity"++api_param_verbosity =+ "Verbosity level.\+ \\nDefault to "<>con "info"<>"."+	`help`+	toPermDefault Verbosity_Info $+		tag "verbosity" (+			constant "error"   Verbosity_Error   `alt`+			constant "warning" Verbosity_Warning `alt`+			constant "info"    Verbosity_Info    `alt`+			constant "debug"   Verbosity_Debug+		 ) `alt`+		env "HJUGEMENT_VERBOSITY"+ -- * Pipes utilities runPipe ::  Pip.MonadIO m =>@@ -145,20 +178,23 @@  runPipeWithError ::  Pip.MonadIO m =>+ Global_Params ->  Pip.Effect (Pip.SafeT IO) (a, Either Doc ()) -> MaybeT m a-runPipeWithError p = do+runPipeWithError glob p = do 	(a, r) <- runPipe p 	case r of-	 Left err -> outputError err+	 Left err -> outputError glob err 	 Right () -> return a  writeFileLn ::  Pip.MonadSafe m =>  Foldable f =>+ Global_Params ->  Posix.FileMode ->  IO.FilePath ->  Pip.Consumer (f Text) m r-writeFileLn fileMode filePath =+writeFileLn glob fileMode filePath = do+	Pip.liftIO $ outputDebug glob $ "writing " <> Doc.from filePath 	Pip.bracket open close $ \h -> 		Pip.for Pip.cat $ \xs -> 			Pip.liftIO $ do@@ -167,8 +203,7 @@ 	where 	open = Pip.liftIO $ do 		IO.createDirectoryIfMissing True $ FP.takeDirectory filePath-		h <- IO.openFile filePath IO.WriteMode-		return h+		IO.openFile filePath IO.WriteMode 	close h = Pip.liftIO $ do 		fd <- Posix.handleToFd h 		Posix.setFdMode fd fileMode@@ -177,19 +212,20 @@ writeJSON ::  Pip.MonadSafe m =>  JSON.ToJSON a =>+ Global_Params ->  Posix.FileMode ->  IO.FilePath ->  Pip.Consumer a m r-writeJSON fileMode filePath =+writeJSON glob fileMode filePath = do+	Pip.liftIO $ outputDebug glob $ "writing " <> Doc.from filePath 	Pip.bracket open close $ \h -> 		Pip.for Pip.cat $ \a -> 			Pip.liftIO $ do-				BSL8.hPutStr h $ JSON.encode a+				BSL8.hPutStrLn h $ JSON.encode a 	where 	open = Pip.liftIO $ do 		IO.createDirectoryIfMissing True $ FP.takeDirectory filePath-		h <- IO.openFile filePath IO.WriteMode-		return h+		IO.openFile filePath IO.WriteMode 	close h = Pip.liftIO $ do 		fd <- Posix.handleToFd h 		Posix.setFdMode fd fileMode@@ -199,10 +235,12 @@  Pip.MonadSafe m =>  JSON.FromJSON a =>  JSON.ToJSON a =>+ Global_Params ->  IO.FilePath ->  Pip.Producer a m (Either Doc ())-readJSON filePath =-	let bytes = Pip.withFile filePath IO.ReadMode PipBS.fromHandle in+readJSON glob filePath = do+	Pip.liftIO $ outputDebug glob $ "reading " <> Doc.from filePath+	let bytes = Pip.withFile filePath IO.ReadMode PipBS.fromHandle 	left handleError <$> Lens.view PipJSON.decoded bytes 	where 	handleError (err, _rest) =@@ -219,22 +257,43 @@ saveJSON ::  JSON.ToJSON a =>  Pip.MonadIO m =>+ Global_Params ->  IO.FilePath -> a -> m ()-saveJSON filePath a =+saveJSON glob filePath a = 	-- FIXME: abort or demand confirmation if the file exists-	Pip.liftIO $ JSON.encodeFile filePath a+	Pip.liftIO $ do+		outputDebug glob $ "saving " <> Doc.from filePath+		JSON.encodeFile filePath a  loadJSON ::  JSON.FromJSON a =>  Pip.MonadIO m =>+ Global_Params ->  IO.FilePath -> MaybeT m a-loadJSON filePath =-	Pip.liftIO (JSON.eitherDecodeFileStrict' filePath) >>= \case-	 Left err -> outputError $+loadJSON glob filePath =+	Pip.liftIO (do+		outputDebug glob $ "loading " <> Doc.from filePath+		JSON.eitherDecodeFileStrict' filePath+	 ) >>= \case+	 Left err -> outputError glob $ 		Doc.from filePath<>": "<> 		Doc.from err<>"\n" 	 Right a -> return a +loadElection ::+ Pip.MonadIO m =>+ Global_Params ->+ IO.FilePath -> MaybeT m (VP.Election ())+loadElection glob filePath =+	Pip.liftIO ( do+		outputDebug glob $ "loading " <> Doc.from filePath+		runExceptT $ VP.readElection filePath+	 ) >>= \case+	 Left err -> outputError glob $+		Doc.from filePath<>": "<>+		Doc.from err<>"\n"+	 Right a -> return a+ {- readJSON' ::  Pip.MonadSafe m =>@@ -278,24 +337,38 @@  pipeInfo ::  Pip.MonadIO m =>- Outputable (OnHandle d) =>- (a -> d) -> Pip.Pipe a a m r-pipeInfo d =+ Global_Params ->+ (a -> Doc) -> Pip.Pipe a a m r+pipeInfo glob d = 	Pip.for Pip.cat $ \s -> do-		Pip.liftIO $ do-			output $ OnHandle IO.stderr (d s)-			output $ OnHandle IO.stderr '\n'+		Pip.liftIO $ outputInfo glob $ d s 		Pip.yield s -outputInfo :: Pip.MonadIO m => Doc -> m ()-outputInfo msg = do+outputMessage :: Pip.MonadIO m => Global_Params -> Doc -> Doc -> m ()+outputMessage Global_Params{..} hdr msg = 	Pip.liftIO $ output $ OnHandle @Doc IO.stderr $-		Doc.green "INFO"<>": "<>msg<>"\n"+		(if global_stderr_prepend_newline then Doc.newline else mempty) <>+		(if global_stderr_prepend_carriage then "\r" else mempty) <>+		hdr<>": "<>msg<>+		(if global_stderr_append_newline then Doc.newline else mempty) -outputError ::- Pip.MonadIO m =>- Doc -> MaybeT m a-outputError msg = do-	Pip.liftIO $ output $ OnHandle @Doc IO.stderr $-		Doc.redder "ERROR"<>": "<>msg<>"\n"+outputError :: Pip.MonadIO m => Global_Params -> Doc -> MaybeT m a+outputError glob@Global_Params{..} msg = do+	when (Verbosity_Error <= global_verbosity) $ do+		outputMessage glob (Doc.redder "ERROR") msg 	empty++outputWarning :: Pip.MonadIO m => Global_Params -> Doc -> m ()+outputWarning glob@Global_Params{..} msg = do+	when (Verbosity_Warning <= global_verbosity) $ do+		outputMessage glob (Doc.yellower "WARNING") msg++outputInfo :: Pip.MonadIO m => Global_Params -> Doc -> m ()+outputInfo glob@Global_Params{..} msg = do+	when (Verbosity_Info <= global_verbosity) $ do+		outputMessage glob (Doc.greener "info") msg++outputDebug :: Pip.MonadIO m => Global_Params -> Doc -> m ()+outputDebug glob@Global_Params{..} msg = do+	when (Verbosity_Debug <= global_verbosity) $ do+		outputMessage glob (Doc.magentaer "debug") msg
+ src/Hjugement/CLI/Voter.hs view
@@ -0,0 +1,191 @@+{-# 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+	rawElec <- loadElection glob $ voterVote_url FP.</> "election.json"+	VP.reifyElection rawElec $ \(elec@VP.Election{..} :: VP.Election 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 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+	rawElec <- loadElection glob $ voterVerify_url FP.</> "election.json"+	VP.reifyElection rawElec $ \(elec@VP.Election{..} :: VP.Election c) -> do+		outputInfo glob $ "verifying ballots"+		(fails :: Natural, (encTally :: VP.EncryptedTally 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 c <- loadJSON glob resultPath+			outputInfo glob $ "decrypting tally using trustees' decryption shares"+			trustees <- 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 ()