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

   1 {-# LANGUAGE NoMonomorphismRestriction #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 {-# LANGUAGE StrictData #-}
   4 {-# LANGUAGE TypeApplications #-}
   5 {-# OPTIONS_GHC -Wno-missing-signatures #-}
   6 module Hjugement.CLI.Registrar where
   7
   8 import Control.Arrow (left)
   9 import Control.Applicative (Applicative(..))
  10 import Control.Monad (Monad(..))
  11 import Control.Monad.Trans.Maybe (MaybeT(..))
  12 import Control.Monad.Trans.State.Strict (runState)
  13 import Data.Bool
  14 import Data.Either (Either(..))
  15 import Data.Function (($), (.))
  16 import Data.Functor ((<$>))
  17 import Data.Maybe (Maybe(..))
  18 import Data.Proxy (Proxy(..))
  19 import Data.Semigroup (Semigroup(..))
  20 import GHC.Natural (minusNatural)
  21 import Numeric.Natural (Natural)
  22 import Pipes ((>->))
  23 import Prelude (logBase, ceiling, Num(..), (/), (^), fromIntegral, Double)
  24 import Symantic.CLI as CLI
  25 import Text.Show (Show(..))
  26 import qualified Data.List as List
  27 import qualified Data.Text as T
  28 import qualified Data.Time as Time
  29 import qualified Lens.Family as Lens
  30 import qualified Pipes as Pip
  31 import qualified Pipes.ByteString as PipBS
  32 import qualified Pipes.Group as Pip
  33 import qualified Pipes.Prelude as Pip
  34 import qualified Pipes.Safe.Prelude as Pip
  35 import qualified Pipes.Text as PipText
  36 import qualified Pipes.Text.Encoding as PipText
  37 import qualified Symantic.Document as Doc
  38 import qualified System.FilePath as FP
  39 import qualified System.IO as IO
  40 import qualified System.Random as Rand
  41 import qualified Voting.Protocol as VP
  42
  43 import Hjugement.CLI.Utils
  44
  45 -- ** Type 'Registrar_Params'
  46 data Registrar_Params = Registrar_Params
  47  {   registrar_election_crypto  :: VP.FFC
  48  ,   registrar_election_version :: VP.Version
  49  ,   registrar_election_uuid    :: VP.UUID
  50  } deriving (Show)
  51
  52 api_registrar =
  53         "Commands for a registrar."
  54         `helps`
  55         command "registrar" $
  56                 rule "PARAMS"
  57                  (Registrar_Params
  58                          <$> api_param_crypto
  59                          <*> api_param_version
  60                          <*> api_param_uuid)
  61                 <?> (
  62                         api_registrar_credentials <!>
  63                         api_registrar_pubkey)
  64                 <!> api_help False
  65 run_registrar globParams =
  66         (\params ->
  67                 run_registrar_credentials globParams params :!:
  68                 run_registrar_pubkey globParams params
  69         ) :!:
  70         run_help api_registrar
  71
  72 api_registrar_pubkey =
  73         "Derive the public key associated to a specific "<>ref"PRIVATE_CRED"<>"."
  74         `helps`
  75         command "pubkey" $
  76                 var "PRIVATE_CRED"
  77                 <.> response @Natural
  78 run_registrar_pubkey
  79  Global_Params{..}
  80  Registrar_Params{..}
  81  cred =
  82         return $
  83                 VP.reify registrar_election_crypto $ \(_::Proxy c) ->
  84                         VP.nat $ VP.publicKey $
  85                                 VP.credentialSecretKey @VP.FFC @c registrar_election_uuid cred
  86
  87 api_registrar_credentials =
  88         "Generate voters' credentials, either "<>ref "COUNT"<>" sequential identities\
  89  \ or for all identities on each line of "<>ref "FILE"<>".\
  90  \\nThree files are created:\n"<>
  91  Doc.ul
  92   [ ref"<timestamp>.privcreds" <>
  93     " listing the secret key of each voter,\
  94     \ each line formatted as: <Registrar>"<>Doc.space<>"<Credential>.\
  95     \ It "<>Doc.bold "must be destroyed"<>" after dispatching\
  96     \ the credentials to the voters."
  97   , ref"<timestamp>.pubcreds" <>
  98     " listing the public key of each voter,\
  99     \ each line formatted as: <PublicKey>.\
 100     \ It "<>Doc.bold "must be sent"<>" to the election administrator.\
 101     \ Note that the entries are numerically sorted\
 102     \ which forgets whose credential the key belongs to."
 103   , ref"<timestamp>.hashcreds" <>
 104     " listing the hash of the credential of each voter,\
 105     \ each line formatted as: <Registrar>"<>Doc.space<>"<SHA256>.\
 106     \ It is used by the hotline to update the public key on the web server."
 107   ] `helps`
 108         command "credentials" $
 109                 (var @Natural "COUNT" <!>
 110                 var @IO.FilePath "FILE")
 111                 <.> response @(Maybe ())
 112 run_registrar_credentials
 113  glob@Global_Params{..}
 114  Registrar_Params{..} =
 115         run_count :!:
 116         run_file
 117         where
 118         run_count count = do
 119                 outputInfo glob $ "generating credentials for "<>Doc.from count<>" voters"
 120                 run_credentials $
 121                         let i0 = firstIdentity count in
 122                         (Right <$>) $ Pip.each $
 123                                 T.pack . show
 124                                  <$> [i0 .. (i0+count)`minusNatural`1]
 125         run_file file = do
 126                 outputInfo glob $ "generating credentials for voters listed in "<>Doc.from file
 127                 run_credentials $
 128                         let bytes = Pip.withFile file IO.ReadMode PipBS.fromHandle in
 129                         let idents =
 130                                 Lens.view PipText.lines $
 131                                 Lens.view (PipText.utf8 . PipText.eof) bytes in
 132                         Pip.concats idents
 133         run_credentials identsProd =
 134                 VP.reify registrar_election_crypto $ \(_crypto::Proxy c) -> runMaybeT $ do
 135                         now <- Pip.liftIO $ Time.getCurrentTime
 136                         let timestamp = Time.formatTime Time.defaultTimeLocale "%s" now
 137                         let baseFile = global_dir FP.</> timestamp
 138                         pubKeys <- runPipeWithError glob $
 139                                 ((left (\_p -> "UTF-8 decoding failed") <$>) <$>) $
 140                                 Pip.toListM' $
 141                                         identsProd
 142                                          >-> Pip.mapM (\ident -> do
 143                                                 cred <- Pip.liftIO $
 144                                                         Rand.getStdRandom $ runState $
 145                                                         VP.randomCredential
 146                                                 return (ident, cred)
 147                                          )
 148                                          >-> Pip.tee (
 149                                                 Pip.map (\(ident, VP.Credential cred) -> [ident, " ", cred])
 150                                                  >-> writeFileLn glob 0o400 (baseFile FP.<.>"privcreds")
 151                                          )
 152                                          >-> Pip.mapM (\(ident, cred) ->
 153                                                 let secKey = VP.credentialSecretKey @VP.FFC @c registrar_election_uuid cred in
 154                                                 let pubKey = VP.publicKey secKey in
 155                                                 return (ident, pubKey))
 156                                          >-> Pip.tee (
 157                                                 Pip.map (\(ident, pubKey) ->
 158                                                         [ident, " ", VP.hexSHA256 $ VP.bytesNat pubKey]
 159                                                  )
 160                                                  >-> writeFileLn glob 0o444 (baseFile FP.<.>"hashcreds")
 161                                          )
 162                                          >-> Pip.map (\(_ident, pubKey) -> pubKey)
 163                         runPipe $
 164                                 Pip.each (List.sort pubKeys)
 165                                  -- NOTE: numerical sort on Natural (not lexicographic on String)
 166                                  -- which forgets in this file the relationship between
 167                                  -- the voters' identity and public key.
 168                                  -- Unfortunately this requires to accumulates all the pubKey in memory.
 169                                  >-> Pip.map (\pubKey -> [T.pack (show (VP.nat pubKey))])
 170                                  >-> writeFileLn glob 0o444 (baseFile FP.<.>"pubcreds")
 171                         return ()
 172
 173 -- | @('firstIdentity' numIdentities)@ returns @(10'^'i0)@ such that
 174 -- @(10'^'i0 '+' numIdentities '<=' 10'^'(i0'+'1))@,
 175 -- that is to say it returns the lowest identity such that
 176 -- the next @numIdentities@ identities
 177 -- all have the same number of digits.
 178 firstIdentity :: Natural -> Natural
 179 firstIdentity n =
 180         ((10::Natural) ^) $ (ceiling::Double -> Natural) $
 181         logBase 10 $ (fromIntegral n) / 9