Full monadification

lib/crypto.ml

@@ -57,16 +57,17 @@ let check_election p =
   let computed = Array.fold_left ( *~ ) G.one public_keys in
   computed =~ params.e_public_key
 
-(** Dummy monad *)
+(** Simple monad *)
 
-module MakeDummyMonad (G : GROUP) = struct
+module MakeSimpleMonad (G : GROUP) = struct
   type 'a t = 'a
+  let ballots = ref []
   let return x = x
   let bind x f = f x
   let random q = Util.random q
   type ballot = G.t Serializable_t.ballot
-  let cast x = ()
-  let fold f x = return x
+  let cast x = ballots := x :: !ballots
+  let fold f x = List.fold_left (fun accu b -> f b accu) x !ballots
 end
 
 (** Homomorphic elections *)
@@ -79,7 +80,9 @@ struct
   open P
   open G
 
-  type 'a m = 'a
+  type 'a m = 'a M.t
+  open M
+  let ( >>= ) = bind
 
   type elt = G.t
   type private_key = Z.t
@@ -127,11 +130,11 @@ struct
       knowledge *)
 
   let fs_prove gs x oracle =
-    let w = random q in
+    random q >>= fun w ->
     let commitments = Array.map (fun g -> g **~ w) gs in
     let challenge = oracle commitments in
     let response = Z.((w + x * challenge) mod q) in
-    {challenge; response}
+    return {challenge; response}
 
   (** ZKPs for disjunctions *)
 
@@ -147,20 +150,28 @@ struct
     let f i =
       let challenge = random q
       and response = random q in
+      challenge >>= fun challenge ->
+      response >>= fun response ->
       proofs.(i) <- {challenge; response};
       commitments.(2*i) <- g **~ response / alpha **~ challenge;
       commitments.(2*i+1) <- y **~ response / (beta *~ d.(i)) **~ challenge;
       total_challenges := Z.(!total_challenges + challenge);
+      return ()
     in
-    for i = 0 to x-1 do f i done;
-    for i = x+1 to n-1 do f i done;
+    let rec loop i =
+      if i < x then f i >>= fun () -> loop (succ i)
+      else if i = x then loop (succ i)
+      else if i < n then f i >>= fun () -> loop (succ i)
+      else return ()
+    in loop 0 >>= fun () ->
     total_challenges := Z.(q - !total_challenges mod q);
     (* compute genuine proof *)
-    proofs.(x) <- fs_prove [| g; y |] r (fun commitx ->
+    fs_prove [| g; y |] r (fun commitx ->
       Array.blit commitx 0 commitments (2*x) 2;
       Z.((G.hash commitments + !total_challenges) mod q)
-    );
-    proofs
+    ) >>= fun p ->
+    proofs.(x) <- p;
+    return proofs
 
   let eg_disj_verify d proofs {alpha; beta} =
     G.check alpha && G.check beta &&
@@ -194,6 +205,27 @@ struct
     done;
     d
 
+  let swap xs =
+    let rec loop i accu =
+      if i >= 0
+      then xs.(i) >>= fun x -> loop (pred i) (x::accu)
+      else return (Array.of_list accu)
+    in loop (pred (Array.length xs)) []
+
+  let sswap xs =
+    let rec loop_outer i accu =
+      if i >= 0 then (
+        let x = xs.(i) in
+        let rec loop_inner j accu =
+          if j >= 0
+          then x.(j) >>= fun r -> loop_inner (pred j) (r::accu)
+          else return (Array.of_list accu)
+        in
+        loop_inner (Array.length x - 1) [] >>= fun ys ->
+        loop_outer (pred i) (ys::accu)
+      ) else return (Array.of_list accu)
+    in loop_outer (Array.length xs - 1) []
+
   let create_answer q r m =
     let choices = Array.map2 eg_encrypt r m in
     let individual_proofs = Array.map3 (eg_disj_prove d01) m r choices in
@@ -205,16 +237,19 @@ struct
     assert (q.q_min <= summ && summ <= q.q_max);
     let d = make_d q.q_min q.q_max in
     let overall_proof = eg_disj_prove d (summ - q.q_min) sumr sumc in
-    {choices; individual_proofs; overall_proof}
+    swap individual_proofs >>= fun individual_proofs ->
+    overall_proof >>= fun overall_proof ->
+    return {choices; individual_proofs; overall_proof}
 
