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.List as List
  45 import qualified Data.Text as Text
  46 import qualified Data.Text.Encoding as Text
  47 import qualified Data.Text.Lazy as TL
  48 import qualified Data.Text.Lazy.Builder as TLB
  49 import qualified Data.Text.Lazy.Builder.Int as TLB
  50 import qualified Data.Text.Lazy.Encoding as TL
  51 import qualified Data.Text.Lazy.IO as TL
  52 import qualified Data.Time as Time
  53 import qualified Lens.Family as Lens
  54 import qualified Lens.Family.State.Strict as Lens
  55 import qualified Pipes as Pip
  56 import qualified Pipes.ByteString as PipBS
  57 import qualified Pipes.Group as Pip
  58 import qualified Pipes.Prelude as Pip
  59 import qualified Pipes.Aeson as PipJSON (DecodingError(..))
  60 import qualified Pipes.Aeson.Unchecked as PipJSON
  61 import qualified Pipes.Safe as Pip
  62 import qualified Pipes.Safe.Prelude as Pip
  63 import qualified Pipes.Text as PipText
  64 import qualified Pipes.Text.Encoding as PipText
  65 import qualified Pipes.Text.IO as PipText
  66 import qualified Symantic.Document as Doc
  67 import qualified System.FilePath as FP
  68 import qualified System.IO as IO
  69 import qualified System.Posix as Posix
  70 import qualified System.Random as Rand
  71 import qualified Voting.Protocol as VP
  72 import qualified Voting.Protocol.Utils as VP
  73
  74 import Hjugement.CLI.Utils
  75
  76 -- * administrator
  77 data Voter_Params = Voter_Params
  78  {
  79  } deriving (Show)
  80
  81 api_voter =
  82         "Commands for a voter."
  83         `helps`
  84         command "voter" $
  85                 api_voter_vote
  86                 <!> api_help False
  87 run_voter globParams =
  88         run_voter_vote globParams
  89         :!: run_help api_voter
  90
  91 -- ** election
  92 data VoterVote_Params = VoterVote_Params
  93  {   voterVote_privcred :: VP.Credential
  94  ,   voterVote_url      :: FilePath
  95  ,   voterVote_grades   :: [Text]
  96  } deriving (Show)
  97
  98 api_voter_vote =
  99         "Cast a vote on an election."
 100         `helps`
 101         command "vote" $
 102                 rule "PARAMS"
 103                  (VoterVote_Params
 104                          <$> api_param_privcred
 105                          <*> api_param_url
 106                          <*> api_param_grades)
 107                 <?> response @(Maybe ())
 108         where
 109         api_param_privcred =
 110                 "Voter's private credential."
 111                 `helps`
 112                 requiredTag "privcred" (var "CREDENTIAL")
 113         api_param_grades =
 114                 "The grades to evaluate the choices, from the lowest to the highest."
 115                 `helps`
 116                 many1Tag (TagLong "grade") $
 117                         var @Text "STRING"
 118
 119 run_voter_vote
 120  Global_Params{..}
 121  o@VoterVote_Params{..}
 122  = runMaybeT $ do
 123         elecUnit <- loadJSON (voterVote_url FP.</> "election.json")
 124         VP.reifyElection elecUnit $ \(elec@VP.Election{..} :: VP.Election c) -> do
 125                 outputInfo $ "Voted"<>Doc.from (show voterVote_grades)
 126                 votes <- VP.isoZipWithM
 127                  (outputError $ "Mismatching number of cast grades ("<>
 128                         Doc.from (List.length voterVote_grades)<>
 129                         ") and choices ("<>
 130                         Doc.from (List.length election_questions)<>
 131                         ")")
 132                  (\VP.Question{..} grade -> do
 133                         let bools = (grade ==) <$> question_choices
 134                         let boolSum = sum $ (<$> bools) $ \b -> if b then 1 else 0 :: Natural
 135                         unless (boolSum == 1) $
 136                                 outputError $
 137                                         "The election does not allow to cast a grade named: "<>Doc.from grade<>"\n"<>
 138                                         "Allowed grades are: "<>Doc.from (Text.intercalate ", " question_choices)
 139                         return bools)
 140                  election_questions
 141                  voterVote_grades
 142                 outputInfo $ Doc.from (show votes)
 143                 let (secKey :: VP.SecretKey c) =
 144                         VP.credentialSecretKey election_uuid voterVote_privcred
 145                 ballot <- join $ Pip.liftIO $
 146                         Rand.getStdRandom $ \gen ->
 147                                 case runExcept $ (`runStateT` gen) $
 148                                  VP.encryptBallot elec (Just secKey) votes of
 149                                  Left err -> (outputError $ Doc.from (show err), gen)
 150                                  Right (ballot, gen') -> (return ballot, gen')
 151                 Pip.liftIO $ BSL.putStrLn $ JSON.encode ballot