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

   1 {-# LANGUAGE NoMonomorphismRestriction #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 {-# LANGUAGE StrictData #-}
   4 {-# OPTIONS_GHC -Wno-missing-signatures #-}
   5 module Hjugement.CLI.Administrator where
   6
   7 import Control.Applicative (Applicative(..), Alternative(..))
   8 import Control.Monad (Monad(..), forM, forM_, join, unless, void)
   9 import Control.Monad.Trans.Class (MonadTrans(..))
  10 import Control.Monad.Trans.Except (runExcept)
  11 import Control.Monad.Trans.Maybe (MaybeT(..))
  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(..))
  17 import Data.Eq (Eq(..))
  18 import Data.Foldable (Foldable, foldMap, length, null)
  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 GHC.Natural (minusNatural, minusNaturalMaybe)
  30 import GHC.Prim (coerce)
  31 import Numeric.Natural (Natural)
  32 import Pipes ((>->))
  33 import Prelude (logBase, ceiling, Num(..), (/), (^), fromIntegral, Double)
  34 import Symantic.CLI as CLI
  35 import System.IO (IO, FilePath)
  36 import Text.Show (Show(..))
  37 import qualified Crypto.Hash as Crypto
  38 import qualified Data.Aeson as JSON
  39 import qualified Data.ByteArray as ByteArray
  40 import qualified Data.ByteString as BS
  41 import qualified Data.ByteString.Char8 as BS8
  42 import qualified Data.ByteString.Lazy as BSL
  43 import qualified Data.List as List
  44 import qualified Data.Text as Text
  45 import qualified Data.Text.Encoding as Text
  46 import qualified Data.Text.Lazy as TL
  47 import qualified Data.Text.Lazy.Builder as TLB
  48 import qualified Data.Text.Lazy.Builder.Int as TLB
  49 import qualified Data.Text.Lazy.Encoding as TL
  50 import qualified Data.Text.Lazy.IO as TL
  51 import qualified Data.Time as Time
  52 import qualified Lens.Family as Lens
  53 import qualified Lens.Family.State.Strict as Lens
  54 import qualified Pipes as Pip
  55 import qualified Pipes.ByteString as PipBS
  56 import qualified Pipes.Group as Pip
  57 import qualified Pipes.Prelude as Pip
  58 import qualified Pipes.Aeson as PipJSON (DecodingError(..))
  59 import qualified Pipes.Aeson.Unchecked as PipJSON
  60 import qualified Pipes.Safe as Pip
  61 import qualified Pipes.Safe.Prelude as Pip
  62 import qualified Pipes.Text as PipText
  63 import qualified Pipes.Text.Encoding as PipText
  64 import qualified Pipes.Text.IO as PipText
  65 import qualified Symantic.Document as Doc
  66 import qualified System.FilePath as FP
  67 import qualified System.IO as IO
  68 import qualified System.Posix as Posix
  69 import qualified System.Random as Rand
  70 import qualified Voting.Protocol as VP
  71
  72 import Hjugement.CLI.Utils
  73
  74 -- * administrator
  75 data Administrator_Params = Administrator_Params
  76  {
  77  } deriving (Show)
  78
  79 api_administrator =
  80         "Commands for an administrator."
  81         `helps`
  82         command "administrator" $
  83                 api_administrator_election
  84                 <!> api_administrator_tally
  85                 <!> api_help False
  86 run_administrator globParams =
  87         run_administrator_election globParams
  88         :!: run_administrator_tally globParams
  89         :!: run_help api_administrator
  90
  91 -- ** election
  92 data AdministratorElection_Params = AdministratorElection_Params
  93  {   administratorElection_crypto       :: VP.FFC
  94  ,   administratorElection_name         :: Text
  95  ,   administratorElection_description  :: Text
  96  ,   administratorElection_uuid         :: Maybe Text
  97  ,   administratorElection_grades       :: [Text]
  98  ,   administratorElection_defaultGrade :: Maybe Text
  99  } deriving (Show)
 100
 101 api_administrator_election =
 102         "This command reads and checks the trustees' public keys in "<>fileRef"public_keys.jsons"<>".\
 103  \ From which it computes the global election public key\
 104  \ put it into an "<>fileRef"election.json"<>" file \
 105  \ with the infos of the vote given here."
 106         `helps`
 107         command "election" $
 108                 rule "PARAMS"
 109                  (AdministratorElection_Params
 110                          <$> api_param_crypto
 111                          <*> api_param_name
 112                          <*> api_param_description
 113                          <*> api_option_uuid
 114                          <*> api_param_grades
 115                          <*> api_param_defaultGrade)
 116                 <?> api_quests
 117                 <.> response @(Maybe ())
 118         where
 119         api_param_name =
 120                 "Name of the election."
 121                 `help`
 122                 defaultTag "name" "" (var "STRING")
 123         api_param_description =
 124                 "Description of the election."
 125                 `help`
 126                 defaultTag "description" "" (var "STRING")
 127         api_option_uuid =
 128                 "UUID of the election."
 129                 `help`
 130                 optionalTag "uuid" $
 131                         var "UUID"
 132         api_quests =
 133                 "Some questions."
 134                 `help`
 135                 many1 (var @Text "STRING")
 136         api_param_grades =
 137                 "The grades to evaluate the choices, from the lowest to the highest."
 138                 `helps`
 139                 many1Tag (TagLong "grade") $
 140                         var @Text "STRING"
 141         api_param_defaultGrade =
 142                 "The grade used when no grade is given by a voter.\n"<>
 143                 "Defaults to the lowest grade."
 144                 `helps`
 145                 optionalTag (TagLong "default-grade") $
 146                         var @Text "STRING"
 147
 148 run_administrator_election
 149  glob@Global_Params{..}
 150  AdministratorElection_Params{..}
 151  quests =
 152         VP.reify administratorElection_crypto $ \(_crypto::Proxy c) -> runMaybeT $ do
 153                 election_uuid <-
 154                         case administratorElection_uuid of
 155                          Nothing -> Pip.liftIO $ Rand.getStdRandom $ runState $ VP.randomUUID
 156                          Just u ->
 157                                 case VP.readUUID u of
 158                                  Left err -> outputError glob $ Doc.from (show err)
 159                                  Right uuid -> return uuid
 160                 let trusteeKeysPath = global_dir FP.</> "public_keys.jsons"
 161                 trusteeKeys :: [VP.TrusteePublicKey c] <- runPipeWithError glob $
 162                         Pip.toListM' $ readJSON glob trusteeKeysPath
 163                 forM_ trusteeKeys $ \trusteeKey ->
 164                         case runExcept $ VP.verifyIndispensableTrusteePublicKey trusteeKey of
 165                          Left err -> outputError glob $ Doc.from (show err)
 166                          Right () -> return ()
 167                 let grades = List.nub administratorElection_grades
 168                 unless (List.length grades > 1) $
 169                         outputError glob $ "at least two distinct grades are needed"
 170                 unless (List.length grades == List.length administratorElection_grades) $
 171                         outputError glob $ "indistinct grades: " <>
 172                                 Doc.from (Text.intercalate ", " $ List.nub $
 173                                         administratorElection_grades List.\\ grades)
 174                 let defaultGrade =
 175                         fromMaybe (grades List.!!0)
 176                          administratorElection_defaultGrade
 177                  -- FIXME: put defaultGrade into election.json
 178                 let elec =
 179                         VP.Election
 180                          { VP.election_name        = administratorElection_name
 181                          , VP.election_description = administratorElection_description
 182                          , VP.election_crypto      = VP.ElectionCrypto_FFC
 183                                  { electionCrypto_FFC_params    = administratorElection_crypto
 184                                  , electionCrypto_FFC_PublicKey = VP.combineIndispensableTrusteePublicKeys trusteeKeys
 185                                  }
 186                          , VP.election_questions = (<$> quests) $ \quest -> VP.Question
 187                                  { question_text    = quest
 188                                  , question_choices = grades
 189                                  , question_mini    = 1
 190                                  , question_maxi    = 1
 191                                  }
 192                          , VP.election_uuid
 193                          , VP.election_hash = VP.Base64SHA256 ""
 194                          }
 195                 saveJSON glob (global_dir FP.</> "election.json") elec
 196                 outputInfo glob $
 197                         "created election with "<>Doc.from (show election_uuid)<>
 198                         " and "<>Doc.from (show (VP.base64SHA256 (BSL.toStrict (JSON.encode elec))))
 199
 200 -- ** tally
 201 api_administrator_tally =
 202  "Tally an election using the decryption shares gathered from trustees\
 203  \ in "<>fileRef "partial_decryptions.jsons"<>".\
 204  \ The result is saved in "<>fileRef "result.json"<>".\n\
 205  \ It contains the decryption shares,\
 206  \ so "<>fileRef "partial_decryptions.jsons"<>" can be discarded afterwards."
 207         `helps`
 208         command "tally" $
 209                 response @(Maybe ())
 210
 211 run_administrator_tally
 212  glob@Global_Params{..} = runMaybeT $ do
 213         rawElec <- loadElection glob $ global_dir FP.</> "election.json"
 214         VP.reifyElection rawElec $ \(_elec :: VP.Election c) -> do
 215                 keys <- runPipeWithError glob $ Pip.toListM' $
 216                         readJSON glob $ global_dir FP.</> "public_keys.jsons"
 217                 decs <- runPipeWithError glob $ Pip.toListM' $
 218                         readJSON glob $ global_dir FP.</> "partial_decryptions.jsons"
 219                 outputInfo glob $ "computing encrypted tally from ballots"
 220                 (encTally, numBallots) <- runPipeWithError glob $
 221                         Pip.fold'
 222                          (flip VP.insertEncryptedTally)
 223                          VP.emptyEncryptedTally id $
 224                                 readJSON glob $ global_dir FP.</> "ballots.jsons"
 225                 outputInfo glob $ "decrypting tally using trustees' decryption shares"
 226                 case runExcept $ VP.proveTally
 227                          (encTally :: VP.EncryptedTally c, numBallots) decs
 228                          (VP.combineIndispensableDecryptionShares (VP.trustee_PublicKey <$> keys)) of
 229                  Left err -> outputError glob $ Doc.from (show err)
 230                  Right tally -> do
 231                         let resultPath = global_dir FP.</> "result.json"
 232                         saveJSON glob resultPath tally
 233                         outputInfo glob $ "tally generated in " <> Doc.from resultPath