]> Git — Sourcephile - majurity.git/blob - hjugement-cli/src/Hjugement/CLI/Registrar.hs
protocol: no padding for Base64SHA256.
[majurity.git] / 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