hjugement-protocol/Protocol/Election.hs

   1 module Protocol.Election where
   2
   3 import Control.Monad (Monad(..))
   4 import Data.Bool
   5 import Data.Eq (Eq(..))
   6 import Data.Functor (Functor, (<$>))
   7 import Data.Maybe (Maybe(..))
   8 import Data.Monoid (Monoid(..))
   9 import Data.Ord (Ord(..))
  10 import Data.Int (Int)
  11 import Data.Semigroup (Semigroup(..))
  12 import Prelude (Integral, undefined)
  13 import Text.Show (Show(..))
  14 import qualified Control.Monad.Trans.State.Strict as S
  15 import qualified Data.List as List
  16
  17 import Protocol.Arith
  18
  19 -- * Type 'CipherText'
  20 data CipherText q = CipherText
  21  { alpha :: G q -- ^ Random nonce: @(g'^'r)@
  22  , beta  :: G q -- ^ Encrypted message: @(g'^'msg '*' (g'^'secKey)'^'r)@
  23  } deriving (Show)
  24
  25 -- | Additive homomorphism.
  26 -- Using the fact that: @g^x * g^y == g^(x+y)@.
  27 instance SubGroup q => Semigroup (CipherText q) where
  28         x<>y = CipherText (alpha x * alpha y) (beta x * beta y)
  29 instance SubGroup q => Monoid (CipherText q) where
  30         mempty = CipherText one one
  31         mappend = (<>)
  32
  33 type PublicKey = G
  34 type SecretKey = E
  35 type Random = E
  36
  37 encrypt ::
  38  PrimeField (P q) =>
  39  SubGroup q =>
  40  Integral msg =>
  41  PublicKey q -> Random q -> msg -> CipherText q
  42 encrypt pk r msg =
  43         CipherText
  44          { alpha = groupGen^r
  45          , beta  = groupGen^inE msg * pk^r
  46          -- NOTE: pk == groupGen ^ sk
  47          -- NOTE: msg is put as exponent in order
  48          -- to make an additive homomorphism
  49          -- instead of a multiplicative homomorphism.
  50          }
  51
  52 -- * Type 'Proof'
  53 data Proof q = Proof
  54  { challenge :: E q
  55  , response  :: E q
  56  } deriving (Eq,Show)
  57
  58 proofFiatShamir ::
  59  Monad m =>
  60  RandomGen r =>
  61  SubGroup q =>
  62  Functor f =>
  63  f (G q) -> E q -> (f (G q) -> E q) -> S.StateT r m (Proof q)
  64 proofFiatShamir gs msg oracle = do
  65         r <- random
  66         let commitments = (^ r) <$> gs
  67         let challenge = oracle commitments
  68         return Proof
  69          { challenge
  70          , response = r + msg * challenge
  71          }
  72
  73 -- | Prove that alpha = g^r and beta = y^r/d!!i
  74 -- the size of d is the number of disjuncts
  75 elgamalDisjProve ::
  76  PublicKey q -> [G q] -> Text -> Int -> Random q -> CipherText q -> Proof q
  77 elgamalDisjProve y d zkp i r CipherText{..} =
  78         undefined
  79
  80 {-
  81 type Randomness
  82 type Message
  83 type Answer
  84
  85
  86 -}
  87 {-
  88   (** ZKPs for disjunctions *)
  89
  90   let eg_disj_prove y d zkp x r {alpha; beta} =
  91     (* prove that alpha = g^r and beta = y^r/d_x *)
  92     (* the size of d is the number of disjuncts *)
  93     let n = Array.length d in
  94     assert (0 <= x && x < n);
  95     let proofs = Array.make n dummy_proof
  96     and commitments = Array.make (2*n) g
  97     and total_challenges = ref Z.zero in
  98     (* compute fake proofs *)
  99     let f i =
 100       let challenge = random q
 101       and response = random q in
 102       challenge >>= fun challenge ->
 103         response >>= fun response ->
 104           proofs.(i)          <- {challenge; response};
 105           commitments.(2*i)   <- g **~ response / alpha **~ challenge;
 106           commitments.(2*i+1) <- y **~ response / (beta *~ d.(i)) **~ challenge;
 107           total_challenges := Z.(!total_challenges + challenge);
 108           return ()
 109     in
 110                 -- Apply f to all elements of d except the xth
 111     let rec loop i =
 112       if i < x then f i >>= fun () -> loop (succ i)
 113       else if i = x then loop (succ i)
 114       else if i < n then f i >>= fun () -> loop (succ i)
 115       else return ()
 116     in loop 0 >>= fun () ->
 117       total_challenges := Z.(q - !total_challenges mod q);
 118       (* compute genuine proof *)
 119       fs_prove [| g; y |] r (fun commitx ->
 120         Array.blit commitx 0 commitments (2*x) 2;
 121         let prefix = Printf.sprintf "prove|%s|%s,%s|"
 122           zkp (G.to_string alpha) (G.to_string beta)
 123         in
 124         Z.((G.hash prefix commitments + !total_challenges) mod q)
 125       ) >>= fun p ->
 126         proofs.(x) <- p;
 127         return proofs
 128 -}