1 {-# LANGUAGE NoMonomorphismRestriction #-}
2 {-# LANGUAGE OverloadedStrings #-}
3 {-# LANGUAGE StrictData #-}
4 {-# OPTIONS_GHC -Wno-missing-signatures #-}
5 module Hjugement.CLI.Voter where
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)
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 ((<$>), (<$))
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)
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
74 import Hjugement.CLI.Utils
77 data Voter_Params = Voter_Params
82 "Commands for a voter."
87 run_voter globParams =
88 run_voter_vote globParams
89 :!: run_help api_voter
92 data VoterVote_Params = VoterVote_Params
93 { voterVote_privcred :: VP.Credential
94 , voterVote_url :: FilePath
95 , voterVote_grades :: [Text]
99 "Cast a vote on an election."
104 <$> api_param_privcred
106 <*> api_param_grades)
107 <?> response @(Maybe ())
110 "Voter's private credential."
112 requiredTag "privcred" (var "CREDENTIAL")
114 "The grades to evaluate the choices, from the lowest to the highest."
116 many1Tag (TagLong "grade") $
121 o@VoterVote_Params{..}
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)<>
130 Doc.from (List.length election_questions)<>
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) $
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)
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