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

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