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