Commit 233ad301 authored by Stephane Glondu's avatar Stephane Glondu

Implement web server-side shuffling

parent 9dd16701
Pipeline #82861 passed with stages
in 17 minutes and 26 seconds
......@@ -47,6 +47,12 @@ let get_group x =
(** Helper functions *)
let has_nh_questions e =
Array.exists (function
| Question.Open _ -> true
| Question.Standard _ -> false
) e.e_params.e_questions
let check_modulo p x = Z.(geq x zero && lt x p)
(** Homomorphic elections *)
......
......@@ -26,6 +26,8 @@ open Signatures
val of_string : string -> Yojson.Safe.json election
val get_group : Yojson.Safe.json election -> (module ELECTION_DATA)
val has_nh_questions : 'a election -> bool
module Make (W : ELECTION_DATA) (M : RANDOM) :
ELECTION with type elt = W.G.t and type 'a m = 'a M.t
(** Implementation of {!Signatures.ELECTION}. *)
......@@ -235,7 +235,7 @@ let get_elections_by_owner user =
let election = Election.of_string election in
let%lwt kind, date =
match%lwt get_election_state uuid with
| `Open | `Closed | `EncryptedTally _ ->
| `Open | `Closed | `Shuffling | `EncryptedTally _ ->
let%lwt date = get_election_date `Validation uuid in
let date = Option.get date default_validation_date in
return (`Validated, date)
......@@ -393,6 +393,106 @@ let compute_encrypted_tally uuid =
let%lwt () = write_file ~uuid (string_of_election_file ESETally) [tally] in
return (Some (num_tallied, sha256_b64 tally, tally))
let get_shuffle_token uuid =
match%lwt read_file ~uuid "shuffle_token" with
| Some [x] -> return x
| _ ->
let%lwt token = generate_token () in
let%lwt () = write_file ~uuid "shuffle_token" [token] in
return token
let clear_shuffle_token uuid =
let f = !Web_config.spool_dir / raw_string_of_uuid uuid / "shuffle_token" in
try%lwt Lwt_unix.unlink f with _ -> return_unit
let get_nh_ciphertexts uuid =
match%lwt get_raw_election uuid with
| None -> Lwt.fail (Failure "get_nh_ciphertexts: election not found")
| Some election ->
let election = Election.of_string election in
let module W = (val Election.get_group election) in
let module E = Election.Make (W) (LwtRandom) in
let%lwt current =
match%lwt read_file ~uuid "shuffles.jsons" with
| None -> return []
| Some x -> return x
in
match List.rev current with
| [] ->
let%lwt tally =
match%lwt read_file ~uuid (string_of_election_file ESETally) with
| Some [x] -> return (encrypted_tally_of_string E.G.read x)
| _ -> Lwt.fail (Failure "append_to_shuffles: encrypted tally not found or invalid")
in
return (string_of_nh_ciphertexts E.G.write (E.extract_nh_ciphertexts tally))
| x :: _ -> return x
let get_shuffles uuid =
match%lwt get_raw_election uuid with
| None -> return_none
| Some election ->
let election = Election.of_string election in
let module W = (val Election.get_group election) in
let module E = Election.Make (W) (LwtRandom) in
match%lwt read_file ~uuid "shuffles.jsons" with
| None -> return_none
| Some x ->
let rec loop accu = function
| p :: c :: rest ->
let shuffle_ciphertexts = nh_ciphertexts_of_string E.G.read c in
let shuffle_proofs = shuffle_proofs_of_string E.G.read p in
let shuffle = string_of_shuffle E.G.write {shuffle_ciphertexts; shuffle_proofs} in
loop (shuffle :: accu) rest
| [] -> return_some (List.rev accu)
| [_] -> Lwt.fail (Failure "get_shuffles: odd number of lines")
in
loop [] x
let compute_encrypted_tally_after_shuffling uuid =
let%lwt election = get_raw_election uuid in
match election with
| None -> return_none
| Some election ->
let election = Election.of_string election in
let module W = (val Election.get_group election) in
let module E = Election.Make (W) (LwtRandom) in
match%lwt read_file ~uuid (string_of_election_file ESETally) with
| Some [x] ->
let tally = encrypted_tally_of_string E.G.read x in
let%lwt nh = get_nh_ciphertexts uuid in
let nh = nh_ciphertexts_of_string E.G.read nh in
let tally = E.merge_nh_ciphertexts nh tally in
let tally = string_of_encrypted_tally E.G.write tally in
let%lwt () = write_file ~uuid (string_of_election_file ESETally) [tally] in
return_some (sha256_b64 tally, tally)
| _ -> return_none
let shuffle_mutex = Lwt_mutex.create ()
let append_to_shuffles uuid ~ciphertexts ~proofs =
match%lwt get_raw_election uuid with
| None -> Lwt.fail (Failure "append_to_shuffles: election not found")
| Some election ->
let election = Election.of_string election in
let module W = (val Election.get_group election) in
let module E = Election.Make (W) (LwtRandom) in
let proofs_ = shuffle_proofs_of_string E.G.read proofs in
let ciphertexts_ = nh_ciphertexts_of_string E.G.read ciphertexts in
Lwt_mutex.with_lock shuffle_mutex (fun () ->
let%lwt last_ciphertext = get_nh_ciphertexts uuid in
let last_ciphertext = nh_ciphertexts_of_string E.G.read last_ciphertext in
if E.check_shuffle last_ciphertext ciphertexts_ proofs_ then (
let%lwt current =
match%lwt read_file ~uuid "shuffles.jsons" with
| None -> return []
| Some x -> return x
in
let new_ = current @ [proofs; ciphertexts] in
let%lwt () = write_file ~uuid "shuffles.jsons" new_ in
return true
) else return false
)
module ExtendedRecordsCacheTypes = struct
type key = uuid
type value = (datetime * string) StringMap.t
......
......@@ -82,6 +82,16 @@ val get_ballot_by_hash : uuid -> string -> string option Lwt.t
val compute_encrypted_tally : uuid -> (int * string * string) option Lwt.t
val get_shuffles : uuid -> string list option Lwt.t
val compute_encrypted_tally_after_shuffling : uuid -> (string * string) option Lwt.t
val get_shuffle_token : uuid -> string Lwt.t
val clear_shuffle_token : uuid -> unit Lwt.t
val get_nh_ciphertexts : uuid -> string Lwt.t
val append_to_shuffles : uuid -> ciphertexts:string -> proofs:string -> bool Lwt.t
val has_voted : uuid -> user -> bool Lwt.t
val init_credential_mapping : uuid -> string list -> unit Lwt.t
......
......@@ -79,6 +79,7 @@ type credential_mapping = {
type election_state =
[ Open
| Closed
| Shuffling
| EncryptedTally of (int * int * string)
| Tallied
| Archived
......
......@@ -104,6 +104,10 @@ let election_missing_voters = create ~path:(Path ["elections"]) ~meth:(Get (suff
let election_download_archive = create ~path:(Path ["elections"]) ~meth:(Get (suffix (uuid "uuid" ** suffix_const "archive.zip"))) ()
let election_compute_encrypted_tally = create_attached_post ~csrf_safe:true ~fallback:election_admin ~post_params:unit ()
let election_nh_ciphertexts = create ~path:(Path ["election"; "nh-ciphertexts"]) ~meth:(Get (uuid "uuid")) ()
let election_shuffle_link = create ~path:(Path ["election"; "shuffle"]) ~meth:(Get uuid_and_token) ()
let election_shuffle_post = create ~path:(Path ["election"; "submit-shuffle"]) ~meth:(Post (uuid_and_token, string "shuffle")) ()
let election_decrypt = create_attached_post ~csrf_safe:true ~fallback:election_admin ~post_params:unit ()
let election_tally_trustees = create ~path:(Path ["election"; "trustees"]) ~meth:(Get uuid_and_token) ()
let election_tally_trustees_post = create ~path:(Path ["election"; "submit-partial-decryption"]) ~meth:(Post (uuid_and_token, string "partial_decryption")) ()
let election_tally_release = create_attached_post ~fallback:election_admin ~post_params:unit ()
......
......@@ -313,6 +313,8 @@ let delete_election uuid =
"records";
"result.json";
"hide_result";
"shuffle_token";
"shuffles.jsons";
"voters.txt";
"archive.zip";
]
......@@ -1829,7 +1831,9 @@ let handle_election_tally_release uuid () =
let module K = Trustees.MakePedersen (W.G) (LwtRandom) (P) (C) in
return (K.combine_factors checker tp)
in
let result = E.compute_result ntallied et pds combinator in
let%lwt shuffles = Web_persist.get_shuffles uuid in
let shuffles = Option.map (List.map (shuffle_of_string W.G.read)) shuffles in
let result = E.compute_result ?shuffles ntallied et pds combinator in
let%lwt () =
let result = string_of_election_result W.G.write result in
write_file ~uuid (string_of_election_file ESResult) [result]
......@@ -1837,6 +1841,8 @@ let handle_election_tally_release uuid () =
let%lwt () = Web_persist.set_election_state uuid `Tallied in
let%lwt () = Web_persist.set_election_date `Tally uuid (now ()) in
let%lwt () = cleanup_file (!Web_config.spool_dir / uuid_s / "decryption_tokens.json") in
let%lwt () = cleanup_file (!Web_config.spool_dir / uuid_s / "shuffles.jsons") in
let%lwt () = Web_persist.clear_shuffle_token uuid in
redir_preapply election_home (uuid, ()) ()
) else forbidden ()
)
......@@ -1878,6 +1884,13 @@ let () =
let%lwt site_user = Eliom_reference.get Web_state.site_user in
handle_pseudo_file uuid f site_user)
let () =
Any.register ~service:election_nh_ciphertexts
(fun uuid () ->
let%lwt x = Web_persist.get_nh_ciphertexts uuid in
String.send (x, "application/json")
)
module type ELECTION_LWT = ELECTION with type 'a m = 'a Lwt.t
let perform_server_side_decryption uuid e metadata tally =
......@@ -1922,15 +1935,91 @@ let () =
| Some x -> return x
| None -> failwith "Anomaly in election_compute_encrypted_tally service handler. Please report." (* should not happen *)
in
if Election.has_nh_questions E.election then (
let%lwt () = Web_persist.set_election_state uuid `Shuffling in
redir_preapply election_admin uuid ()
) else (
let%lwt npks =
match%lwt Web_persist.get_threshold uuid with
| Some tp ->
let tp = threshold_parameters_of_string W.G.read tp in
return (Array.length tp.t_verification_keys)
| None ->
match%lwt Web_persist.get_public_keys uuid with
| Some pks -> return (List.length pks)
| None -> failwith "missing public keys and threshold parameters"
in
let%lwt () = Web_persist.set_election_state uuid (`EncryptedTally (npks, nb, hash)) in
if%lwt perform_server_side_decryption uuid (module E) metadata tally then
handle_election_tally_release uuid ()
else
redir_preapply election_admin uuid ()
)
) else forbidden ()
)
)
let () =
Any.register ~service:election_shuffle_link
(fun (uuid, token) () ->
let%lwt expected_token = Web_persist.get_shuffle_token uuid in
if token = expected_token then (
let%lwt election = find_election uuid in
T.shuffle election token >>= Html.send
) else forbidden ()
)
let () =
Any.register ~service:election_shuffle_post
(fun (uuid, token) shuffle ->
let%lwt expected_token = Web_persist.get_shuffle_token uuid in
if token = expected_token then (
let shuffle = try Ok (shuffle_of_string Yojson.Safe.read_json shuffle) with e -> Error e in
match shuffle with
| Ok shuffle ->
let ciphertexts = string_of_nh_ciphertexts Yojson.Safe.write_json shuffle.shuffle_ciphertexts in
let proofs = string_of_shuffle_proofs Yojson.Safe.write_json shuffle.shuffle_proofs in
if%lwt Web_persist.append_to_shuffles uuid ~ciphertexts ~proofs then (
let%lwt () = Web_persist.clear_shuffle_token uuid in
T.generic_page ~title:"Success" "The shuffle has been successfully applied!" () >>= Html.send
) else
T.generic_page ~title:"Error" "An error occurred while applying the shuffle." () >>= Html.send
| Error e ->
T.generic_page ~title:"Error" (Printf.sprintf "Data is invalid! (%s)" (Printexc.to_string e)) () >>= Html.send
) else forbidden ()
)
let () =
Any.register ~service:election_decrypt (fun uuid () ->
with_site_user (fun u ->
let%lwt election = find_election uuid in
let%lwt metadata = Web_persist.get_election_metadata uuid in
let module W = (val Election.get_group election) in
let module E = Election.Make (W) (LwtRandom) in
if metadata.e_owner = Some u then (
let%lwt () =
match%lwt Web_persist.get_election_state uuid with
| `Shuffling -> return ()
| _ -> forbidden ()
in
let%lwt hash, tally =
match%lwt Web_persist.compute_encrypted_tally_after_shuffling uuid with
| Some x -> return x
| None -> Lwt.fail (Failure "election_decrypt handler: compute_encrypted_tally_after_shuffling")
in
let%lwt nb =
let%lwt x = Web_persist.get_ballot_hashes uuid in
return (List.length x)
in
let%lwt npks =
match%lwt Web_persist.get_threshold uuid with
| Some tp ->
let tp = threshold_parameters_of_string W.G.read tp in
let tp = threshold_parameters_of_string E.G.read tp in
return (Array.length tp.t_verification_keys)
| None ->
match%lwt Web_persist.get_public_keys uuid with
| Some pks -> return (List.length pks)
| None -> failwith "missing public keys and threshold parameters"
| None -> Lwt.fail (Failure "election_decrypt handler: missing public keys and threshold parameters")
in
let%lwt () = Web_persist.set_election_state uuid (`EncryptedTally (npks, nb, hash)) in
if%lwt perform_server_side_decryption uuid (module E) metadata tally then
......@@ -2323,7 +2412,7 @@ let extract_automatic_data_validated uuid_s =
let contact = metadata.e_contact in
let%lwt state = Web_persist.get_election_state uuid in
match state with
| `Open | `Closed | `EncryptedTally _ ->
| `Open | `Closed | `Shuffling | `EncryptedTally _ ->
let%lwt t = Web_persist.get_election_date `Validation uuid in
let t = Option.get t default_validation_date in
let next_t = datetime_add t (day days_to_delete) in
......
......@@ -1731,6 +1731,11 @@ let election_home election state () =
| _ -> pcdata ""
in
[it_will_close]
| `Shuffling ->
[
pcdata " ";
b [pcdata L.election_closed_being_tallied];
]
| `EncryptedTally (_, _, hash) ->
[
pcdata " ";
......@@ -1965,6 +1970,25 @@ let election_admin election metadata state get_tokens_decrypt () =
pcdata " Warning: this action is irreversible; the election will be definitively closed.";
]) uuid;
]
| `Shuffling ->
let%lwt token = Web_persist.get_shuffle_token uuid in
return (
div [
div [
pcdata "The ballots are being shuffled. ";
a ~service:election_shuffle_link [
pcdata "Shuffle link";
] (uuid, token);
pcdata ".";
];
post_form ~service:election_decrypt
(fun () ->
[
input ~input_type:`Submit ~value:"Proceed to decryption" string;
]
) uuid;
]
)
| `EncryptedTally (npks, _, hash) ->
let%lwt pds = Web_persist.get_partial_decryptions uuid in
let%lwt tp = Web_persist.get_threshold uuid in
......@@ -2135,7 +2159,7 @@ let election_admin election metadata state get_tokens_decrypt () =
]
in
let%lwt deletion_date = match state with
| `Open | `Closed | `EncryptedTally _ ->
| `Open | `Closed | `Shuffling | `EncryptedTally _ ->
let%lwt t = Web_persist.get_election_date `Validation uuid in
let dt = day days_to_delete in
return @@ datetime_add (Option.get t default_validation_date) dt
......@@ -2538,6 +2562,28 @@ let pretty_records election records () =
let%lwt login_box = login_box ~cont:(ContSiteElection uuid) () in
base ~title ~login_box ~content ()
let shuffle election token =
let params = election.e_params in
let uuid = params.e_uuid in
let title = params.e_name ^ " — Shuffle" in
let content = [
div [pcdata "It is now time to shuffle encrypted ballots."];
post_form ~service:election_shuffle_post
(fun nshuffle ->
[
div [
input ~input_type:`Submit ~value:"Submit" string;
];
div [
pcdata "Data: ";
textarea ~a:[a_rows 5; a_cols 40; a_id "shuffle"] ~name:nshuffle ();
];
]
) (uuid, token);
]
in
base ~title ~content ~uuid ()
let tally_trustees election trustee_id token () =
let params = election.e_params in
let uuid = params.e_uuid in
......
......@@ -61,6 +61,8 @@ val cast_confirmed : 'a election -> result:(string, Web_common.error) result ->
val pretty_ballots : 'a election -> string list -> Yojson.Safe.json election_result option -> unit -> [> `Html ] Eliom_content.Html.F.elt Lwt.t
val pretty_records : 'a election -> (string * string) list -> unit -> [> `Html ] Eliom_content.Html.F.elt Lwt.t
val shuffle : 'a election -> string -> [> `Html ] Eliom_content.Html.F.elt Lwt.t
val tally_trustees : 'a election -> int -> string -> unit -> [> `Html ] Eliom_content.Html.F.elt Lwt.t
val login_choose :
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment