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                  )
 114                 <?> api_quests
 115                 <.> response @(Maybe ())
 116         where
 117         api_param_name =
 118                 "Name of the election."
 119                 `help`
 120                 defaultTag "name" "" (var "STRING")
 121         api_param_description =
 122                 "Description of the election."
 123                 `help`
 124                 defaultTag "description" "" (var "STRING")
 125         api_option_uuid =
 126                 "UUID of the election."
 127                 `help`
 128                 optionalTag "uuid" $
 129                         var "UUID"
 130         api_quests =
 131                 "Some questions."
 132                 `help`
 133                 many1 (var @Text "STRING")
 134         api_param_grades =
 135                 "The grades to evaluate the choices, from the lowest to the highest."
 136                 `helps`
 137                 many1Tag (TagLong "grade") $
 138                         var @Text "STRING"
 139         api_param_defaultGrade =
 140                 "The grade used when no grade is given by a voter.\n"<>
 141                 "Defaults to the lowest grade."
 142                 `helps`
 143                 optionalTag (TagLong "default-grade") $
 144                         var @Text "STRING"
 145
 146 run_administrator_election
 147  Global_Params{..}
 148  o@AdministratorElection_Params{..}
 149  quests =
 150         VP.reify administratorElection_crypto $ \(crypto::Proxy c) -> runMaybeT $ do
 151                 election_uuid <-
 152                         case administratorElection_uuid of
 153                          Nothing -> Pip.liftIO $ Rand.getStdRandom $ runState $ VP.randomUUID
 154                          Just u ->
 155                                 case VP.readUUID u of
 156                                  Left err -> outputError $ Doc.from (show err)
 157                                  Right uuid -> return uuid
 158                 let trusteeKeysPath = global_dir FP.</> "public_keys.jsons"
 159                 trusteeKeys :: [VP.TrusteePublicKey c] <- runPipeWithError $
 160                         Pip.toListM' $ readJSON trusteeKeysPath
 161                 let grades = List.nub administratorElection_grades
 162                 unless (List.length grades > 1) $
 163                         outputError $ "at least two distinct grades are needed"
 164                 unless (List.length grades == List.length administratorElection_grades) $
 165                         outputError $ "indistinct grades: " <>
 166                                 Doc.from (Text.intercalate ", " $ List.nub $
 167                                         administratorElection_grades List.\\ grades)
 168                 let defaultGrade = fromMaybe (grades List.!!0) administratorElection_defaultGrade
 169                  -- FIXME: put defaultGrade into election.json
 170                 saveJSON (global_dir FP.</> "election.json") $
 171                         VP.hashElection VP.Election
 172                          { VP.election_name        = administratorElection_name
 173                          , VP.election_description = administratorElection_description
 174                          , VP.election_crypto      = VP.ElectionCrypto_FFC
 175                                  { electionCrypto_FFC_params    = administratorElection_crypto
 176                                  , electionCrypto_FFC_PublicKey = VP.combineIndispensableTrusteePublicKeys trusteeKeys
 177                                  }
 178                          , VP.election_questions = (<$> quests) $ \quest -> VP.Question
 179                                  { question_text    = quest
 180                                  , question_choices = grades
 181                                  , question_mini    = 1
 182                                  , question_maxi    = 1
 183                                  }
 184                          , VP.election_uuid
 185                          , VP.election_hash = VP.hashJSON JSON.Null
 186                          }
 187                 outputInfo $ "Created election with "<>Doc.from (show election_uuid)