hjugement-protocol/Protocol/Election.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 module Protocol.Election where
   3
   4 import Control.Monad (Monad(..), mapM, forM, join, sequence)
   5 import Data.Bool
   6 import Data.Eq (Eq(..))
   7 import Data.Function (($), (.))
   8 import Data.Functor (Functor(..), (<$>))
   9 import Data.Foldable (Foldable, foldMap, and, toList)
  10 import Data.Int (Int)
  11 import Data.Maybe (Maybe(..))
  12 import Data.Monoid (Monoid(..))
  13 import Data.Ord (Ord(..), Ordering(..))
  14 import Data.Semigroup (Semigroup(..))
  15 import Data.Text (Text)
  16 import Data.Tuple (fst, snd, curry)
  17 import Prelude (Integral, fromIntegral, undefined, error)
  18 import Text.Show (Show(..))
  19 import Data.String (IsString(..))
  20 import qualified Control.Monad.Trans.State.Strict as S
  21 import qualified Data.List as List
  22 import qualified Data.Text.Encoding as Text
  23 import qualified Data.ByteString as BS
  24 import qualified Data.Map.Strict as Map
  25 import Data.Map.Strict (Map)
  26
  27 import Protocol.Arith
  28 import Protocol.List
  29
  30 -- * Type 'Encryption'
  31 data Encryption q = Encryption
  32  { encryption_nonce :: G q
  33    -- ^ Public part of the random 'secNonce': @('groupGen''^'r)@
  34  , encryption_vault :: G q
  35    -- ^ Encrypted opinion: @('pubKey''^'r '*' 'groupGen''^'opinion)@
  36  } deriving (Show)
  37
  38 -- | Additive homomorphism.
  39 -- Using the fact that: @'groupGen''^'x '*' 'groupGen''^'y '==' 'groupGen''^'(x'+'y)@.
  40 instance SubGroup q => Additive (Encryption q) where
  41         zero = Encryption one one
  42         x+y = Encryption
  43          (encryption_nonce x * encryption_nonce y)
  44          (encryption_vault x * encryption_vault y)
  45
  46 type PublicKey = G
  47 type SecretKey = E
  48 type SecretNonce = E
  49 type PublicKeyString = BS.ByteString
  50
  51 -- *** Type 'Opinion'
  52 -- | Exponent indexing a 'Disjunction' within a list of them.
  53 type Opinion = E
  54
  55 encrypt ::
  56  Monad m =>
  57  RandomGen r =>
  58  SubGroup q =>
  59  PublicKey q -> Opinion q ->
  60  S.StateT r m (SecretNonce q, Encryption q)
  61 encrypt pubKey opinion = do
  62         secNonce <- random
  63         -- NOTE: preserve the 'secNonce' for 'proof'
  64         return $ (secNonce,)
  65                 Encryption
  66                  { encryption_nonce = groupGen^secNonce
  67                  , encryption_vault = pubKey  ^secNonce * groupGen^opinion
  68                  -- NOTE: pubKey == groupGen ^ secKey
  69                  -- NOTE: 'index' is put as exponent in order
  70                  -- to make an additive homomorphism
  71                  -- instead of a multiplicative homomorphism.
  72                  }
  73
  74 -- * Type 'Proof'
  75 data Proof q = Proof
  76  { proof_challenge :: E q
  77  , proof_response  :: E q
  78  } deriving (Eq,Show)
  79
  80 type Oracle q = [Commitment q] -> Hash q
  81 type Hash = E
  82
  83 -- | Strong Fiat-Shamir transformation
  84 -- of an IZK proof into a NIZK proof.
  85 proof ::
  86  Monad m =>
  87  RandomGen r =>
  88  SubGroup q =>
  89  SecretNonce q ->
  90  [Commitment q] ->
  91  Oracle q ->
  92  S.StateT r m (Proof q)
  93 proof secretNonce commits oracle = do
  94         nonce <- random
  95         let commitments = (^ nonce) <$> commits
  96         let proof_challenge = oracle commitments
  97         return Proof
  98          { proof_challenge
  99          , proof_response = nonce + secretNonce*proof_challenge
 100          }
 101
 102 -- ** Type 'Commitment'
 103 type Commitment = G
 104
 105 -- ** Type 'Disjunction'
 106 -- | A 'Disjunction' is an 'inv'ersed @'groupGen''^'opinion@
 107 -- it's used in 'validableEncryption' to generate a 'Proof'
 108 -- that an 'encryption_vault' contains a given @'groupGen''^'opinion@,
 109 type Disjunction = G
 110
 111 validBool :: SubGroup q => [Disjunction q]
 112 validBool = List.take 2 groupGenInverses
 113
 114 validRange :: SubGroup q => E q -> E q -> [Disjunction q]
 115 validRange mini maxi =
 116         List.genericTake (intE maxi - intE mini) $
 117         List.genericDrop (intE mini) groupGenInverses
 118
 119 -- ** Type 'ValidityProof'
 120 -- | A list of 'Proof' to prove that the 'Opinion' within an 'Encryption'
 121 -- is indexing a 'Disjunction' within a list of them,
 122 -- without knowing which 'Opinion' it is.
 123 newtype ValidityProof q = ValidityProof [Proof q]
 124  deriving (Eq,Show)
 125
 126 -- | @('validableEncryption' pubKey zkp ds d (secNonce, enc))@
 127 -- returns a 'ValidityProof' that @'encryption_nonce' == 'groupGen''^''secNonce'@
 128 -- and @'encryption_vault' == pubKey'^'secNonce'/'indexedDisj'@.
 129 validableEncryption ::
 130  forall m r q.
 131  Monad m =>
 132  RandomGen r =>
 133  SubGroup q =>
 134  PublicKey q -> PublicKeyString ->
 135  [Disjunction q] -> Opinion q ->
 136  (SecretNonce q, Encryption q) ->
 137  S.StateT r m (ValidityProof q)
 138 validableEncryption pubKey zkp valids index (secNonce, Encryption{..})
 139  | (prevDisjs,_indexedDisj:nextDisjs) <-
 140    List.splitAt (fromIntegral (intE index)) valids = do
 141         prevFakes <- fakeProof `mapM` prevDisjs
 142         nextFakes <- fakeProof `mapM` nextDisjs
 143         let challengeSum =
 144                 neg $
 145                 sum (proof_challenge . fst <$> prevFakes) +
 146                 sum (proof_challenge . fst <$> nextFakes)
 147         genuineProof <- proof secNonce [groupGen, pubKey] $
 148          -- | 'Oracle'
 149          \nizkCommitments ->
 150                 let statement =
 151                         "prove|"<>zkp<>"|"<>
 152                         fromString (show (intG encryption_nonce))<>","<>
 153                         fromString (show (intG encryption_vault))<>"|" in
 154                 let commitments =
 155                         foldMap snd prevFakes <>
 156                         nizkCommitments <>
 157                         foldMap snd nextFakes in
 158                 hash statement commitments + challengeSum
 159         return $
 160                 ValidityProof $
 161                  (fst <$> prevFakes) <>
 162                  [genuineProof] <>
 163                  (fst <$> nextFakes)
 164  | otherwise = error "validableEncryption: bad disjunction index"
 165         where
 166         fakeProof :: Disjunction q -> S.StateT r m (Proof q, [Commitment q])
 167         fakeProof disj = do
 168                 proof_challenge <- random
 169                 proof_response  <- random
 170                 let commitments =
 171                          [ groupGen^proof_response / encryption_nonce       ^proof_challenge
 172                          , pubKey  ^proof_response / (encryption_vault*disj)^proof_challenge
 173                          ]
 174                 return (Proof{..}, commitments)
 175
 176 validateEncryption ::
 177  SubGroup q =>
 178  PublicKey q -> PublicKeyString ->
 179  [Disjunction q] ->
 180  (Encryption q, ValidityProof q) -> Bool
 181 validateEncryption pubKey zkp disjs (Encryption{..}, ValidityProof proofs) =
 182         List.length disjs == List.length proofs &&
 183         hash statement commitments == challengeSum
 184         where
 185         challengeSum = sum (proof_challenge <$> proofs)
 186         statement =
 187                 "prove|"<>zkp<>"|"<>
 188                 fromString (show (intG encryption_nonce))<>","<>
 189                 fromString (show (intG encryption_vault))<>"|"
 190         commitments = join $ List.zipWith commitment disjs proofs
 191                 where commitment disj Proof{..} =
 192                         -- g = groupGen
 193                         -- h = pubKey
 194                         -- y1 = encryption_nonce
 195                         -- y2 = (encryption_vault * disj)
 196                         -- com1 = g^res / y1 ^ ch
 197                         -- com2 = h^res / y2 ^ ch
 198                         [ groupGen^proof_response / encryption_nonce       ^proof_challenge
 199                         , pubKey  ^proof_response / (encryption_vault*disj)^proof_challenge
 200                         ]
 201
 202 -- * Type 'Question'
 203 data Question q = Question
 204  {   question_text    :: Text
 205  ,   question_answers :: [Text]
 206  ,   question_min     :: E q
 207  ,   question_max     :: E q
 208  -- ,   question_blank :: Maybe Bool
 209  } deriving (Eq, Show)
 210
 211 -- * Type 'Answer'
 212 data Answer q = Answer
 213  {   answer_opinions :: [(Encryption q, ValidityProof q)]
 214      -- ^ Encrypted 'Opinion' for each 'question_answers'
 215      -- with a 'ValidityProof' that they belong to [0,1].
 216  ,   answer_sumProof :: ValidityProof q
 217      -- ^ Proofs that the sum of the 'Opinon's encrypted in 'answer_opinions'
 218      -- is an element of ['question_min'..'question_max'].
 219  -- , answer_blankProof ::
 220  }
 221
 222 answer ::
 223  forall m r q.
 224  Monad m =>
 225  RandomGen r =>
 226  SubGroup q =>
 227  PublicKey q -> PublicKeyString ->
 228  Question q ->
 229  [Opinion q] ->
 230  S.StateT r m (Answer q)
 231 answer pubKey zkp Question{..} opinions = do
 232         encryptions <- encrypt pubKey `mapM` opinions
 233         individualProofs :: [ValidityProof q] <-
 234                 sequence $ List.zipWith
 235                  (validableEncryption pubKey zkp validBool)
 236                  opinions encryptions
 237         sumProof <-
 238                 validableEncryption pubKey zkp
 239                  (validRange question_min question_max)
 240                  (sum opinions - question_min)
 241                  ( sum (fst <$> encryptions)
 242                  , sum (snd <$> encryptions) )
 243         return Answer
 244          { answer_opinions =
 245                 List.zip
 246                  (snd <$> encryptions) -- NOTE: drop the secretNonce
 247                  individualProofs
 248          , answer_sumProof = sumProof
 249          }
 250
 251 validateAnswer ::
 252  SubGroup q =>
 253  PublicKey q -> PublicKeyString ->
 254  Question q ->
 255  Answer q -> Bool
 256 validateAnswer pubKey zkp Question{..} Answer{..} =
 257         and (validateEncryption pubKey zkp validBool <$> answer_opinions) &&
 258         validateEncryption pubKey zkp
 259          (validRange question_min question_max)
 260          ( sum (fst <$> answer_opinions)
 261          , answer_sumProof )