module Voting.Protocol.Cryptography where
-import Effect (Effect)
-import Control.Applicative (pure)
-import Control.Monad (bind)
+import Control.Applicative (pure, (<*>))
+import Control.Monad (bind, join)
+import Control.Monad.Trans.Class (lift)
+import Control.Monad.Except.Trans (ExceptT)
import Data.Argonaut.Core as JSON
-import Data.Argonaut.Decode (class DecodeJson, decodeJson)
-import Data.Argonaut.Encode (class EncodeJson, encodeJson)
+import Data.Argonaut.Decode (class DecodeJson, decodeJson, (.:))
+import Data.Argonaut.Encode (class EncodeJson, encodeJson, (:=), (:=?), (~>), (~>?))
import Data.Argonaut.Parser as JSON
import Data.BigInt (BigInt)
import Data.BigInt as BigInt
import Data.EuclideanRing (class EuclideanRing, (/), mod)
import Data.Foldable (intercalate)
import Data.Function (($), identity, (<<<), flip)
-import Data.Functor ((<$>))
+import Data.Functor (class Functor, (<$>))
import Data.HeytingAlgebra ((&&))
+import Data.Int as Int
import Data.List (List, (:))
+import Data.List as List
+import Data.List.Lazy as LL
import Data.Maybe (Maybe(..), maybe, fromJust)
import Data.Monoid (class Monoid, mempty, (<>))
import Data.Newtype (class Newtype, wrap, unwrap)
import Data.Semiring (class Semiring, zero, (+), one, (*))
import Data.Show (class Show, show)
import Data.String.CodeUnits as String
+import Data.Traversable (sum)
+import Data.Tuple (Tuple(..))
+import Data.Unfoldable (replicateA)
+import Effect (Effect)
+import Effect.Random (randomInt)
import Node.Crypto as Crypto
import Node.Crypto.Hash as Crypto
-import Effect.Random (randomInt)
import Partial.Unsafe (unsafePartial)
import Type.Proxy (Proxy(..))
import Voting.Protocol.Arithmetic
+import Voting.Protocol.Version
+
+-- * Type 'PublicKey'
+type PublicKey = G
+-- * Type 'SecretKey'
+type SecretKey = E
-- * Type 'Hash'
newtype Hash crypto c = Hash (E crypto c)
-- will differ at most by a factor of (1 +- 1/q).
-- Assuming the 'random' is uniform, of course.
-- On average, log q / log b more random values will be generated
- -- than the minimum
+ -- than the minimum.
q = BigInt.fromInt 1000
targetMagnitude = k * q
- -- generate random values until we exceed the target magnitude
+ -- Generate random values until we exceed the target magnitude.
f mag acc
| mag >= targetMagnitude = pure acc
| otherwise = do
CryptoParams crypto c =>
Effect (E crypto c)
randomE = E <<< Natural <$> randomBigInt zero (unwrap (nat (top::E crypto c)))
+
+-- * Type 'Encryption'
+-- | ElGamal-like encryption.
+-- Its security relies on the /Discrete Logarithm problem/.
+--
+-- Because ('groupGen' '^'encNonce '^'secKey '==' 'groupGen' '^'secKey '^'encNonce),
+-- knowing @secKey@, one can divide 'encryption_vault' by @('encryption_nonce' '^'secKey)@
+-- to decipher @('groupGen' '^'clear)@, then the @clear@ text must be small to be decryptable,
+-- because it is encrypted as a power of 'groupGen' (hence the "-like" in "ElGamal-like")
+-- to enable the additive homomorphism.
+--
+-- NOTE: Since @('encryption_vault' '*' 'encryption_nonce' '==' 'encryption_nonce' '^' (secKey '+' clear))@,
+-- then: @(logBase 'encryption_nonce' ('encryption_vault' '*' 'encryption_nonce') '==' secKey '+' clear)@.
+data Encryption crypto v c = Encryption
+ { encryption_nonce :: G crypto c
+ -- ^ Public part of the randomness 'encNonce' used to 'encrypt' the 'clear' text,
+ -- equal to @('groupGen' '^'encNonce)@
+ , encryption_vault :: G crypto c
+ -- ^ Encrypted 'clear' text,
+ -- equal to @('pubKey' '^'encNone '*' 'groupGen' '^'clear)@
+ }
+derive instance eqEncryption :: Eq (G crypto c) => Eq (Encryption crypto v c)
+instance showEncryption :: Show (G crypto c) => Show (Encryption crypto v c) where
+ show (Encryption e) = show e
+instance encodeJsonEncryption ::
+ ( Reifies v Version
+ , CryptoParams crypto c
+ ) => EncodeJson (Encryption crypto v c) where
+ encodeJson (Encryption{encryption_nonce, encryption_vault}) =
+ "alpha" := encryption_nonce ~>
+ "beta" := encryption_vault ~>
+ JSON.jsonEmptyObject
+instance decodeJsonEncryption ::
+ ( Reifies v Version
+ , CryptoParams crypto c
+ ) => DecodeJson (Encryption crypto v c) where
+ decodeJson json = do
+ obj <- decodeJson json
+ encryption_nonce <- obj .: "alpha"
+ encryption_vault <- obj .: "beta"
+ pure $ Encryption{encryption_nonce, encryption_vault}
+
+-- | Additive homomorphism.
+-- Using the fact that: @'groupGen' '^'x '*' 'groupGen' '^'y '==' 'groupGen' '^'(x'+'y)@.
+instance additiveEncryption ::
+ CryptoParams crypto c =>
+ Additive (Encryption crypto v c) where
+ gzero = Encryption{encryption_nonce:one, encryption_vault:one}
+ gadd (Encryption x) (Encryption y) = Encryption
+ { encryption_nonce: x.encryption_nonce * y.encryption_nonce
+ , encryption_vault: x.encryption_vault * y.encryption_vault
+ }
+
+-- *** Type 'EncryptionNonce'
+type EncryptionNonce = E
+
+-- | @('encrypt' pubKey clear)@ returns an ElGamal-like 'Encryption'.
+--
+-- WARNING: the secret encryption nonce (@encNonce@)
+-- is returned alongside the 'Encryption'
+-- in order to 'prove' the validity of the encrypted 'clear' text in 'proveEncryption',
+-- but this secret @encNonce@ MUST be forgotten after that,
+-- as it may be used to decipher the 'Encryption'
+-- without the 'SecretKey' associated with 'pubKey'.
+encrypt ::
+ forall crypto v c.
+ Reifies v Version =>
+ CryptoParams crypto c =>
+ PublicKey crypto c -> E crypto c ->
+ Effect (Tuple (EncryptionNonce crypto c) (Encryption crypto v c))
+encrypt pubKey clear = do
+ encNonce <- randomE
+ -- NOTE: preserve the 'encNonce' for 'prove' in 'proveEncryption'.
+ pure $ Tuple encNonce $
+ Encryption
+ { encryption_nonce: groupGen^encNonce
+ , encryption_vault: pubKey ^encNonce * groupGen^clear
+ }
+
+-- * Type 'Proof'
+-- | Non-Interactive Zero-Knowledge 'Proof'
+-- of knowledge of a discrete logarithm:
+-- @(secret == logBase base (base^secret))@.
+data Proof crypto v c = Proof
+ { proof_challenge :: Challenge crypto c
+ -- ^ 'Challenge' sent by the verifier to the prover
+ -- to ensure that the prover really has knowledge
+ -- of the secret and is not replaying.
+ -- Actually, 'proof_challenge' is not sent to the prover,
+ -- but derived from the prover's 'Commitment's and statements
+ -- with a collision resistant 'hash'.
+ -- Hence the prover cannot chose the 'proof_challenge' to his/her liking.
+ , proof_response :: E crypto c
+ -- ^ A discrete logarithm sent by the prover to the verifier,
+ -- as a response to 'proof_challenge'.
+ --
+ -- If the verifier observes that @('proof_challenge' '==' 'hash' statement [commitment])@, where:
+ --
+ -- * @statement@ is a serialization of a tag, @base@ and @basePowSec@,
+ -- * @commitment '==' 'commit' proof base basePowSec '=='
+ -- base '^' 'proof_response' '*' basePowSec '^' 'proof_challenge'@,
+ -- * and @basePowSec '==' base'^'sec@,
+ --
+ -- then, with overwhelming probability (due to the 'hash' function),
+ -- the prover was not able to choose 'proof_challenge'
+ -- yet was able to compute a 'proof_response' such that
+ -- (@commitment '==' base '^' 'proof_response' '*' basePowSec '^' 'proof_challenge'@),
+ -- that is to say: @('proof_response' '==' logBase base 'commitment' '-' sec '*' 'proof_challenge')@,
+ -- therefore the prover knows 'sec'.
+ --
+ -- The prover choses 'commitment' to be a random power of @base@,
+ -- to ensure that each 'prove' does not reveal any information
+ -- about its secret.
+ }
+derive instance eqProof :: Eq (Proof crypto v c)
+instance showProof :: Show (Proof crypto v c) where
+ show (Proof e) = show e
+instance encodeJsonProof ::
+ ( Reifies v Version
+ , CryptoParams crypto c
+ ) => EncodeJson (Proof crypto v c) where
+ encodeJson (Proof{proof_challenge, proof_response}) =
+ "challenge" := proof_challenge ~>
+ "response" := proof_response ~>
+ JSON.jsonEmptyObject
+instance decodeJsonProof ::
+ ( Reifies v Version
+ , CryptoParams crypto c
+ ) => DecodeJson (Proof crypto v c) where
+ decodeJson json = do
+ obj <- decodeJson json
+ proof_challenge <- obj .: "challenge"
+ proof_response <- obj .: "response"
+ pure $ Proof{proof_challenge, proof_response}
+
+-- ** Type 'ZKP'
+-- | Zero-knowledge proof.
+--
+-- A protocol is /zero-knowledge/ if the verifier
+-- learns nothing from the protocol except that the prover
+-- knows the secret.
+--
+-- DOC: Mihir Bellare and Phillip Rogaway. Random oracles are practical:
+-- A paradigm for designing efficient protocols. In ACM-CCS’93, 1993.
+newtype ZKP = ZKP String
+
+-- ** Type 'Challenge'
+type Challenge = E
+
+-- ** Type 'Oracle'
+-- An 'Oracle' returns the 'Challenge' of the 'Commitment's
+-- by 'hash'ing them (eventually with other 'Commitment's).
+--
+-- Used in 'prove' it enables a Fiat-Shamir transformation
+-- of an /interactive zero-knowledge/ (IZK) proof
+-- into a /non-interactive zero-knowledge/ (NIZK) proof.
+-- That is to say that the verifier does not have
+-- to send a 'Challenge' to the prover.
+-- Indeed, the prover now handles the 'Challenge'
+-- which becomes a (collision resistant) 'hash'
+-- of the prover's commitments (and statements to be a stronger proof).
+--
+-- NOTE: the returned 'Challenge' is within 'Effect' because in PureScript
+-- 'hash'ing needs this (due to the use of Node.Buffer).
+type Oracle list crypto c = list (Commitment crypto c) -> Effect (Challenge crypto c)
+
+-- | @('prove' sec commitmentBases oracle)@
+-- returns a 'Proof' that @sec@ is known
+-- (by proving the knowledge of its discrete logarithm).
+--
+-- The 'Oracle' is given 'Commitment's equal to the 'commitmentBases'
+-- raised to the power of the secret nonce of the 'Proof',
+-- as those are the 'Commitment's that the verifier will obtain
+-- when composing the 'proof_challenge' and 'proof_response' together
+-- (with 'commit').
+--
+-- WARNING: for 'prove' to be a so-called /strong Fiat-Shamir transformation/ (not a weak):
+-- the statement must be included in the 'hash' (along with the commitments).
+--
+-- NOTE: a 'random' @nonce@ is used to ensure each 'prove'
+-- does not reveal any information regarding the secret @sec@,
+-- because two 'Proof's using the same 'Commitment'
+-- can be used to deduce @sec@ (using the special-soundness).
+prove ::
+ forall crypto v c list.
+ Reifies v Version =>
+ CryptoParams crypto c =>
+ Functor list =>
+ E crypto c ->
+ list (G crypto c) ->
+ Oracle list crypto c ->
+ Effect (Proof crypto v c)
+prove sec commitmentBases oracle = do
+ nonce <- randomE
+ let commitments = (_ ^ nonce) <$> commitmentBases
+ proof_challenge <- oracle commitments
+ pure $ Proof
+ { proof_challenge
+ , proof_response: nonce `op` (sec*proof_challenge)
+ }
+ where
+ -- | See comments in 'commit'.
+ op =
+ if reflect (Proxy::Proxy v) `hasVersionTag` versionTagQuicker
+ then (-)
+ else (+)
+
+-- | Like 'prove' but quicker. It chould replace 'prove' entirely
+-- when Helios-C specifications will be fixed.
+proveQuicker ::
+ forall crypto v c list.
+ Reifies v Version =>
+ CryptoParams crypto c =>
+ Functor list =>
+ E crypto c ->
+ list (G crypto c) ->
+ Oracle list crypto c ->
+ Effect (Proof crypto v c)
+proveQuicker sec commitmentBases oracle = do
+ nonce <- randomE
+ let commitments = (_ ^ nonce) <$> commitmentBases
+ proof_challenge <- oracle commitments
+ pure $ Proof
+ { proof_challenge
+ , proof_response: nonce - sec*proof_challenge
+ }
+
+-- | @('fakeProof')@ returns a 'Proof'
+-- whose 'proof_challenge' and 'proof_response' are uniformly chosen at random,
+-- instead of @('proof_challenge' '==' 'hash' statement commitments)@
+-- and @('proof_response' '==' nonce '+' sec '*' 'proof_challenge')@
+-- as a 'Proof' returned by 'prove'.
+--
+-- Used in 'proveEncryption' to fill the returned 'DisjProof'
+-- with fake 'Proof's for all 'Disjunction's but the encrypted one.
+fakeProof ::
+ forall crypto v c.
+ CryptoParams crypto c =>
+ Effect (Proof crypto v c)
+fakeProof = do
+ proof_challenge <- randomE
+ proof_response <- randomE
+ pure $ Proof{proof_challenge, proof_response}
+
+-- ** Type 'Commitment'
+-- | A commitment from the prover to the verifier.
+-- It's a power of 'groupGen' chosen randomly by the prover
+-- when making a 'Proof' with 'prove'.
+type Commitment = G
+
+-- | @('commit' proof base basePowSec)@ returns a 'Commitment'
+-- from the given 'Proof' with the knowledge of the verifier.
+commit ::
+ forall crypto v c.
+ Reifies v Version =>
+ CryptoParams crypto c =>
+ Proof crypto v c ->
+ G crypto c ->
+ G crypto c ->
+ Commitment crypto c
+commit (Proof p) base basePowSec =
+ (base^p.proof_response) `op`
+ (basePowSec^p.proof_challenge)
+ where
+ op =
+ if reflect (Proxy::Proxy v) `hasVersionTag` versionTagQuicker
+ then (*)
+ else (/)
+ -- TODO: contrary to some textbook presentations,
+ -- @('*')@ should be used instead of @('/')@ to avoid the performance cost
+ -- of a modular exponentiation @('^' ('groupOrder' '-' 'one'))@,
+ -- this is compensated by using @('-')@ instead of @('+')@ in 'prove'.
+
+-- | Like 'commit' but quicker. It chould replace 'commit' entirely
+-- when Helios-C specifications will be fixed.
+commitQuicker ::
+ forall crypto v c.
+ CryptoParams crypto c =>
+ Proof crypto v c ->
+ G crypto c ->
+ G crypto c ->
+ Commitment crypto c
+commitQuicker (Proof p) base basePowSec =
+ base^p.proof_response *
+ basePowSec^p.proof_challenge
+
+-- * Type 'Disjunction'
+-- | A 'Disjunction' is an 'inverse'd @('groupGen' '^'opinion)@
+-- it's used in 'proveEncryption' to generate a 'Proof'
+-- that an 'encryption_vault' contains a given @('groupGen' '^'opinion)@,
+type Disjunction = G
+
+booleanDisjunctions :: forall crypto c. CryptoParams crypto c => LL.List (Disjunction crypto c)
+booleanDisjunctions = LL.take 2 $ groupGenInverses::LL.List (G crypto c)
+
+intervalDisjunctions ::
+ forall crypto c.
+ CryptoParams crypto c =>
+ Natural -> Natural -> LL.List (Disjunction crypto c)
+intervalDisjunctions mini maxi =
+ LL.take (int $ (unwrap (nat maxi) + one)-unwrap (nat mini)) $
+ LL.drop (int $ unwrap (nat mini)) $
+ groupGenInverses :: LL.List (G crypto c)
+ where
+ int = Int.round <<< BigInt.toNumber
+
+-- ** Type 'DisjProof'
+-- | A list of 'Proof's to prove that the opinion within an 'Encryption'
+-- is indexing a 'Disjunction' within a list of them,
+-- without revealing which opinion it is.
+newtype DisjProof crypto v c = DisjProof (List (Proof crypto v c))
+derive newtype instance eqDisjProof :: Eq (DisjProof crypto v c)
+derive newtype instance showDisjProof :: Show (DisjProof crypto v c)
+derive newtype instance encodeJsonDisjProof :: (Reifies v Version, CryptoParams crypto c) => EncodeJson (DisjProof crypto v c)
+derive newtype instance decodeJsonDisjProof :: (Reifies v Version, CryptoParams crypto c) => DecodeJson (DisjProof crypto v c)
+instance newtypeDisjProof :: Newtype (DisjProof crypto v c) (List (Proof crypto v c)) where
+ wrap = DisjProof
+ unwrap (DisjProof x) = x
+
+-- | @('proveEncryption' elecPubKey voterZKP (prevDisjs,nextDisjs) (encNonce,enc))@
+-- returns a 'DisjProof' that 'enc' 'encrypt's
+-- the 'Disjunction' 'd' between 'prevDisjs' and 'nextDisjs'.
+--
+-- The prover proves that it knows an 'encNonce', such that:
+-- @(enc '==' Encryption{encryption_nonce='groupGen' '^'encNonce, encryption_vault=elecPubKey'^'encNonce '*' groupGen'^'d})@
+--
+-- A /NIZK Disjunctive Chaum Pedersen Logarithm Equality/ is used.
+--
+-- DOC: Pierrick Gaudry. <https://hal.inria.fr/hal-01576379 Some ZK security proofs for Belenios>, 2017.
+proveEncryption ::
+ forall crypto v c.
+ Reifies v Version =>
+ CryptoParams crypto c =>
+ PublicKey crypto c -> ZKP ->
+ Tuple (List (Disjunction crypto c)) (List (Disjunction crypto c)) ->
+ Tuple (EncryptionNonce crypto c) (Encryption crypto v c) ->
+ Effect (DisjProof crypto v c)
+proveEncryption elecPubKey voterZKP (Tuple prevDisjs nextDisjs) (Tuple encNonce enc) = do
+ -- Fake proofs for all 'Disjunction's except the genuine one.
+ prevFakeProofs <- replicateA (List.length prevDisjs) fakeProof
+ nextFakeProofs <- replicateA (List.length nextDisjs) fakeProof
+ let fakeChallengeSum = sum ((\(Proof p) -> p.proof_challenge) <$> prevFakeProofs) +
+ sum ((\(Proof p) -> p.proof_challenge) <$> nextFakeProofs)
+ let statement = encryptionStatement voterZKP enc
+ genuineProof <- prove encNonce (groupGen : elecPubKey : List.Nil) $ \genuineCommitments -> do
+ let validCommitments = List.zipWith (encryptionCommitments elecPubKey enc)
+ let prevCommitments = validCommitments prevDisjs prevFakeProofs
+ let nextCommitments = validCommitments nextDisjs nextFakeProofs
+ let commitments = join prevCommitments <> genuineCommitments <> join nextCommitments
+ challenge <- hash statement commitments
+ let genuineChallenge = challenge - fakeChallengeSum
+ pure genuineChallenge
+ -- NOTE: here by construction (genuineChallenge == challenge - fakeChallengeSum)
+ -- thus (sum ((\(Proof p) -> p.proof_challenge) <$> proofs) == challenge)
+ -- as checked in 'verifyEncryption'.
+ let proofs = prevFakeProofs <> (genuineProof : nextFakeProofs)
+ pure (DisjProof proofs)
+
+{-
+verifyEncryption ::
+ forall crypto v c.
+ Reifies v Version =>
+ CryptoParams crypto c =>
+ PublicKey crypto c -> ZKP ->
+ List (Disjunction crypto c) -> Tuple (Encryption crypto v c) (DisjProof crypto v c) ->
+ ExceptT ErrorVerifyEncryption Effect Boolean
+verifyEncryption elecPubKey voterZKP disjs (Tuple enc (DisjProof proofs)) =
+ case isoZipWith (encryptionCommitments elecPubKEy enc) disjs proofs of
+ Nothing ->
+ throwE $ ErrorVerifyEncryption_InvalidProofLength
+ (fromIntegral $ List.length proofs)
+ (fromIntegral $ List.length disjs)
+ Just commitments -> do
+ h <- lift $ hash (encryptionStatement voterZKP enc) (join commitments)
+ pure (challengeSum == h)
+ where
+ challengeSum = sum ((\(Proof p) -> p.proof_challenge) <$> proofs)
+-}
+
+-- ** Hashing
+encryptionStatement ::
+ forall crypto v c.
+ CryptoParams crypto c =>
+ ZKP -> Encryption crypto v c -> String
+encryptionStatement (ZKP voterZKP) (Encryption enc) =
+ "prove|"<>voterZKP<>"|"
+ <> bytesNat enc.encryption_nonce<>","
+ <> bytesNat enc.encryption_vault<>"|"
+
+-- | @('encryptionCommitments' elecPubKey enc disj proof)@
+-- returns the 'Commitment's with only the knowledge of the verifier.
+--
+-- For the prover the 'Proof' comes from @fakeProof@,
+-- and for the verifier the 'Proof' comes from the prover.
+encryptionCommitments ::
+ forall crypto v c.
+ Reifies v Version =>
+ CryptoParams crypto c =>
+ PublicKey crypto c -> Encryption crypto v c ->
+ Disjunction crypto c -> Proof crypto v c -> List (G crypto c)
+encryptionCommitments elecPubKey (Encryption enc) disj proof =
+ commit proof groupGen enc.encryption_nonce :
+ -- == groupGen ^ nonce if 'Proof' comes from 'prove'.
+ -- base==groupGen, basePowSec==groupGen^encNonce.
+ commit proof elecPubKey (enc.encryption_vault*disj) :
+ -- == elecPubKey ^ nonce if 'Proof' comes from 'prove'
+ -- and 'encryption_vault' encrypts (- logBase groupGen disj).
+ -- base==elecPubKey, basePowSec==elecPubKey^encNonce.
+ List.Nil
+
+-- ** Type 'ErrorVerifyEncryption'
+-- | Error raised by 'verifyEncryption'.
+data ErrorVerifyEncryption
+ = ErrorVerifyEncryption_InvalidProofLength Natural Natural
+ -- ^ When the number of proofs is different than
+ -- the number of 'Disjunction's.
+ -- deriving (Eq,Show)
+
+{-
+-- * Type 'Signature'
+-- | Schnorr-like signature.
+--
+-- Used by each voter to sign his/her encrypted 'Ballot'
+-- using his/her 'Credential',
+-- in order to avoid ballot stuffing.
+data Signature crypto v c = Signature
+ { signature_publicKey :: !(PublicKey crypto c)
+ -- ^ Verification key.
+ , signature_proof :: !(Proof crypto v c)
+ } deriving (Generic)
+deriving instance (NFData crypto, NFData (G crypto c)) => NFData (Signature crypto v c)
+instance
+ ( Reifies v Version
+ , CryptoParams crypto c
+ ) => ToJSON (Signature crypto v c) where
+ toJSON (Signature pubKey Proof{..}) =
+ JSON.object
+ [ "public_key" .= pubKey
+ , "challenge" .= proof_challenge
+ , "response" .= proof_response
+ ]
+ toEncoding (Signature pubKey Proof{..}) =
+ JSON.pairs
+ ( "public_key" .= pubKey
+ <> "challenge" .= proof_challenge
+ <> "response" .= proof_response
+ )
+instance
+ ( Reifies v Version
+ , CryptoParams crypto c
+ ) => FromJSON (Signature crypto v c) where
+ parseJSON = JSON.withObject "Signature" $ \o -> do
+ signature_publicKey <- o .: "public_key"
+ proof_challenge <- o .: "challenge"
+ proof_response <- o .: "response"
+ let signature_proof = Proof{..}
+ pure Signature{..}
+-}
sourcephile / git / majurity.git / blobdiff