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.Maybe (MaybeT(..))
  11 import Control.Monad.Trans.State.Strict (runState, runStateT)
  12 import Data.Bits (setBit)
  13 import Data.Bool
  14 import Data.ByteString (ByteString)
  15 import Data.Either (Either(..))
  16 import Data.Eq (Eq(..))
  17 import Data.Foldable (Foldable, foldMap, length, null)
  18 import Data.Function (($), (.), id, flip)
  19 import Data.Functor ((<$>), (<$))
  20 import Data.Int (Int)
  21 import Data.Maybe (Maybe(..), maybe, fromMaybe, fromJust)
  22 import Data.Monoid (Monoid(..))
  23 import Data.Ord (Ord(..))
  24 import Data.Proxy (Proxy(..))
  25 import Data.Semigroup (Semigroup(..))
  26 import Data.String (String)
  27 import Data.Text (Text)
  28 import GHC.Natural (minusNatural, minusNaturalMaybe)
  29 import GHC.Prim (coerce)
  30 import Numeric.Natural (Natural)
  31 import Pipes ((>->))
  32 import Prelude (logBase, ceiling, Num(..), (/), (^), fromIntegral, Double)
  33 import Symantic.CLI as CLI
  34 import System.IO (IO, FilePath)
  35 import Text.Show (Show(..))
  36 import qualified Crypto.Hash as Crypto
  37 import qualified Data.Aeson as JSON
  38 import qualified Data.ByteArray as ByteArray
  39 import qualified Data.ByteString as BS
  40 import qualified Data.ByteString.Char8 as BS8
  41 import qualified Data.ByteString.Lazy as BSL
  42 import qualified Data.List as List
  43 import qualified Data.Text as Text
  44 import qualified Data.Text.Encoding as Text
  45 import qualified Data.Text.Lazy as TL
  46 import qualified Data.Text.Lazy.Builder as TLB
  47 import qualified Data.Text.Lazy.Builder.Int as TLB
  48 import qualified Data.Text.Lazy.Encoding as TL
  49 import qualified Data.Text.Lazy.IO as TL
  50 import qualified Data.Time as Time
  51 import qualified Lens.Family as Lens
  52 import qualified Lens.Family.State.Strict as Lens
  53 import qualified Pipes as Pip
  54 import qualified Pipes.ByteString as PipBS
  55 import qualified Pipes.Group as Pip
  56 import qualified Pipes.Prelude as Pip
  57 import qualified Pipes.Aeson as PipJSON (DecodingError(..))
  58 import qualified Pipes.Aeson.Unchecked as PipJSON
  59 import qualified Pipes.Safe as Pip
  60 import qualified Pipes.Safe.Prelude as Pip
  61 import qualified Pipes.Text as PipText
  62 import qualified Pipes.Text.Encoding as PipText
  63 import qualified Pipes.Text.IO as PipText
  64 import qualified Symantic.Document as Doc
  65 import qualified System.FilePath as FP
  66 import qualified System.IO as IO
  67 import qualified System.Posix as Posix
  68 import qualified System.Random as Rand
  69 import qualified Voting.Protocol as VP
  70
  71 import Hjugement.CLI.Utils
  72
  73 -- * administrator
  74 data Administrator_Params = Administrator_Params
  75  {
  76  } deriving (Show)
  77
  78 api_administrator =
  79         "Commands for an administrator."
  80         `helps`
  81         command "administrator" $
  82                 api_administrator_election
  83                 <!> api_help False
  84 run_administrator globParams =
  85         run_administrator_election globParams
  86         :!: run_help api_administrator
  87
  88 -- ** election
  89 data AdministratorElection_Params = AdministratorElection_Params
  90  {   administratorElection_crypto       :: VP.FFC
  91  ,   administratorElection_name         :: Text
  92  ,   administratorElection_description  :: Text
  93  ,   administratorElection_uuid         :: Maybe Text
  94  ,   administratorElection_grades       :: [Text]
  95  ,   administratorElection_defaultGrade :: Maybe Text
  96  } deriving (Show)
  97
  98 api_administrator_election =
  99         "This command reads and checks the trustees' public keys in "<>fileRef"public_keys.jsons"<>".\
 100  \ From which it computes the global election public key\
 101  \ put it into an "<>fileRef"election.json"<>" file \
 102  \ with the infos of the vote given here."
 103         `helps`
 104         command "election" $
 105                 rule "PARAMS"
 106                  (AdministratorElection_Params
 107                          <$> api_param_crypto
 108                          <*> api_param_name
 109                          <*> api_param_description
 110                          <*> api_option_uuid
 111                          <*> api_param_grades
 112                          <*> api_param_defaultGrade)
 113                 <?> api_quests
 114                 <.> response @(Maybe ())
 115         where
 116         api_param_name =
 117                 "Name of the election."
 118                 `help`
 119                 defaultTag "name" "" (var "STRING")
 120         api_param_description =
 121                 "Description of the election."
 122                 `help`
 123                 defaultTag "description" "" (var "STRING")
 124         api_option_uuid =
 125                 "UUID of the election."
 126                 `help`
 127                 optionalTag "uuid" $
 128                         var "UUID"
 129         api_quests =
 130                 "Some questions."
 131                 `help`
 132                 many1 (var @Text "STRING")
 133         api_param_grades =
 134                 "The grades to evaluate the choices, from the lowest to the highest."
 135                 `helps`
 136                 many1Tag (TagLong "grade") $
 137                         var @Text "STRING"
 138         api_param_defaultGrade =
 139                 "The grade used when no grade is given by a voter.\n"<>
 140                 "Defaults to the lowest grade."
 141                 `helps`
 142                 optionalTag (TagLong "default-grade") $
 143                         var @Text "STRING"
 144
 145 run_administrator_election
 146  Global_Params{..}
 147  o@AdministratorElection_Params{..}
 148  quests =
 149         VP.reify administratorElection_crypto $ \(crypto::Proxy c) -> runMaybeT $ do
 150                 election_uuid <-
 151                         case administratorElection_uuid of
 152                          Nothing -> Pip.liftIO $ Rand.getStdRandom $ runState $ VP.randomUUID
 153                          Just u ->
 154                                 case VP.readUUID u of
 155                                  Left err -> outputError $ Doc.from (show err)
 156                                  Right uuid -> return uuid
 157                 let trusteeKeysPath = global_dir FP.</> "public_keys.jsons"
 158                 trusteeKeys :: [VP.TrusteePublicKey c] <- runPipeWithError $
 159                         Pip.toListM' $ readJSON trusteeKeysPath
 160                 let grades = List.nub administratorElection_grades
 161                 unless (List.length grades > 1) $
 162                         outputError $ "at least two distinct grades are needed"
 163                 unless (List.length grades == List.length administratorElection_grades) $
 164                         outputError $ "indistinct grades: " <>
 165                                 Doc.from (Text.intercalate ", " $ List.nub $
 166                                         administratorElection_grades List.\\ grades)
 167                 let defaultGrade = fromMaybe (grades List.!!0) administratorElection_defaultGrade
 168                  -- FIXME: put defaultGrade into election.json
 169                 saveJSON (global_dir FP.</> "election.json") $
 170                         VP.hashElection VP.Election
 171                          { VP.election_name        = administratorElection_name
 172                          , VP.election_description = administratorElection_description
 173                          , VP.election_crypto      = VP.ElectionCrypto_FFC
 174                                  { electionCrypto_FFC_params    = administratorElection_crypto
 175                                  , electionCrypto_FFC_PublicKey = VP.combineIndispensableTrusteePublicKeys trusteeKeys
 176                                  }
 177                          , VP.election_questions = (<$> quests) $ \quest -> VP.Question
 178                                  { question_text    = quest
 179                                  , question_choices = grades
 180                                  , question_mini    = 1
 181                                  , question_maxi    = 1
 182                                  }
 183                          , VP.election_uuid
 184                          , VP.election_hash = VP.hashJSON JSON.Null
 185                          }
 186                 outputInfo $ "Created election with "<>Doc.from (show election_uuid)