1 module Voting.Protocol.Cryptography where
3 import Control.Applicative (pure, (<*>))
4 import Control.Monad (bind, join)
5 import Control.Monad.Trans.Class (lift)
6 import Control.Monad.Except.Trans (ExceptT, throwError)
7 import Data.Argonaut.Core as JSON
8 import Data.Argonaut.Decode (class DecodeJson, decodeJson, (.:))
9 import Data.Argonaut.Encode (class EncodeJson, encodeJson, (:=), (:=?), (~>), (~>?))
10 import Data.Argonaut.Parser as JSON
11 import Data.BigInt (BigInt)
12 import Data.BigInt as BigInt
13 import Data.Boolean (otherwise)
14 import Data.Bounded (class Bounded, top)
15 import Data.Either (Either(..))
16 import Data.Eq (class Eq, (==), (/=))
17 import Data.EuclideanRing (class EuclideanRing, (/), mod)
18 import Data.Foldable (intercalate)
19 import Data.Function (($), identity, (<<<), flip)
20 import Data.Functor (class Functor, (<$>))
21 import Data.HeytingAlgebra ((&&))
22 import Data.Int as Int
23 import Data.List (List, (:))
24 import Data.List as List
25 import Data.List.Lazy as LL
26 import Data.Maybe (Maybe(..), maybe, fromJust)
27 import Data.Monoid (class Monoid, mempty, (<>))
28 import Data.Newtype (class Newtype, wrap, unwrap)
29 import Data.Ord (class Ord, (>=))
30 import Data.Reflection (class Reifies, reflect)
31 import Data.Ring (class Ring, (-), negate)
32 import Data.Semiring (class Semiring, zero, (+), one, (*))
33 import Data.Show (class Show, show)
34 import Data.String.CodeUnits as String
35 import Data.Traversable (sum)
36 import Data.Tuple (Tuple(..))
37 import Data.Unfoldable (replicateA)
38 import Effect (Effect)
39 import Effect.Random (randomInt)
40 import Node.Crypto as Crypto
41 import Node.Crypto.Hash as Crypto
42 import Partial.Unsafe (unsafePartial)
43 import Type.Proxy (Proxy(..))
45 import Voting.Protocol.Utils
46 import Voting.Protocol.Arithmetic
47 import Voting.Protocol.Version
55 newtype Hash crypto c = Hash (E crypto c)
56 derive newtype instance eqHash :: Eq (Hash crypto c)
57 derive newtype instance ordHash :: Ord (Hash crypto c)
58 derive newtype instance showHash :: Show (Hash crypto c)
61 -- | @('hash' bs gs)@ returns as a number in 'G'
62 -- the 'Crypto.SHA256' hash of the given 'BS.ByteString' 'bs'
63 -- prefixing the decimal representation of given subgroup elements 'gs',
64 -- with a comma (",") intercalated between them.
66 -- NOTE: to avoid any collision when the 'hash' function is used in different contexts,
67 -- a message 'gs' is actually prefixed by a 'bs' indicating the context.
69 -- Used by 'proveEncryption' and 'verifyEncryption',
70 -- where the 'bs' usually contains the 'statement' to be proven,
71 -- and the 'gs' contains the 'commitments'.
75 CryptoParams crypto c =>
76 String -> List (G crypto c) ->
79 let s = bs <> intercalate "," (bytesNat <$> gs)
80 h <- Crypto.hex Crypto.SHA256 s
81 pure $ fromNatural $ Natural $
82 unsafePartial $ fromJust $
85 -- | `('bytesNat' x)` returns the serialization of `x`.
86 bytesNat :: forall n. ToNatural n => n -> String
87 bytesNat = show <<< nat
89 -- | `'randomBigInt' low high` returns a random 'BigInt' within `low` and `high`.
91 -- NOTE: adapted from GHC's 'randomIvalInteger'
92 randomBigInt :: BigInt -> BigInt -> Effect BigInt
100 b = BigInt.fromInt srcHigh - BigInt.fromInt srcLow + one
103 -- Probabilities of the most likely and least likely result
104 -- will differ at most by a factor of (1 +- 1/q).
105 -- Assuming the 'random' is uniform, of course.
106 -- On average, log q / log b more random values will be generated
108 q = BigInt.fromInt 1000
109 targetMagnitude = k * q
110 -- Generate random values until we exceed the target magnitude.
112 | mag >= targetMagnitude = pure acc
114 r <- randomInt srcLow srcHigh
116 (acc * b + (BigInt.fromInt r - BigInt.fromInt srcLow))
120 CryptoParams crypto c =>
122 randomE = E <<< Natural <$> randomBigInt zero (unwrap (nat (top::E crypto c)))
124 -- * Type 'Encryption'
125 -- | ElGamal-like encryption.
126 -- Its security relies on the /Discrete Logarithm problem/.
128 -- Because ('groupGen' '^'encNonce '^'secKey '==' 'groupGen' '^'secKey '^'encNonce),
129 -- knowing @secKey@, one can divide 'encryption_vault' by @('encryption_nonce' '^'secKey)@
130 -- to decipher @('groupGen' '^'clear)@, then the @clear@ text must be small to be decryptable,
131 -- because it is encrypted as a power of 'groupGen' (hence the "-like" in "ElGamal-like")
132 -- to enable the additive homomorphism.
134 -- NOTE: Since @('encryption_vault' '*' 'encryption_nonce' '==' 'encryption_nonce' '^' (secKey '+' clear))@,
135 -- then: @(logBase 'encryption_nonce' ('encryption_vault' '*' 'encryption_nonce') '==' secKey '+' clear)@.
136 data Encryption crypto v c = Encryption
137 { encryption_nonce :: G crypto c
138 -- ^ Public part of the randomness 'encNonce' used to 'encrypt' the 'clear' text,
139 -- equal to @('groupGen' '^'encNonce)@
140 , encryption_vault :: G crypto c
141 -- ^ Encrypted 'clear' text,
142 -- equal to @('pubKey' '^'encNone '*' 'groupGen' '^'clear)@
144 derive instance eqEncryption :: Eq (G crypto c) => Eq (Encryption crypto v c)
145 instance showEncryption :: Show (G crypto c) => Show (Encryption crypto v c) where
146 show (Encryption e) = show e
147 instance encodeJsonEncryption ::
149 , CryptoParams crypto c
150 ) => EncodeJson (Encryption crypto v c) where
151 encodeJson (Encryption{encryption_nonce, encryption_vault}) =
152 "alpha" := encryption_nonce ~>
153 "beta" := encryption_vault ~>
155 instance decodeJsonEncryption ::
157 , CryptoParams crypto c
158 ) => DecodeJson (Encryption crypto v c) where
160 obj <- decodeJson json
161 encryption_nonce <- obj .: "alpha"
162 encryption_vault <- obj .: "beta"
163 pure $ Encryption{encryption_nonce, encryption_vault}
165 -- | Additive homomorphism.
166 -- Using the fact that: @'groupGen' '^'x '*' 'groupGen' '^'y '==' 'groupGen' '^'(x'+'y)@.
167 instance additiveEncryption ::
168 CryptoParams crypto c =>
169 Additive (Encryption crypto v c) where
170 gzero = Encryption{encryption_nonce:one, encryption_vault:one}
171 gadd (Encryption x) (Encryption y) = Encryption
172 { encryption_nonce: x.encryption_nonce * y.encryption_nonce
173 , encryption_vault: x.encryption_vault * y.encryption_vault
176 -- *** Type 'EncryptionNonce'
177 type EncryptionNonce = E
179 -- | @('encrypt' pubKey clear)@ returns an ElGamal-like 'Encryption'.
181 -- WARNING: the secret encryption nonce (@encNonce@)
182 -- is returned alongside the 'Encryption'
183 -- in order to 'prove' the validity of the encrypted 'clear' text in 'proveEncryption',
184 -- but this secret @encNonce@ MUST be forgotten after that,
185 -- as it may be used to decipher the 'Encryption'
186 -- without the 'SecretKey' associated with 'pubKey'.
190 CryptoParams crypto c =>
191 PublicKey crypto c -> E crypto c ->
192 Effect (Tuple (EncryptionNonce crypto c) (Encryption crypto v c))
193 encrypt pubKey clear = do
195 -- NOTE: preserve the 'encNonce' for 'prove' in 'proveEncryption'.
196 pure $ Tuple encNonce $
198 { encryption_nonce: groupGen^encNonce
199 , encryption_vault: pubKey ^encNonce * groupGen^clear
203 -- | Non-Interactive Zero-Knowledge 'Proof'
204 -- of knowledge of a discrete logarithm:
205 -- @(secret == logBase base (base^secret))@.
206 data Proof crypto v c = Proof
207 { proof_challenge :: Challenge crypto c
208 -- ^ 'Challenge' sent by the verifier to the prover
209 -- to ensure that the prover really has knowledge
210 -- of the secret and is not replaying.
211 -- Actually, 'proof_challenge' is not sent to the prover,
212 -- but derived from the prover's 'Commitment's and statements
213 -- with a collision resistant 'hash'.
214 -- Hence the prover cannot chose the 'proof_challenge' to his/her liking.
215 , proof_response :: E crypto c
216 -- ^ A discrete logarithm sent by the prover to the verifier,
217 -- as a response to 'proof_challenge'.
219 -- If the verifier observes that @('proof_challenge' '==' 'hash' statement [commitment])@, where:
221 -- * @statement@ is a serialization of a tag, @base@ and @basePowSec@,
222 -- * @commitment '==' 'commit' proof base basePowSec '=='
223 -- base '^' 'proof_response' '*' basePowSec '^' 'proof_challenge'@,
224 -- * and @basePowSec '==' base'^'sec@,
226 -- then, with overwhelming probability (due to the 'hash' function),
227 -- the prover was not able to choose 'proof_challenge'
228 -- yet was able to compute a 'proof_response' such that
229 -- (@commitment '==' base '^' 'proof_response' '*' basePowSec '^' 'proof_challenge'@),
230 -- that is to say: @('proof_response' '==' logBase base 'commitment' '-' sec '*' 'proof_challenge')@,
231 -- therefore the prover knows 'sec'.
233 -- The prover choses 'commitment' to be a random power of @base@,
234 -- to ensure that each 'prove' does not reveal any information
237 derive instance eqProof :: Eq (Proof crypto v c)
238 instance showProof :: Show (Proof crypto v c) where
239 show (Proof e) = show e
240 instance encodeJsonProof ::
242 , CryptoParams crypto c
243 ) => EncodeJson (Proof crypto v c) where
244 encodeJson (Proof{proof_challenge, proof_response}) =
245 "challenge" := proof_challenge ~>
246 "response" := proof_response ~>
248 instance decodeJsonProof ::
250 , CryptoParams crypto c
251 ) => DecodeJson (Proof crypto v c) where
253 obj <- decodeJson json
254 proof_challenge <- obj .: "challenge"
255 proof_response <- obj .: "response"
256 pure $ Proof{proof_challenge, proof_response}
259 -- | Zero-knowledge proof.
261 -- A protocol is /zero-knowledge/ if the verifier
262 -- learns nothing from the protocol except that the prover
265 -- DOC: Mihir Bellare and Phillip Rogaway. Random oracles are practical:
266 -- A paradigm for designing efficient protocols. In ACM-CCS’93, 1993.
267 newtype ZKP = ZKP String
269 -- ** Type 'Challenge'
273 -- An 'Oracle' returns the 'Challenge' of the 'Commitment's
274 -- by 'hash'ing them (eventually with other 'Commitment's).
276 -- Used in 'prove' it enables a Fiat-Shamir transformation
277 -- of an /interactive zero-knowledge/ (IZK) proof
278 -- into a /non-interactive zero-knowledge/ (NIZK) proof.
279 -- That is to say that the verifier does not have
280 -- to send a 'Challenge' to the prover.
281 -- Indeed, the prover now handles the 'Challenge'
282 -- which becomes a (collision resistant) 'hash'
283 -- of the prover's commitments (and statements to be a stronger proof).
285 -- NOTE: the returned 'Challenge' is within 'Effect' because in PureScript
286 -- 'hash'ing needs this (due to the use of Node.Buffer).
287 type Oracle list crypto c = list (Commitment crypto c) -> Effect (Challenge crypto c)
289 -- | @('prove' sec commitmentBases oracle)@
290 -- returns a 'Proof' that @sec@ is known
291 -- (by proving the knowledge of its discrete logarithm).
293 -- The 'Oracle' is given 'Commitment's equal to the 'commitmentBases'
294 -- raised to the power of the secret nonce of the 'Proof',
295 -- as those are the 'Commitment's that the verifier will obtain
296 -- when composing the 'proof_challenge' and 'proof_response' together
299 -- WARNING: for 'prove' to be a so-called /strong Fiat-Shamir transformation/ (not a weak):
300 -- the statement must be included in the 'hash' (along with the commitments).
302 -- NOTE: a 'random' @nonce@ is used to ensure each 'prove'
303 -- does not reveal any information regarding the secret @sec@,
304 -- because two 'Proof's using the same 'Commitment'
305 -- can be used to deduce @sec@ (using the special-soundness).
307 forall crypto v c list.
309 CryptoParams crypto c =>
313 Oracle list crypto c ->
314 Effect (Proof crypto v c)
315 prove sec commitmentBases oracle = do
317 let commitments = (_ ^ nonce) <$> commitmentBases
318 proof_challenge <- oracle commitments
321 , proof_response: nonce `op` (sec*proof_challenge)
324 -- | See comments in 'commit'.
326 if reflect (Proxy::Proxy v) `hasVersionTag` versionTagQuicker
330 -- | Like 'prove' but quicker. It chould replace 'prove' entirely
331 -- when Helios-C specifications will be fixed.
333 forall crypto v c list.
335 CryptoParams crypto c =>
339 Oracle list crypto c ->
340 Effect (Proof crypto v c)
341 proveQuicker sec commitmentBases oracle = do
343 let commitments = (_ ^ nonce) <$> commitmentBases
344 proof_challenge <- oracle commitments
347 , proof_response: nonce - sec*proof_challenge
350 -- | @('fakeProof')@ returns a 'Proof'
351 -- whose 'proof_challenge' and 'proof_response' are uniformly chosen at random,
352 -- instead of @('proof_challenge' '==' 'hash' statement commitments)@
353 -- and @('proof_response' '==' nonce '+' sec '*' 'proof_challenge')@
354 -- as a 'Proof' returned by 'prove'.
356 -- Used in 'proveEncryption' to fill the returned 'DisjProof'
357 -- with fake 'Proof's for all 'Disjunction's but the encrypted one.
360 CryptoParams crypto c =>
361 Effect (Proof crypto v c)
363 proof_challenge <- randomE
364 proof_response <- randomE
365 pure $ Proof{proof_challenge, proof_response}
367 -- ** Type 'Commitment'
368 -- | A commitment from the prover to the verifier.
369 -- It's a power of 'groupGen' chosen randomly by the prover
370 -- when making a 'Proof' with 'prove'.
373 -- | @('commit' proof base basePowSec)@ returns a 'Commitment'
374 -- from the given 'Proof' with the knowledge of the verifier.
378 CryptoParams crypto c =>
383 commit (Proof p) base basePowSec =
384 (base^p.proof_response) `op`
385 (basePowSec^p.proof_challenge)
388 if reflect (Proxy::Proxy v) `hasVersionTag` versionTagQuicker
391 -- TODO: contrary to some textbook presentations,
392 -- @('*')@ should be used instead of @('/')@ to avoid the performance cost
393 -- of a modular exponentiation @('^' ('groupOrder' '-' 'one'))@,
394 -- this is compensated by using @('-')@ instead of @('+')@ in 'prove'.
396 -- | Like 'commit' but quicker. It chould replace 'commit' entirely
397 -- when Helios-C specifications will be fixed.
400 CryptoParams crypto c =>
405 commitQuicker (Proof p) base basePowSec =
406 base^p.proof_response *
407 basePowSec^p.proof_challenge
409 -- * Type 'Disjunction'
410 -- | A 'Disjunction' is an 'inverse'd @('groupGen' '^'opinion)@
411 -- it's used in 'proveEncryption' to generate a 'Proof'
412 -- that an 'encryption_vault' contains a given @('groupGen' '^'opinion)@,
415 booleanDisjunctions :: forall crypto c. CryptoParams crypto c => LL.List (Disjunction crypto c)
416 booleanDisjunctions = LL.take 2 $ groupGenInverses::LL.List (G crypto c)
418 intervalDisjunctions ::
420 CryptoParams crypto c =>
421 Natural -> Natural -> LL.List (Disjunction crypto c)
422 intervalDisjunctions mini maxi =
423 LL.take (int $ (unwrap (nat maxi) + one)-unwrap (nat mini)) $
424 LL.drop (int $ unwrap (nat mini)) $
425 groupGenInverses :: LL.List (G crypto c)
427 int = Int.round <<< BigInt.toNumber
429 -- ** Type 'DisjProof'
430 -- | A list of 'Proof's to prove that the opinion within an 'Encryption'
431 -- is indexing a 'Disjunction' within a list of them,
432 -- without revealing which opinion it is.
433 newtype DisjProof crypto v c = DisjProof (List (Proof crypto v c))
434 derive newtype instance eqDisjProof :: Eq (DisjProof crypto v c)
435 derive newtype instance showDisjProof :: Show (DisjProof crypto v c)
436 derive newtype instance encodeJsonDisjProof :: (Reifies v Version, CryptoParams crypto c) => EncodeJson (DisjProof crypto v c)
437 derive newtype instance decodeJsonDisjProof :: (Reifies v Version, CryptoParams crypto c) => DecodeJson (DisjProof crypto v c)
438 instance newtypeDisjProof :: Newtype (DisjProof crypto v c) (List (Proof crypto v c)) where
440 unwrap (DisjProof x) = x
442 -- | @('proveEncryption' elecPubKey voterZKP (prevDisjs,nextDisjs) (encNonce,enc))@
443 -- returns a 'DisjProof' that 'enc' 'encrypt's
444 -- the 'Disjunction' 'd' between 'prevDisjs' and 'nextDisjs'.
446 -- The prover proves that it knows an 'encNonce', such that:
447 -- @(enc '==' Encryption{encryption_nonce='groupGen' '^'encNonce, encryption_vault=elecPubKey'^'encNonce '*' groupGen'^'d})@
449 -- A /NIZK Disjunctive Chaum Pedersen Logarithm Equality/ is used.
451 -- DOC: Pierrick Gaudry. <https://hal.inria.fr/hal-01576379 Some ZK security proofs for Belenios>, 2017.
455 CryptoParams crypto c =>
456 PublicKey crypto c -> ZKP ->
457 Tuple (List (Disjunction crypto c)) (List (Disjunction crypto c)) ->
458 Tuple (EncryptionNonce crypto c) (Encryption crypto v c) ->
459 Effect (DisjProof crypto v c)
460 proveEncryption elecPubKey voterZKP (Tuple prevDisjs nextDisjs) (Tuple encNonce enc) = do
461 -- Fake proofs for all 'Disjunction's except the genuine one.
462 prevFakeProofs <- replicateA (List.length prevDisjs) fakeProof
463 nextFakeProofs <- replicateA (List.length nextDisjs) fakeProof
464 let fakeChallengeSum = sum ((\(Proof p) -> p.proof_challenge) <$> prevFakeProofs) +
465 sum ((\(Proof p) -> p.proof_challenge) <$> nextFakeProofs)
466 let statement = encryptionStatement voterZKP enc
467 genuineProof <- prove encNonce (groupGen : elecPubKey : List.Nil) $ \genuineCommitments -> do
468 let validCommitments = List.zipWith (encryptionCommitments elecPubKey enc)
469 let prevCommitments = validCommitments prevDisjs prevFakeProofs
470 let nextCommitments = validCommitments nextDisjs nextFakeProofs
471 let commitments = join prevCommitments <> genuineCommitments <> join nextCommitments
472 challenge <- hash statement commitments
473 let genuineChallenge = challenge - fakeChallengeSum
474 pure genuineChallenge
475 -- NOTE: here by construction (genuineChallenge == challenge - fakeChallengeSum)
476 -- thus (sum ((\(Proof p) -> p.proof_challenge) <$> proofs) == challenge)
477 -- as checked in 'verifyEncryption'.
478 let proofs = prevFakeProofs <> (genuineProof : nextFakeProofs)
479 pure (DisjProof proofs)
484 CryptoParams crypto c =>
485 PublicKey crypto c -> ZKP ->
486 List (Disjunction crypto c) -> Tuple (Encryption crypto v c) (DisjProof crypto v c) ->
487 ExceptT ErrorVerifyEncryption Effect Boolean
488 verifyEncryption elecPubKey voterZKP disjs (Tuple enc (DisjProof proofs)) =
489 case isoZipWith (encryptionCommitments elecPubKey enc) disjs proofs of
491 throwError $ ErrorVerifyEncryption_InvalidProofLength
492 (nat $ List.length proofs)
493 (nat $ List.length disjs)
494 Just commitments -> do
495 h <- lift $ hash (encryptionStatement voterZKP enc) (join commitments)
496 pure (challengeSum == h)
498 challengeSum = sum ((\(Proof p) -> p.proof_challenge) <$> proofs)
501 encryptionStatement ::
503 CryptoParams crypto c =>
504 ZKP -> Encryption crypto v c -> String
505 encryptionStatement (ZKP voterZKP) (Encryption enc) =
506 "prove|"<>voterZKP<>"|"
507 <> bytesNat enc.encryption_nonce<>","
508 <> bytesNat enc.encryption_vault<>"|"
510 -- | @('encryptionCommitments' elecPubKey enc disj proof)@
511 -- returns the 'Commitment's with only the knowledge of the verifier.
513 -- For the prover the 'Proof' comes from @fakeProof@,
514 -- and for the verifier the 'Proof' comes from the prover.
515 encryptionCommitments ::
518 CryptoParams crypto c =>
519 PublicKey crypto c -> Encryption crypto v c ->
520 Disjunction crypto c -> Proof crypto v c -> List (G crypto c)
521 encryptionCommitments elecPubKey (Encryption enc) disj proof =
522 commit proof groupGen enc.encryption_nonce :
523 -- == groupGen ^ nonce if 'Proof' comes from 'prove'.
524 -- base==groupGen, basePowSec==groupGen^encNonce.
525 commit proof elecPubKey (enc.encryption_vault*disj) :
526 -- == elecPubKey ^ nonce if 'Proof' comes from 'prove'
527 -- and 'encryption_vault' encrypts (- logBase groupGen disj).
528 -- base==elecPubKey, basePowSec==elecPubKey^encNonce.
531 -- ** Type 'ErrorVerifyEncryption'
532 -- | Error raised by 'verifyEncryption'.
533 data ErrorVerifyEncryption
534 = ErrorVerifyEncryption_InvalidProofLength Natural Natural
535 -- ^ When the number of proofs is different than
536 -- the number of 'Disjunction's.
537 -- deriving (Eq,Show)
539 -- * Type 'Signature'
540 -- | Schnorr-like signature.
542 -- Used by each voter to sign his/her encrypted 'Ballot'
543 -- using his/her 'Credential',
544 -- in order to avoid ballot stuffing.
545 data Signature crypto v c = Signature
546 { signature_publicKey :: PublicKey crypto c
547 -- ^ Verification key.
548 , signature_proof :: Proof crypto v c
550 instance encodeJsonSignature ::
552 , CryptoParams crypto c
553 ) => EncodeJson (Signature crypto v c) where
554 encodeJson (Signature{signature_publicKey:pubKey, signature_proof:Proof p}) =
555 "public_key" := pubKey ~>
556 "challenge" := p.proof_challenge ~>
557 "response" := p.proof_response ~>
559 instance decodeJsonSignature ::
561 , CryptoParams crypto c
562 ) => DecodeJson (Signature crypto v c) where
564 obj <- decodeJson json
565 signature_publicKey <- obj .: "public_key"
566 proof_challenge <- obj .: "challenge"
567 proof_response <- obj .: "response"
568 let signature_proof = Proof{proof_challenge, proof_response}
569 pure $ Signature{signature_publicKey, signature_proof}