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