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.Applicative (Applicative(..))
   8 import Control.Monad (Monad(..), forM, forM_, join, void)
   9 import Control.Monad.Trans.Class (MonadTrans(..))
  10 import Control.Monad.Trans.State.Strict (runState, runStateT)
  11 import Data.Bool
  12 import Data.ByteString (ByteString)
  13 import Data.Either (Either(..))
  14 import Data.Foldable (Foldable, foldMap, length)
  15 import Data.Function (($), (.), flip)
  16 import Data.Functor ((<$>))
  17 import Data.Int (Int)
  18 import Data.Maybe (Maybe(..), maybe, fromMaybe)
  19 import Data.Ord (Ord(..))
  20 import Data.Proxy (Proxy(..))
  21 import Data.Semigroup (Semigroup(..))
  22 import Data.String (String)
  23 import Data.Text (Text)
  24 import GHC.Natural (minusNatural, minusNaturalMaybe)
  25 import Numeric.Natural (Natural)
  26 import Pipes ((>->))
  27 import Prelude (logBase, ceiling, Num(..), (/), (^), fromIntegral, Double)
  28 import Symantic.CLI as CLI
  29 import Text.Show (Show(..))
  30 import qualified Data.ByteString as BS
  31 import qualified Data.ByteString.Char8 as BS8
  32 import qualified Data.ByteString.Lazy as BSL
  33 import qualified Data.List as List
  34 import qualified Data.Text as T
  35 import qualified Data.Text.Encoding as T
  36 import qualified Data.Text.Lazy as TL
  37 import qualified Data.Text.Lazy.Encoding as TL
  38 import qualified Data.Text.Lazy.IO as TL
  39 import qualified Data.Time as Time
  40 import qualified Lens.Family as Lens
  41 import qualified Lens.Family.State.Strict as Lens
  42 import qualified Pipes as Pip
  43 import qualified Pipes.ByteString as PipBS
  44 import qualified Pipes.Group as Pip
  45 import qualified Pipes.Prelude as Pip
  46 import qualified Pipes.Safe as Pip
  47 import qualified Pipes.Safe.Prelude as Pip
  48 import qualified Pipes.Text as PipText
  49 import qualified Pipes.Text.Encoding as PipText
  50 import qualified Pipes.Text.IO as PipText
  51 import qualified Symantic.Document as Doc
  52 import qualified System.FilePath as FP
  53 import qualified System.IO as IO
  54 import qualified System.Posix as Posix
  55 import qualified System.Random as Rand
  56 import qualified Voting.Protocol as VP
  57
  58 import Hjugement.CLI.Utils
  59
  60 -- ** Type 'Registrar_Options'
  61 data Registrar_Options = Registrar_Options
  62  {   registrar_election_crypto :: VP.FFC
  63  ,   registrar_election_uuid   :: VP.UUID
  64  } deriving (Show)
  65
  66 api_registrar =
  67         "Commands for a registrar."
  68         `helps`
  69         command "registrar" $
  70                 rule "PARAMS"
  71                  (Registrar_Options
  72                          <$> option_crypto
  73                          <*> option_uuid
  74                  )
  75                 <?> (
  76                         api_registrar_credentials <!>
  77                         api_registrar_pubkey
  78                  )
  79                 <!> api_help False
  80 run_registrar globOpts =
  81         (\opts ->
  82                 run_registrar_credentials globOpts opts :!:
  83                 run_registrar_pubkey globOpts opts
  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_Options{..} o@Registrar_Options{..} 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 @Doc
 124 run_registrar_credentials
 125  Global_Options{..}
 126  o@Registrar_Options{..} =
 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 = do
 144                 now <- Time.getCurrentTime
 145                 let timestamp = Time.formatTime Time.defaultTimeLocale "%s" now
 146                 let baseFile = global_dir FP.</> timestamp
 147                 VP.reify registrar_election_crypto $ \(crypto::Proxy c) ->
 148                         Pip.runSafeT $ Pip.runEffect $ do
 149                                 -- TODO: match err to check utf8 decoding went well
 150                                 (pubKeys, err) <- 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                                 Pip.each (List.sort pubKeys)
 174                                  -- NOTE: numerical sort on Natural (not lexicographic on String)
 175                                  -- which forgets in this file the relationship between
 176                                  -- the voters' identity and public key.
 177                                  -- Unfortunately this requires to accumulates all the pubKey in memory.
 178                                  >-> Pip.map (\pubKey -> [T.pack (show (VP.nat pubKey))])
 179                                  >-> writeFileLn 0o444 (baseFile FP.<.>"pubcreds")
 180                 return ""
 181
 182 -- | @('firstIdentity' numIdentities)@ returns @(10'^'i0)@ such that
 183 -- @(10'^'i0 '+' numIdentities '<=' 10'^'(i0'+'1))@,
 184 -- that is to say it returns the lowest identity such that
 185 -- the next @numIdentities@ identities
 186 -- all have the same number of digits.
 187 firstIdentity :: Natural -> Natural
 188 firstIdentity n =
 189         ((10::Natural) ^) $ (ceiling::Double -> Natural) $
 190         logBase 10 $ (fromIntegral n) / 9