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         rawElec <- loadElection glob $ voterVote_url FP.</> "election.json"
  94         VP.reifyElection rawElec $ \(elec@VP.Election{..} :: VP.Election 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 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         rawElec <- loadElection glob $ voterVerify_url FP.</> "election.json"
 141         VP.reifyElection rawElec $ \(elec@VP.Election{..} :: VP.Election c) -> do
 142                 outputInfo glob $ "verifying ballots"
 143                 (fails :: Natural, (encTally :: VP.EncryptedTally c, _numBallots)) <- runPipeWithError glob $
 144                         Pip.foldM'
 145                          (\(fails, acc@(_, numBallots)) ballot@VP.Ballot{..} -> do
 146                                 let ballotNum = numBallots + fails
 147                                 outputDebug glob
 148                                  { global_stderr_prepend_carriage = True
 149                                  , global_stderr_append_newline   = False
 150                                  } $
 151                                         "checking ballot #"<>Doc.from ballotNum
 152                                 let globError = glob{global_stderr_prepend_newline = Verbosity_Debug <= global_verbosity}
 153                                 case ballot_signature of
 154                                  Nothing -> do
 155                                         void $ runMaybeT $ outputError globError $
 156                                                 "ballot #"<>Doc.from ballotNum<>" has no signature"
 157                                         return (fails+1, acc)
 158                                  Just{} ->
 159                                         if VP.verifyBallot elec ballot
 160                                         then return (fails, VP.insertEncryptedTally ballot acc)
 161                                         else do
 162                                                 void $ runMaybeT $ outputError globError $
 163                                                         "ballot #"<>Doc.from ballotNum<>" has an invalid signature"
 164                                                 return (fails+1, acc)
 165                          )
 166                          (return (0, VP.emptyEncryptedTally))
 167                          return $
 168                                 readJSON glob $ voterVerify_url FP.</> "ballots.jsons"
 169                 when (Verbosity_Debug <= global_verbosity) $
 170                         Pip.liftIO $ output $ OnHandle IO.stderr (Doc.newline::String)
 171                 when (0 < fails) empty
 172                 let resultPath = voterVerify_url FP.</> "result.json"
 173                 hasResult <- Pip.liftIO $ IO.doesPathExist resultPath
 174                 if not hasResult
 175                  then do
 176                         outputWarning glob "no tally to check"
 177                  else do
 178                         tally :: VP.Tally c <- loadJSON glob resultPath
 179                         outputInfo glob $ "decrypting tally using trustees' decryption shares"
 180                         trustees <- runPipeWithError glob $ Pip.toListM' $
 181                                 readJSON glob $ voterVerify_url FP.</> "public_keys.jsons"
 182                         let trustPubKeys = VP.trustee_PublicKey <$> trustees
 183                         decs <- runPipeWithError glob $ Pip.toListM' $
 184                                 readJSON glob $ voterVerify_url FP.</> "partial_decryptions.jsons"
 185                         outputInfo glob $ "verifying tally"
 186                         case runExcept $ do
 187                                 VP.verifyDecryptionShareByTrustee encTally trustPubKeys decs
 188                                 VP.verifyTally tally (VP.combineIndispensableDecryptionShares trustPubKeys)
 189                          of
 190                          Left err -> outputError glob $ Doc.from (show err)
 191                          Right () -> return ()