-  let create_randomness () =
-    Array.map (fun q ->
+  let randomness =
+    sswap (Array.map (fun q ->
       Array.init (Array.length q.q_answers) (fun _ -> random G.q)
-    ) params.e_questions
+    ) params.e_questions)
 
   let create_ballot r m =
-    {
-      answers = Array.map3 create_answer params.e_questions r m;
+    swap (Array.map3 create_answer params.e_questions r m) >>= fun answers ->
+    return {
+      answers;
       election_hash = fingerprint;
       election_uuid = params.e_uuid
     }
@@ -247,7 +282,8 @@ struct
     if check_ciphertext c then (
       let res = Array.mmap (eg_factor x) c in
       let decryption_factors, decryption_proofs = Array.ssplit res in
-      {decryption_factors; decryption_proofs}
+      sswap decryption_proofs >>= fun decryption_proofs ->
+      return {decryption_factors; decryption_proofs}
     ) else (
       invalid_arg "Invalid ciphertext"
     )

lib/crypto.mli

@@ -13,13 +13,14 @@ val check_finite_field : p:Z.t -> q:Z.t -> g:Z.t -> bool
 val check_election : (module ELECTION_PARAMS) -> bool
 (** Check consistency of election parameters. *)
 
-module MakeDummyMonad (G : GROUP) : ELECTION_MONAD
+module MakeSimpleMonad (G : GROUP) : ELECTION_MONAD
   with type ballot = G.t Serializable_t.ballot
   and type 'a t = 'a
+(** Simple election monad that keeps all ballots in memory. *)
 
 module MakeElection
   (P : ELECTION_PARAMS)
   (M : ELECTION_MONAD with type ballot = P.G.t Serializable_t.ballot)
   : ELECTION
   with type elt = P.G.t
-  and type 'a m = 'a
+  and type 'a m = 'a M.t

lib/crypto_sigs.mli

@@ -125,7 +125,7 @@ module type ELECTION = sig
   type randomness = Z.t array array
   (** Randomness needed to create a ballot. *)
 
-  val create_randomness : unit -> randomness m
+  val randomness : randomness m
   (** Creates randomness for [create_ballot] below. The result can be
       kept for Benaloh-style auditing. *)
 

tests/sandbox.ml

@@ -93,7 +93,8 @@ let verbose_verify_election_test_data (e, ballots, signatures, private_data) =
   verbose_assert "election key" (lazy (
     Crypto.check_election (module P : Crypto_sigs.ELECTION_PARAMS)
   ));
-  let module Election = Crypto.MakeElection(P)(Crypto.MakeDummyMonad(P.G)) in
+  let module M = Crypto.MakeSimpleMonad(P.G) in
+  let module Election = Crypto.MakeElection(P)(M) in
   if Array.length ballots = 0 then (
     Printf.eprintf "   no ballots available\n%!"
   ) else (
@@ -177,18 +178,15 @@ module P = struct
   let fingerprint = e.fingerprint
 end
 
-module Election = Crypto.MakeElection(P)(Crypto.MakeDummyMonad(P.G))
+module M = Crypto.MakeSimpleMonad(P.G)
+module Election = Crypto.MakeElection(P)(M)
 module Compat = Serializable_compat.MakeCompat(P)
 
 let nballots = Array.map Serializable_compat.of_ballot ballots;;
 assert (Array.forall Election.check_ballot nballots);;
 assert (Array.forall2 (fun b b' -> b = Compat.to_ballot b') ballots nballots);;
 
-let create_ballot b =
-  let randomness = Array.map (fun x ->
-    Array.map (fun _ -> random q) x
-  ) b in
-  Election.create_ballot randomness b
+let create_ballot b = Election.(create_ballot randomness b)
 
 let test_ballot = create_ballot [| [| 1; 0; 0; 0 |] |];;
 assert (Election.check_ballot test_ballot);;

web/helios_registration.ml

@@ -192,7 +192,8 @@ let () = Eliom_registration.Html5.register
              let params = Serializable_compat.of_election election.Common.election
              let fingerprint = assert false
            end in
-           let module Election = Crypto.MakeElection(P)(Crypto.MakeDummyMonad(P.G)) in
+           let module M = Crypto.MakeSimpleMonad(P.G) in
+           let module Election = Crypto.MakeElection(P)(M) in
            if
              Uuidm.equal uuid ballot.election_uuid &&
              Election.check_ballot (Serializable_compat.of_ballot ballot)