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