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