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_uuid   :: VP.UUID
  49  } deriving (Show)
  50
  51 api_registrar =
  52         "Commands for a registrar."
  53         `helps`
  54         command "registrar" $
  55                 rule "PARAMS"
  56                  (Registrar_Params
  57                          <$> api_param_crypto
  58                          <*> api_param_uuid)
  59                 <?> (
  60                         api_registrar_credentials <!>
  61                         api_registrar_pubkey)
  62                 <!> api_help False
  63 run_registrar globParams =
  64         (\params ->
  65                 run_registrar_credentials globParams params :!:
  66                 run_registrar_pubkey globParams params
  67         ) :!:
  68         run_help api_registrar
  69
  70 api_registrar_pubkey =
  71         "Derive the public key associated to a specific "<>ref"PRIVATE_CRED"<>"."
  72         `helps`
  73         command "pubkey" $
  74                 var "PRIVATE_CRED"
  75                 <.> response @Natural
  76 run_registrar_pubkey
  77  Global_Params{..}
  78  Registrar_Params{..}
  79  cred =
  80         return $
  81                 VP.reify registrar_election_crypto $ \(_::Proxy c) ->
  82                         VP.nat $ VP.publicKey $
  83                                 VP.credentialSecretKey @c registrar_election_uuid cred
  84
  85 api_registrar_credentials =
  86         "Generate voters' credentials, either "<>ref "COUNT"<>" sequential identities\
  87  \ or for all identities on each line of "<>ref "FILE"<>".\
  88  \\nThree files are created:\n"<>
  89  Doc.ul
  90   [ ref"<timestamp>.privcreds" <>
  91     " listing the secret key of each voter,\
  92     \ each line formatted as: <Registrar>"<>Doc.space<>"<Credential>.\
  93     \ It "<>Doc.bold "must be destroyed"<>" after dispatching\
  94     \ the credentials to the voters."
  95   , ref"<timestamp>.pubcreds" <>
  96     " listing the public key of each voter,\
  97     \ each line formatted as: <PublicKey>.\
  98     \ It "<>Doc.bold "must be sent"<>" to the election administrator.\
  99     \ Note that the entries are numerically sorted\
 100     \ which forgets whose credential the key belongs to."
 101   , ref"<timestamp>.hashcreds" <>
 102     " listing the hash of the credential of each voter,\
 103     \ each line formatted as: <Registrar>"<>Doc.space<>"<SHA256>.\
 104     \ It is used by the hotline to update the public key on the web server."
 105   ] `helps`
 106         command "credentials" $
 107                 (var @Natural "COUNT" <!>
 108                 var @IO.FilePath "FILE")
 109                 <.> response @(Maybe ())
 110 run_registrar_credentials
 111  glob@Global_Params{..}
 112  Registrar_Params{..} =
 113         run_count :!:
 114         run_file
 115         where
 116         run_count count = do
 117                 outputInfo glob $ "generating credentials for "<>Doc.from count<>" voters"
 118                 run_credentials $
 119                         let i0 = firstIdentity count in
 120                         (Right <$>) $ Pip.each $
 121                                 T.pack . show
 122                                  <$> [i0 .. (i0+count)`minusNatural`1]
 123         run_file file = do
 124                 outputInfo glob $ "generating credentials for voters listed in "<>Doc.from file
 125                 run_credentials $
 126                         let bytes = Pip.withFile file IO.ReadMode PipBS.fromHandle in
 127                         let idents =
 128                                 Lens.view PipText.lines $
 129                                 Lens.view (PipText.utf8 . PipText.eof) bytes in
 130                         Pip.concats idents
 131         run_credentials identsProd =
 132                 VP.reify registrar_election_crypto $ \(_crypto::Proxy c) -> runMaybeT $ do
 133                         now <- Pip.liftIO $ Time.getCurrentTime
 134                         let timestamp = Time.formatTime Time.defaultTimeLocale "%s" now
 135                         let baseFile = global_dir FP.</> timestamp
 136                         pubKeys <- runPipeWithError glob $
 137                                 ((left (\_p -> "UTF-8 decoding failed") <$>) <$>) $
 138                                 Pip.toListM' $
 139                                         identsProd
 140                                          >-> Pip.mapM (\ident -> do
 141                                                 cred <- Pip.liftIO $
 142                                                         Rand.getStdRandom $ runState $
 143                                                         VP.randomCredential
 144                                                 return (ident, cred)
 145                                          )
 146                                          >-> Pip.tee (
 147                                                 Pip.map (\(ident, VP.Credential cred) -> [ident, " ", cred])
 148                                                  >-> writeFileLn glob 0o400 (baseFile FP.<.>"privcreds")
 149                                          )
 150                                          >-> Pip.mapM (\(ident, cred) ->
 151                                                 let secKey = VP.credentialSecretKey @c registrar_election_uuid cred in
 152                                                 let pubKey = VP.publicKey secKey in
 153                                                 return (ident, pubKey))
 154                                          >-> Pip.tee (
 155                                                 Pip.map (\(ident, pubKey) ->
 156                                                         [ident, " ", VP.hexSHA256 $ VP.bytesNat pubKey]
 157                                                  )
 158                                                  >-> writeFileLn glob 0o444 (baseFile FP.<.>"hashcreds")
 159                                          )
 160                                          >-> Pip.map (\(_ident, pubKey) -> pubKey)
 161                         runPipe $
 162                                 Pip.each (List.sort pubKeys)
 163                                  -- NOTE: numerical sort on Natural (not lexicographic on String)
 164                                  -- which forgets in this file the relationship between
 165                                  -- the voters' identity and public key.
 166                                  -- Unfortunately this requires to accumulates all the pubKey in memory.
 167                                  >-> Pip.map (\pubKey -> [T.pack (show (VP.nat pubKey))])
 168                                  >-> writeFileLn glob 0o444 (baseFile FP.<.>"pubcreds")
 169                         return ()
 170
 171 -- | @('firstIdentity' numIdentities)@ returns @(10'^'i0)@ such that
 172 -- @(10'^'i0 '+' numIdentities '<=' 10'^'(i0'+'1))@,
 173 -- that is to say it returns the lowest identity such that
 174 -- the next @numIdentities@ identities
 175 -- all have the same number of digits.
 176 firstIdentity :: Natural -> Natural
 177 firstIdentity n =
 178         ((10::Natural) ^) $ (ceiling::Double -> Natural) $
 179         logBase 10 $ (fromIntegral n) / 9