hjugement-cli/src/Hjugement/CLI/Voter.hs

   1 {-# LANGUAGE NoMonomorphismRestriction #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 {-# LANGUAGE StrictData #-}
   4 {-# LANGUAGE TypeApplications #-}
   5 {-# OPTIONS_GHC -Wno-missing-signatures #-}
   6 module Hjugement.CLI.Voter where
   7
   8 import Control.Applicative (Applicative(..), Alternative(..))
   9 import Control.Monad (Monad(..), join, unless, void, when)
  10 import Control.Monad.Trans.Maybe (MaybeT(..))
  11 import Control.Monad.Trans.Except (runExcept)
  12 import Control.Monad.Trans.State.Strict (runStateT)
  13 import Data.Bool
  14 import Data.Either (Either(..))
  15 import Data.Eq (Eq(..))
  16 import Data.Foldable (sum)
  17 import Data.Function (($))
  18 import Data.Functor ((<$>))
  19 import Data.Maybe (Maybe(..))
  20 import Data.Ord (Ord(..))
  21 import Data.Semigroup (Semigroup(..))
  22 import Data.String (String)
  23 import Data.Text (Text)
  24 import Numeric.Natural (Natural)
  25 import Prelude (Num(..))
  26 import Symantic.CLI as CLI
  27 import System.IO (FilePath)
  28 import Text.Show (Show(..))
  29 import qualified Data.Aeson as JSON
  30 import qualified Data.ByteString.Lazy.Char8 as BSL8
  31 import qualified Data.List as List
  32 import qualified Data.Text as Text
  33 import qualified Pipes as Pip
  34 import qualified Pipes.Prelude as Pip
  35 import qualified Symantic.Document as Doc
  36 import qualified System.Directory as IO
  37 import qualified System.FilePath as FP
  38 import qualified System.IO as IO
  39 import qualified System.Random as Rand
  40 import qualified Voting.Protocol as VP
  41 import qualified Voting.Protocol.Utils as VP
  42
  43 import Hjugement.CLI.Utils
  44
  45 -- * administrator
  46 data Voter_Params = Voter_Params
  47  {
  48  } deriving (Show)
  49
  50 api_voter =
  51         "Commands for a voter."
  52         `helps`
  53         command "voter" $
  54                 api_voter_vote
  55                 <!> api_voter_verify
  56                 <!> api_help False
  57 run_voter globParams =
  58         run_voter_vote globParams
  59         :!: run_voter_verify globParams
  60         :!: run_help api_voter
  61
  62 -- ** vote
  63 data VoterVote_Params = VoterVote_Params
  64  {   voterVote_privcred :: VP.Credential
  65  ,   voterVote_url      :: FilePath
  66  ,   voterVote_grades   :: [Text]
  67  } deriving (Show)
  68
  69 api_voter_vote =
  70         "Cast a vote on an election."
  71         `helps`
  72         command "vote" $
  73                 rule "PARAMS"
  74                  (VoterVote_Params
  75                          <$> api_param_privcred
  76                          <*> api_param_url
  77                          <*> api_param_grades)
  78                 <?> response @(Maybe ())
  79         where
  80         api_param_privcred =
  81                 "Voter's private credential."
  82                 `helps`
  83                 requiredTag "privcred" (var "CREDENTIAL")
  84         api_param_grades =
  85                 "The grades to evaluate the choices, from the lowest to the highest."
  86                 `helps`
  87                 many1Tag (TagLong "grade") $
  88                         var @Text "STRING"
  89
  90 run_voter_vote
  91  glob@Global_Params{..}
  92  VoterVote_Params{..} = runMaybeT $ do
  93         loadElection glob (voterVote_url FP.</> "election.json") $
  94          \(elec@VP.Election{..} :: VP.Election VP.FFC v c) -> do
  95                 outputInfo glob $ "Voted"<>Doc.from (show voterVote_grades)
  96                 votes <- VP.isoZipWithM
  97                  (outputError glob $ "Mismatching number of cast grades ("<>
  98                         Doc.from (List.length voterVote_grades)<>
  99                         ") and choices ("<>
 100                         Doc.from (List.length election_questions)<>
 101                         ")")
 102                  (\VP.Question{..} grade -> do
 103                         let bools = (grade ==) <$> question_choices
 104                         let boolSum = sum $ (<$> bools) $ \b -> if b then 1 else 0 :: Natural
 105                         unless (boolSum == 1) $
 106                                 outputError glob $
 107                                         "The election does not allow to cast a grade named: "<>Doc.from grade<>"\n"<>
 108                                         "Allowed grades are: "<>Doc.from (Text.intercalate ", " question_choices)
 109                         return bools)
 110                  election_questions
 111                  voterVote_grades
 112                 outputInfo glob $ Doc.from (show votes)
 113                 let (secKey :: VP.SecretKey VP.FFC c) =
 114                         VP.credentialSecretKey election_uuid voterVote_privcred
 115                 ballot <- join $ Pip.liftIO $
 116                         Rand.getStdRandom $ \gen ->
 117                                 case runExcept $ (`runStateT` gen) $
 118                                  VP.encryptBallot elec (Just secKey) votes of
 119                                  Left err -> (outputError glob $ Doc.from (show err), gen)
 120                                  Right (ballot, gen') -> (return ballot, gen')
 121                 Pip.liftIO $ BSL8.putStrLn $ JSON.encode ballot
 122
 123 -- ** verify
 124 data VoterVerify_Params = VoterVerify_Params
 125  {   voterVerify_url :: FilePath
 126  } deriving (Show)
 127
 128 api_voter_verify =
 129         "Cast a vote on an election."
 130         `helps`
 131         command "verify" $
 132                 rule "PARAMS"
 133                  (VoterVerify_Params
 134                          <$> api_param_url)
 135                 <?> response @(Maybe ())
 136
 137 run_voter_verify
 138  glob@Global_Params{..}
 139  VoterVerify_Params{..} = runMaybeT $ do
 140         loadElection glob (voterVerify_url FP.</> "election.json") $
 141          \(elec@VP.Election{..} :: VP.Election VP.FFC v c) -> do
 142                 outputInfo glob $ "verifying ballots"
 143                 (fails :: Natural, (encTally :: VP.EncryptedTally VP.FFC v c, _numBallots))
 144                  <- runPipeWithError glob $
 145                         Pip.foldM'
 146                          (\(fails, acc@(_, numBallots)) ballot@VP.Ballot{..} -> do
 147                                 let ballotNum = numBallots + fails
 148                                 outputDebug glob
 149                                  { global_stderr_prepend_carriage = True
 150                                  , global_stderr_append_newline   = False
 151                                  } $
 152                                         "checking ballot #"<>Doc.from ballotNum
 153                                 let globError = glob{global_stderr_prepend_newline = Verbosity_Debug <= global_verbosity}
 154                                 case ballot_signature of
 155                                  Nothing -> do
 156                                         void $ runMaybeT $ outputError globError $
 157                                                 "ballot #"<>Doc.from ballotNum<>" has no signature"
 158                                         return (fails+1, acc)
 159                                  Just{} ->
 160                                         if VP.verifyBallot elec ballot
 161                                         then return (fails, VP.insertEncryptedTally ballot acc)
 162                                         else do
 163                                                 void $ runMaybeT $ outputError globError $
 164                                                         "ballot #"<>Doc.from ballotNum<>" has an invalid signature"
 165                                                 return (fails+1, acc)
 166                          )
 167                          (return (0, VP.emptyEncryptedTally))
 168                          return $
 169                                 readJSON glob $ voterVerify_url FP.</> "ballots.jsons"
 170                 when (Verbosity_Debug <= global_verbosity) $
 171                         Pip.liftIO $ output $ OnHandle IO.stderr (Doc.newline::String)
 172                 when (0 < fails) empty
 173                 let resultPath = voterVerify_url FP.</> "result.json"
 174                 hasResult <- Pip.liftIO $ IO.doesPathExist resultPath
 175                 if not hasResult
 176                  then do
 177                         outputWarning glob "no tally to check"
 178                  else do
 179                         tally :: VP.Tally VP.FFC v c <- loadJSON glob resultPath
 180                         outputInfo glob $ "decrypting tally using trustees' decryption shares"
 181                         trustees :: [VP.TrusteePublicKey VP.FFC v c]
 182                          <- runPipeWithError glob $ Pip.toListM' $
 183                                 readJSON glob $ voterVerify_url FP.</> "public_keys.jsons"
 184                         let trustPubKeys = VP.trustee_PublicKey <$> trustees
 185                         decs <- runPipeWithError glob $ Pip.toListM' $
 186                                 readJSON glob $ voterVerify_url FP.</> "partial_decryptions.jsons"
 187                         outputInfo glob $ "verifying tally"
 188                         case runExcept $ do
 189                                 VP.verifyDecryptionShareByTrustee encTally trustPubKeys decs
 190                                 VP.verifyTally tally (VP.combineIndispensableDecryptionShares trustPubKeys)
 191                          of
 192                          Left err -> outputError glob $ Doc.from (show err)
 193                          Right () -> return ()