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