hjugement-protocol/Protocol/Election.hs

   1 {-# LANGUAGE GADTs #-}
   2 {-# LANGUAGE DataKinds #-}
   3 {-# LANGUAGE OverloadedStrings #-}
   4 {-# LANGUAGE ViewPatterns #-}
   5 module Protocol.Election where
   6
   7 import Control.Monad (Monad(..), mapM, sequence)
   8 import Data.Bool
   9 import Data.Eq (Eq(..))
  10 import Data.Foldable (Foldable, foldMap, and)
  11 import Data.Function (($), (.))
  12 import Data.Functor ((<$>))
  13 import Data.Maybe (Maybe(..), fromJust)
  14 import Data.Ord (Ord(..))
  15 import Data.Proxy (Proxy(..))
  16 import Data.Semigroup (Semigroup(..))
  17 import Data.String (IsString(..))
  18 import Data.Text (Text)
  19 import Data.Tuple (fst, snd, uncurry)
  20 import Numeric.Natural (Natural)
  21 import GHC.TypeNats
  22 import Text.Show (Show(..))
  23 import qualified Control.Monad.Trans.State.Strict as S
  24 import qualified Data.ByteString as BS
  25 import qualified Data.List as List
  26
  27 import Protocol.Arithmetic
  28 import Protocol.Credential
  29 import Utils.MeasuredList as ML
  30 import qualified Utils.Natural as Nat
  31 import qualified Utils.Constraint as Constraint
  32
  33 -- * Type 'Encryption'
  34 -- | ElGamal-like encryption.
  35 data Encryption q = Encryption
  36  { encryption_nonce :: G q
  37    -- ^ Public part of the random 'secNonce': @('groupGen' '^'r)@
  38  , encryption_vault :: G q
  39    -- ^ Encrypted opinion: @('pubKey' '^'r '*' 'groupGen' '^'opinion)@
  40  } deriving (Eq,Show)
  41
  42 -- | Additive homomorphism.
  43 -- Using the fact that: @'groupGen' '^'x '*' 'groupGen' '^'y '==' 'groupGen' '^'(x'+'y)@.
  44 instance SubGroup q => Additive (Encryption q) where
  45         zero = Encryption one one
  46         x+y = Encryption
  47          (encryption_nonce x * encryption_nonce y)
  48          (encryption_vault x * encryption_vault y)
  49
  50 -- *** Type 'SecretNonce'
  51 type SecretNonce = E
  52 -- ** Type 'ZKP'
  53 -- | Zero-knowledge proof
  54 type ZKP = BS.ByteString
  55
  56 -- ** Type 'Opinion'
  57 -- | Index of a 'Disjunction' within a 'ML.MeasuredList' of them.
  58 -- It is encoded as an 'E'xponent in 'encrypt'.
  59 type Opinion = Nat.Index
  60
  61 -- | @('encrypt' pubKey opinion)@ returns an ElGamal-like 'Encryption'.
  62 --
  63 -- WARNING: the secret nonce is returned alongside the 'Encryption'
  64 -- in order to prove the validity of the encrypted content in 'nizkProof',
  65 -- but this secret nonce MUST be forgotten after that,
  66 -- as it may be used to decipher the 'Encryption'
  67 -- without the secret key associated with 'pubKey'.
  68 encrypt ::
  69  Monad m => RandomGen r => SubGroup q =>
  70  PublicKey q -> Opinion ds ->
  71  S.StateT r m (SecretNonce q, Encryption q)
  72 encrypt pubKey (Nat.Index o) = do
  73         let opinion = inE (natVal o)
  74         secNonce <- random
  75         -- NOTE: preserve the 'secNonce' for 'nizkProof'.
  76         return $ (secNonce,)
  77                 Encryption
  78                  { encryption_nonce = groupGen^secNonce
  79                  , encryption_vault = pubKey  ^secNonce * groupGen^opinion
  80                  -- NOTE: pubKey == groupGen ^ secKey
  81                  -- NOTE: 'opinion' is put as exponent in order
  82                  -- to make an additive homomorphism
  83                  -- instead of a multiplicative homomorphism.
  84                  }
  85
  86 -- * Type 'Proof'
  87 data Proof q = Proof
  88  { proof_challenge :: Challenge q
  89  , proof_response  :: E q
  90  } deriving (Eq,Show)
  91
  92 -- ** Type 'Challenge'
  93 type Challenge = E
  94 -- ** Type 'Oracle'
  95 type Oracle q = [Commitment q] -> Challenge q
  96
  97 -- | Fiat-Shamir transformation
  98 -- of an interactive zero-knowledge (IZK) proof
  99 -- into a non-interactive zero-knowledge (NIZK) proof.
 100 nizkProof ::
 101  Monad m => RandomGen r => SubGroup q =>
 102  SecretNonce q -> [Commitment q] -> Oracle q -> S.StateT r m (Proof q)
 103 nizkProof secNonce commits oracle = do
 104         nonce <- random
 105         let commitments = (^ nonce) <$> commits
 106         let proof_challenge = oracle commitments
 107         return Proof
 108          { proof_challenge
 109          , proof_response = nonce + secNonce*proof_challenge
 110          }
 111
 112 -- ** Type 'Commitment'
 113 type Commitment = G
 114
 115 -- ** Type 'Disjunction'
 116 -- | A 'Disjunction' is an 'inv'ersed @('groupGen' '^'opinion)@
 117 -- it's used in 'proveEncryption' to generate a 'Proof'
 118 -- that an 'encryption_vault' contains a given @('groupGen' '^'opinion)@,
 119 type Disjunction = G
 120
 121 booleanDisjunctions :: SubGroup q => ML.MeasuredList 2 (Disjunction q)
 122 booleanDisjunctions = fromJust $ ML.fromList $ List.take 2 groupGenInverses
 123
 124 intervalDisjunctions ::
 125  forall q mini maxi.
 126  SubGroup q =>
 127  Bounds mini maxi ->
 128  ML.MeasuredList (maxi-mini) (Disjunction q)
 129 intervalDisjunctions Bounds{}
 130  | Constraint.Proof <- (Nat.<=) @mini @maxi =
 131         fromJust $
 132         ML.fromList $
 133         List.genericTake (Nat.nat @(maxi-mini)) $
 134         List.genericDrop (Nat.nat @mini) $
 135         groupGenInverses
 136
 137 -- ** Type 'ValidityProof'
 138 -- | A list of 'Proof's to prove that the 'Opinion' within an 'Encryption'
 139 -- is indexing a 'Disjunction' within a list of them,
 140 -- without knowing which 'Opinion' it is.
 141 newtype ValidityProof disjs q = ValidityProof (ML.MeasuredList disjs (Proof q))
 142  deriving (Eq,Show)
 143
 144 encryptionStatement :: SubGroup q => ZKP -> Encryption q -> BS.ByteString
 145 encryptionStatement zkp Encryption{..} =
 146         "prove|"<>zkp<>"|"<>
 147         fromString (show (natG encryption_nonce))<>","<>
 148         fromString (show (natG encryption_vault))<>"|"
 149
 150 proveEncryption ::
 151  forall disjs m r q.
 152  Nat.Known disjs =>
 153  Monad m => RandomGen r => SubGroup q =>
 154  PublicKey q -> ZKP ->
 155  ML.MeasuredList disjs (Disjunction q) -> Opinion disjs ->
 156  (SecretNonce q, Encryption q) ->
 157  S.StateT r m (ValidityProof disjs q)
 158 proveEncryption pubKey zkp disjs
 159  (Nat.Index (o::Proxy o))
 160  (secNonce, enc@Encryption{..})
 161  -- NOTE: the 'Constraint.Proof's below are needed to prove
 162  -- that the returned 'ValidityProof' has the same length
 163  -- than the given list of 'Disjunction's.
 164  | Constraint.Proof <- (Nat.+<=) @o @1 @disjs -- prove that o+1<=disjs implies 1<=disjs-o and o<=disjs
 165  , Constraint.Proof <- (Nat.<=) @o @disjs     -- prove that o<=disjs implies disjs-o is a Natural and o+(disjs-o) ~ disjs
 166  , Constraint.Proof <- (Nat.<=) @1 @(disjs-o) -- prove that ((disjs-o)-1)+1 ~ disjs-o
 167  = do
 168         let (prevDisjs, ML.uncons -> (_indexedDisj,nextDisjs)) = ML.splitAt o disjs
 169         prevFakes <- fakeProof `mapM` prevDisjs
 170         nextFakes <- fakeProof `mapM` nextDisjs
 171         let challengeSum =
 172                 neg $
 173                 sum (proof_challenge . fst <$> prevFakes) +
 174                 sum (proof_challenge . fst <$> nextFakes)
 175         genuineProof <- nizkProof secNonce [groupGen, pubKey] $
 176          -- 'Oracle'
 177          \nizkCommitments ->
 178                 let commitments =
 179                         foldMap snd prevFakes <>
 180                         nizkCommitments <>
 181                         foldMap snd nextFakes in
 182                 -- NOTE: this is a so-called strong Fiat-Shamir transformation (not a weak):
 183                 -- because the statement is included in the hash (not only the commitments).
 184                 hash (encryptionStatement zkp enc) commitments + challengeSum
 185         return $
 186                 ValidityProof $
 187                         ML.concat
 188                          (fst <$> prevFakes)
 189                          (ML.cons genuineProof (fst <$> nextFakes))
 190         where
 191         fakeProof :: Disjunction q -> S.StateT r m (Proof q, [Commitment q])
 192         fakeProof disj = do
 193                 proof_challenge <- random
 194                 proof_response  <- random
 195                 let commitments =
 196                          [ groupGen^proof_response / encryption_nonce       ^proof_challenge
 197                          , pubKey  ^proof_response / (encryption_vault*disj)^proof_challenge
 198                          ]
 199                 return (Proof{..}, commitments)
 200
 201 validateEncryption ::
 202  SubGroup q =>
 203  PublicKey q -> ZKP ->
 204  ML.MeasuredList n (Disjunction q) ->
 205  (Encryption q, ValidityProof n q) -> Bool
 206 validateEncryption pubKey zkp disjs (enc@Encryption{..}, ValidityProof proofs) =
 207         hash (encryptionStatement zkp enc) commitments == challengeSum
 208         where
 209         challengeSum = sum (proof_challenge <$> proofs)
 210         commitments = foldMap commitment (ML.zip disjs proofs)
 211                 where commitment (disj, Proof{..}) =
 212                         -- g = groupGen
 213                         -- h = pubKey
 214                         -- y1 = encryption_nonce
 215                         -- y2 = (encryption_vault * disj)
 216                         -- com1 = g^res / y1 ^ ch
 217                         -- com2 = h^res / y2 ^ ch
 218                         [ groupGen^proof_response / encryption_nonce       ^proof_challenge
 219                         , pubKey  ^proof_response / (encryption_vault*disj)^proof_challenge
 220                         ]
 221
 222 -- * Type 'Question'
 223 data Question choices (mini::Nat) (maxi::Nat) q =
 224  Question
 225  { question_text    :: Text
 226  , question_answers :: ML.MeasuredList choices Text
 227  , question_bounds  :: Bounds mini maxi
 228  -- , question_blank :: Maybe Bool
 229  } deriving (Eq, Show)
 230
 231 -- ** Type 'Bounds'
 232 data Bounds mini maxi =
 233  ((mini<=maxi), Nat.Known mini, Nat.Known maxi) =>
 234  Bounds (Proxy mini) (Proxy maxi)
 235 instance Show (Bounds mini maxi) where
 236         showsPrec p Bounds{} = showsPrec p (Nat.nat @mini, Nat.nat @maxi)
 237 instance Eq (Bounds mini maxi) where
 238         _==_ = True
 239
 240 -- * Type 'Answer'
 241 data Answer choices mini maxi q = Answer
 242  { answer_opinions :: ML.MeasuredList choices (Encryption q, ValidityProof 2 q)
 243    -- ^ Encrypted 'Opinion' for each 'question_answers'
 244    -- with a 'ValidityProof' that they belong to [0,1].
 245  , answer_sumProof :: ValidityProof (maxi-mini) q
 246    -- ^ Proofs that the sum of the 'Opinon's encrypted in 'answer_opinions'
 247    -- is an element of ['mini'..'maxi'].
 248  -- , answer_blankProof ::
 249  } deriving (Eq,Show)
 250
 251 -- | @('answer' pubKey zkp quest opinions)@
 252 -- returns a validable 'Answer',
 253 -- unless the given 'opinions' do not respect 'question_bounds'.
 254 answer ::
 255  forall m r q mini maxi choices.
 256  Monad m => RandomGen r => SubGroup q =>
 257  PublicKey q -> ZKP ->
 258  Question choices mini maxi q ->
 259  ML.MeasuredList choices (Opinion 2) ->
 260  S.StateT r m (Maybe (Answer choices mini maxi q))
 261 answer pubKey zkp Question{..} opinions
 262  | Bounds{} <- question_bounds
 263  , SomeNat (_opinionsSum::Proxy opinionsSum) <-
 264    someNatVal $ sum $ (\(Nat.Index o) -> natVal o) <$> opinions
 265    -- prove that opinionsSum-mini is a Natural
 266  , Just Constraint.Proof <- (Nat.<=?) @mini @opinionsSum
 267    -- prove that (opinionsSum-mini)+1 is a Natural
 268  , Constraint.Proof <- (Nat.+) @(opinionsSum-mini) @1
 269    -- prove that maxi-mini is a Natural
 270  , Constraint.Proof <- (Nat.<=) @mini @maxi
 271    -- prove that (opinionsSum-mini)+1 <= maxi-mini
 272  , Just Constraint.Proof <- (Nat.<=?) @((opinionsSum-mini)+1) @(maxi-mini)
 273  = do
 274         encryptions <- encrypt pubKey `mapM` opinions
 275         individualProofs <-
 276                 sequence $ ML.zipWith
 277                  (proveEncryption pubKey zkp booleanDisjunctions)
 278                  opinions encryptions
 279         sumProof <-
 280                 proveEncryption pubKey zkp
 281                  (intervalDisjunctions question_bounds)
 282                  (Nat.Index $ Proxy @(opinionsSum-mini))
 283                  ( sum (fst <$> encryptions)
 284                  , sum (snd <$> encryptions) )
 285         return $ Just Answer
 286          { answer_opinions = ML.zip
 287                  (snd <$> encryptions) -- NOTE: drop secNonce
 288                  individualProofs
 289          , answer_sumProof = sumProof
 290          }
 291  | otherwise = return Nothing
 292
 293 validateAnswer ::
 294  SubGroup q =>
 295  PublicKey q -> ZKP ->
 296  Question choices mini maxi q ->
 297  Answer choices mini maxi q -> Bool
 298 validateAnswer pubKey zkp Question{..} Answer{..} =
 299         and (validateEncryption pubKey zkp booleanDisjunctions <$> answer_opinions) &&
 300         validateEncryption pubKey zkp
 301          (intervalDisjunctions question_bounds)
 302          ( sum (fst <$> answer_opinions)
 303          , answer_sumProof )
 304
 305 -- * Type 'Election'
 306 data Election quests choices mini maxi q = Election
 307  { election_name        :: Text
 308  , election_description :: Text
 309  , election_publicKey   :: PublicKey q
 310  , election_questions   :: ML.MeasuredList quests (Question choices mini maxi q)
 311  , election_uuid        :: UUID
 312  , election_hash        :: Hash
 313  } deriving (Eq,Show)
 314
 315 -- ** Type 'Hash'
 316 newtype Hash = Hash Text
 317  deriving (Eq,Ord,Show)
 318
 319 -- * Type 'Ballot'
 320 data Ballot quests choices mini maxi q = Ballot
 321  { ballot_answers       :: ML.MeasuredList quests (Answer choices mini maxi q)
 322  , ballot_signature     :: Maybe (Signature q)
 323  , ballot_election_uuid :: UUID
 324  , ballot_election_hash :: Hash
 325  }
 326
 327 ballot ::
 328  Monad m =>
 329  RandomGen r =>
 330  SubGroup q =>
 331  Election quests choices mini maxi q ->
 332  Maybe (SecretKey q) ->
 333  ML.MeasuredList quests (ML.MeasuredList choices (Opinion 2)) ->
 334  S.StateT r m (Maybe (Ballot quests choices mini maxi q))
 335 ballot Election{..} secKeyMay opinionsByQuest = do
 336         let (keysMay, zkp) =
 337                 case secKeyMay of
 338                  Nothing -> (Nothing, "")
 339                  Just secKey ->
 340                         ( Just (secKey, pubKey)
 341                         , fromString (show (natG pubKey)) )
 342                         where pubKey = groupGen ^ secKey
 343         answersByQuestMay <-
 344                 (sequence <$>) $
 345                 uncurry (answer election_publicKey zkp) `mapM`
 346                 ML.zip election_questions opinionsByQuest
 347         case answersByQuestMay of
 348          Nothing -> return Nothing
 349          Just answersByQuest -> do
 350                 ballot_signature <- case keysMay of
 351                  Nothing -> return Nothing
 352                  Just (secKey, pubKey) -> do
 353                         w <- random
 354                         let commitment = groupGen ^ w
 355                         let proof_challenge = hash
 356                                  (signatureCommitments zkp commitment)
 357                                  (signatureStatement answersByQuest)
 358                         return $ Just Signature
 359                          { signature_publicKey = pubKey
 360                          , signature_proof = Proof
 361                                  { proof_challenge
 362                                  , proof_response = w - secKey*proof_challenge
 363                                  }
 364                          }
 365                 return $ Just Ballot
 366                  { ballot_answers = answersByQuest
 367                  , ballot_election_hash = election_hash
 368                  , ballot_election_uuid = election_uuid
 369                  , ballot_signature
 370                  }
 371
 372 validateBallot ::
 373  SubGroup q =>
 374  Election quests choices mini maxi q ->
 375  Ballot quests choices mini maxi q ->
 376  Bool
 377 validateBallot Election{..} Ballot{..} =
 378         ballot_election_uuid == election_uuid &&
 379         ballot_election_hash == election_hash &&
 380         let (validSign, zkp) =
 381                 case ballot_signature of
 382                  Nothing -> (True, "")
 383                  Just (Signature pubKey Proof{..}) ->
 384                         let zkp = fromString (show (natG pubKey)) in
 385                         let validSign =
 386                                 let commitment = groupGen ^ proof_response * pubKey ^ proof_challenge in
 387                                 let prefix     = signatureCommitments zkp commitment in
 388                                 let contents   = signatureStatement ballot_answers in
 389                                 hash prefix contents == proof_challenge
 390                         in (validSign, zkp)
 391         in
 392         validSign &&
 393         and (ML.zipWith (validateAnswer election_publicKey zkp)
 394          election_questions ballot_answers)
 395
 396 -- ** Type 'Signature'
 397 -- | Schnorr-like signature.
 398 --
 399 -- Used to avoid 'Ballot' stuffing.
 400 data Signature q = Signature
 401  { signature_publicKey :: PublicKey q
 402  , signature_proof     :: Proof q
 403  }
 404
 405 signatureStatement ::
 406  Foldable f => SubGroup q =>
 407  f (Answer choices mini maxi q) -> [G q]
 408 signatureStatement =
 409         foldMap $ \Answer{..} ->
 410                 (`foldMap` answer_opinions) $ \(Encryption{..}, _vp) ->
 411                         [encryption_nonce, encryption_vault]
 412
 413 signatureCommitments :: SubGroup q => ZKP -> Commitment q -> BS.ByteString
 414 signatureCommitments zkp commitment =
 415         "sig|"<>zkp<>"|"<>fromString (show (natG commitment))<>"|"