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(..))
   8 import Control.Monad (Monad(..), forM, forM_, join, 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 T
  44 import qualified Data.Text.Encoding as T
  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                 long "name" (var "STRING")
 121         api_param_description =
 122                 "Description of the election."
 123                 `help`
 124                 longOpt "description" "" (var "STRING")
 125         api_option_uuid =
 126                 "UUID of the election."
 127                 `help`
 128                 longOpt "uuid" Nothing $
 129                         dimap Just fromJust $ var "UUID"
 130         api_quests =
 131                 "Some questions."
 132                 `help`
 133                 many1 (var @Text "STRING")
 134         api_param_grades = toPermutation {-Default []-} $
 135                 many1 $
 136                         "The grades to evaluate the choices, from the lowest to the highest."
 137                         `helps`
 138                         tagged (TagLong "grade") $
 139                                 var @Text "STRING"
 140         api_param_defaultGrade = toPermDefault Nothing $
 141                 "The grade used when no grade is given by a voter.\n"<>
 142                 "Defaults to the lowest grade."
 143                 `helps`
 144                 tagged (TagLong "default-grade") $
 145                         dimap Just fromJust $
 146                                 var @Text "STRING"
 147
 148 run_administrator_election
 149  Global_Params{..}
 150  o@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 $ Doc.from (show err)
 159                                  Right uuid -> return uuid
 160                 let trusteeKeysPath = global_dir FP.</> "public_keys.jsons"
 161                 trusteeKeys :: [VP.TrusteePublicKey c] <- runPipeWithError $
 162                         Pip.toListM' $ readJSON trusteeKeysPath
 163                 -- TODO: check grades are distincts.
 164                 -- TODO: check default-grade is a grade.
 165                 saveJSON (global_dir FP.</> "election.json") $
 166                         VP.hashElection VP.Election
 167                          { VP.election_name        = administratorElection_name
 168                          , VP.election_description = administratorElection_description
 169                          , VP.election_crypto      = VP.ElectionCrypto_FFC
 170                                  { electionCrypto_FFC_params    = administratorElection_crypto
 171                                  , electionCrypto_FFC_PublicKey = VP.combineIndispensableTrusteePublicKeys trusteeKeys
 172                                  }
 173                          , VP.election_questions = (<$> quests) $ \quest -> VP.Question
 174                                  { question_text    = quest
 175                                  , question_choices = administratorElection_grades
 176                                  , question_mini    = 1
 177                                  , question_maxi    = 1
 178                                  }
 179                          , VP.election_uuid
 180                          , VP.election_hash = VP.hashJSON JSON.Null
 181                          }
 182                 outputInfo $ "Created election with "<>Doc.from (show election_uuid)