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

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