Threshold: add basic trustee management + key establishment protocol

src/web/web_serializable.atd

@@ -27,6 +27,9 @@ type uuid <ocaml predef from="Serializable_builtin"> = abstract
 type string_set <ocaml predef from="Serializable_builtin"> = abstract
 type datetime <ocaml predef from="Web_serializable_builtin"> = abstract
 type template <ocaml predef from="Serializable"> = abstract
+type cert <ocaml predef from="Serializable"> = abstract
+type polynomial <ocaml predef from="Serializable"> = abstract
+type vinput <ocaml predef from="Serializable"> = abstract
 
 (** {1 Web-specific types} *)
 
@@ -66,6 +69,16 @@ type setup_trustee = {
   public_key <ocaml mutable> : string;
 } <ocaml field_prefix="st_">
 
+type setup_threshold_trustee = {
+  id : string;
+  token : string;
+  ?step <ocaml mutable> : int option;
+  ?cert <ocaml mutable> : cert option;
+  ?polynomial <ocaml mutable> : polynomial option;
+  ?vinput <ocaml mutable> : vinput option;
+  ?voutput <ocaml mutable> : string option;
+} <ocaml field_prefix="stt_">
+
 type setup_election = {
   owner : user;
   group : string;
@@ -75,6 +88,10 @@ type setup_election = {
   metadata <ocaml mutable> : metadata;
   public_creds : string;
   public_creds_received <ocaml mutable> : bool;
+  ?threshold <ocaml mutable> : int option;
+  ?threshold_trustees <ocaml mutable> : setup_threshold_trustee list option;
+  ?threshold_parameters <ocaml mutable> : string option;
+  ?threshold_error <ocaml mutable> : string option;
 } <ocaml field_prefix="se_">
 
 (** {1 OpenID Connect-related types} *)

src/web/web_services.ml

@@ -56,6 +56,14 @@ let election_setup_credentials_server = post_coservice ~fallback:election_setup
 let election_setup_trustees = service ~path:["setup"; "trustees"] ~get_params:(uuid "uuid") ()
 let election_setup_trustee = service ~path:["setup"; "trustee"] ~get_params:(string "token") ()
 let election_setup_trustee_post = post_coservice ~fallback:election_setup_trustee ~post_params:(string "public_key") ()
+
+let election_setup_threshold_trustees = service ~path:["setup"; "threshold-trustees"] ~get_params:(uuid "uuid") ()
+let election_setup_threshold_trustee = service ~path:["setup"; "threshold-trustee"] ~get_params:(string "token") ()
+let election_setup_threshold_trustee_post = post_coservice ~fallback:election_setup_threshold_trustee ~post_params:(string "data") ()
+let election_setup_threshold_set = post_coservice ~fallback:election_setup_threshold_trustees ~post_params:(int "threshold") ()
+let election_setup_threshold_trustee_add = post_coservice ~fallback:election_setup_threshold_trustees ~post_params:(string "id") ()
+let election_setup_threshold_trustee_del = post_coservice ~fallback:election_setup_threshold_trustees ~post_params:(int "index") ()
+
 let election_setup_confirm = service ~path:["setup"; "confirm"] ~get_params:(uuid "uuid") ()
 let election_setup_create = post_coservice ~csrf_safe:true ~fallback:election_setup ~post_params:unit ()
 let election_setup_auth_genpwd = post_coservice ~fallback:election_setup ~post_params:unit ()

src/web/web_site.ml

@@ -45,6 +45,9 @@ let election_stable = Ocsipersist.open_table "site_setup"
 (* Table with tokens given to trustees. *)
 let election_pktokens = Ocsipersist.open_table "site_pktokens"
 
+(* Table with tokens given to trustees (in threshold mode). *)
+let election_tpktokens = Ocsipersist.open_table "site_tpktokens"
+
 (* Table with tokens given to credential authorities. *)
 let election_credtokens = Ocsipersist.open_table "site_credtokens"
 
@@ -327,6 +330,10 @@ let create_new_election owner cred auth =
     se_metadata;
     se_public_creds = token;
     se_public_creds_received = false;
+    se_threshold = None;
+    se_threshold_trustees = None;
+    se_threshold_parameters = None;
+    se_threshold_error = None;
   } in
   let%lwt () = set_setup_election uuid_s se in
   let%lwt () = Ocsipersist.add election_credtokens token uuid_s in
@@ -369,6 +376,9 @@ let () = Html5.register ~service:election_setup
 let () = Html5.register ~service:election_setup_trustees
   (generic_setup_page T.election_setup_trustees)
 
+let () = Html5.register ~service:election_setup_threshold_trustees
+  (generic_setup_page T.election_setup_threshold_trustees)
+
 let () = Html5.register ~service:election_setup_credential_authority
   (generic_setup_page T.election_setup_credential_authority)
 
@@ -1512,3 +1522,228 @@ let () =
       match cont with
       | Some f -> f ()
       | None -> Redirection.send home)
+
+let () =
+  Any.register ~service:election_setup_threshold_set
+    (fun uuid threshold ->
+      if threshold < 0 then forbidden () else
+      let threshold = if threshold = 0 then None else Some threshold in
+      match%lwt Web_state.get_site_user () with
+      | Some u ->
+         let uuid_s = Uuidm.to_string uuid in
+         Lwt_mutex.with_lock election_setup_mutex (fun () ->
+             let%lwt se = get_setup_election uuid_s in
+             if se.se_owner = u
+             then (
+               (match se.se_threshold_trustees with
+                | None -> ()
+                | Some xs -> List.iter (fun x -> x.stt_step <- Some 1) xs
+               );
+               se.se_threshold <- threshold;
+               set_setup_election uuid_s se
+             ) else forbidden ()
+           ) >>
+           Redirection.send (preapply election_setup_threshold_trustees uuid)
+      | None -> forbidden ())
+
+let () =
+  Any.register
+    ~service:election_setup_threshold_trustee_add
+    (fun uuid stt_id ->
+      if is_email stt_id then
+        match%lwt Web_state.get_site_user () with
+        | Some u ->
+           let uuid_s = Uuidm.to_string uuid in
+           Lwt_mutex.with_lock election_setup_mutex (fun () ->
+               let%lwt se = get_setup_election uuid_s in
+               if se.se_owner = u
+               then (
+                 let%lwt stt_token = generate_token () in
+                 let trustee = {
+                     stt_id; stt_token; stt_step = None;
+                     stt_cert = None; stt_polynomial = None;
+                     stt_vinput = None; stt_voutput = None;
+                   } in
+                 let trustees =
+                   match se.se_threshold_trustees with
+                   | None -> Some [trustee]
+                   | Some t -> Some (t @ [trustee])
+                 in
+                 se.se_threshold_trustees <- trustees;
+                 set_setup_election uuid_s se >>
+                 Ocsipersist.add election_tpktokens stt_token uuid_s
+               ) else forbidden ()
+             ) >>
+             Redirection.send (preapply election_setup_threshold_trustees uuid)
+        | None -> forbidden ()
+      else
+        let msg = stt_id ^ " is not a valid e-mail address!" in
+        let service = preapply election_setup_threshold_trustees uuid in
+        T.generic_page ~title:"Error" ~service msg () >>= Html5.send
+    )
+
+let () =
+  Redirection.register
+    ~service:election_setup_threshold_trustee_del
+    (fun uuid index ->
+      match%lwt Web_state.get_site_user () with
+      | Some u ->
+         let uuid_s = Uuidm.to_string uuid in
+         Lwt_mutex.with_lock election_setup_mutex (fun () ->
+             let%lwt se = get_setup_election uuid_s in
+             if se.se_owner = u
+             then (
+               let trustees, old =
+                 let trustees =
+                   match se.se_threshold_trustees with
+                   | None -> []
+                   | Some x -> x
+                 in
+                 trustees |>
+                   List.mapi (fun i x -> i, x) |>
+                   List.partition (fun (i, _) -> i <> index) |>
+                   (fun (x, y) -> List.map snd x, List.map snd y)
+               in
+               let trustees = match trustees with [] -> None | x -> Some x in
+               se.se_threshold_trustees <- trustees;
+               set_setup_election uuid_s se >>
+                 Lwt_list.iter_s (fun {stt_token; _} ->
+                     Ocsipersist.remove election_tpktokens stt_token
+                   ) old
+             ) else forbidden ()
+           ) >>
+           return (preapply election_setup_threshold_trustees uuid)
+      | None -> forbidden ()
+    )
+
+let () =
+  Html5.register
+    ~service:election_setup_threshold_trustee
+    (fun token () ->
+      let%lwt uuid = Ocsipersist.find election_tpktokens token in
+      let%lwt se = get_setup_election uuid in
+      let uuid = match Uuidm.of_string uuid with
+        | None -> failwith "invalid UUID extracted from pktokens"
+        | Some u -> u
+      in
+      T.election_setup_threshold_trustee token uuid se ()
+    )
+
+let () =
+  Any.register
+    ~service:election_setup_threshold_trustee_post
+    (fun token data ->
+      wrap_handler
+        (fun () ->
+          let%lwt uuid = Ocsipersist.find election_tpktokens token in
+          Lwt_mutex.with_lock election_setup_mutex
+            (fun () ->
+              let%lwt se = get_setup_election uuid in
+              let ts =
+                match se.se_threshold_trustees with
+                | None -> failwith "No threshold trustees"
+                | Some xs -> Array.of_list xs
+              in
+              let i, t =
+                match Array.findi (fun i x ->
+                          if token = x.stt_token then Some (i, x) else None
+                        ) ts with
+                | Some (i, t) -> i, t
+                | None -> failwith "Trustee not found"
+              in
+              let get_certs () =
+                let certs = Array.map (fun x ->
+                                match x.stt_cert with
+                                | None -> failwith "Missing certificate"
+                                | Some y -> y
+                              ) ts in
+                {certs}
+              in
+              let get_polynomials () =
+                Array.map (fun x ->
+                    match x.stt_polynomial with
+                    | None -> failwith "Missing polynomial"
+                    | Some y -> y
+                  ) ts
+              in
+              let module G = (val Group.of_string se.se_group : GROUP) in
+              let module P = Trustees.MakePKI (G) (LwtRandom) in
+              let module C = Trustees.MakeChannels (G) (LwtRandom) (P) in
+              let module K = Trustees.MakePedersen (G) (LwtRandom) (P) (C) in
+              (match t.stt_step with
+               | Some 1 ->
+                  let cert = cert_of_string data in
+                  if K.step1_check cert then (
+                    t.stt_cert <- Some cert;
+                    t.stt_step <- Some 2;
+                    return_unit
+                  ) else (
+                    failwith "Invalid certificate"
+                  )
+               | Some 3 ->
+                  let certs = get_certs () in
+                  let polynomial = polynomial_of_string data in
+                  if K.step3_check certs i polynomial then (
+                    t.stt_polynomial <- Some polynomial;
+                    t.stt_step <- Some 4;
+                    return_unit
+                  ) else (
+                    failwith "Invalid polynomial"
+                  )
+               | Some 5 ->
+                  let certs = get_certs () in
+                  let polynomials = get_polynomials () in
+                  let voutput = voutput_of_string G.read data in
+                  if K.step5_check certs i polynomials voutput then (
+                    t.stt_voutput <- Some data;
+                    t.stt_step <- Some 6;
+                    return_unit
+                  ) else (
+                    failwith "Invalid voutput"
+                  )
+               | _ -> failwith "Unknown step"
+              ) >> (
+                if Array.forall (fun x -> x.stt_step = Some 2) ts then (
+                  (try
+                     K.step2 (get_certs ());
+                     Array.iter (fun x -> x.stt_step <- Some 3) ts;
+                   with e ->
+                     se.se_threshold_error <- Some (Printexc.to_string e)
+                  ); return_unit
+                ) else return_unit
+              ) >> (
+                if Array.forall (fun x -> x.stt_step = Some 4) ts then (
+                  (try
+                     let certs = get_certs () in
+                     let polynomials = get_polynomials () in
+                     let vinputs = K.step4 certs polynomials in
+                     for j = 0 to Array.length ts - 1 do
+                       ts.(j).stt_vinput <- Some vinputs.(j)
+                     done;
+                     Array.iter (fun x -> x.stt_step <- Some 5) ts
+                   with e ->
+                     se.se_threshold_error <- Some (Printexc.to_string e)
+                  ); return_unit
+                ) else return_unit
+              ) >> (
+                if Array.forall (fun x -> x.stt_step = Some 6) ts then (
+                  (try
+                     let certs = get_certs () in
+                     let polynomials = get_polynomials () in
+                     let voutputs = Array.map (fun x ->
+                                        match x.stt_voutput with
+                                        | None -> failwith "Missing voutput"
+                                        | Some y -> voutput_of_string G.read y
+                                      ) ts in
+                     let p = K.step6 certs polynomials voutputs in
+                     se.se_threshold_parameters <- Some (string_of_threshold_parameters G.write p);
+                     Array.iter (fun x -> x.stt_step <- Some 7) ts
+                   with e ->
+                     se.se_threshold_error <- Some (Printexc.to_string e)
+                  ); return_unit
+                ) else return_unit
+              ) >> set_setup_election uuid se
+            ) >>
+            Redirection.send (preapply election_setup_threshold_trustee token)
+        )
+    )

src/web/web_templates.ml

@@ -587,6 +587,11 @@ let election_setup_trustees uuid se () =
   let div_content =
     div [
       div [pcdata "If you do not wish the server to store any keys, you may nominate trustees. In that case, each trustee will create her own secret key. Be careful, once the election is over, you will need the contribution of each trustee to compute the result!"];
+      div [
+          pcdata "You can also set up the election so that only a ";
+          a ~service:election_setup_threshold_trustees [pcdata "threshold"] uuid;
+          pcdata " of trustees is needed to perform the decryption.";
+        ];
       br ();
       trustees;
       (if se.se_public_keys <> [] then
@@ -616,6 +621,121 @@ let election_setup_trustees uuid se () =
   let%lwt login_box = site_login_box () in
   base ~title ?login_box ~content ()
 
+let election_setup_threshold_trustees uuid se () =
+  let title = "Trustees for election " ^ se.se_questions.t_name in
+  let show_add_remove = se.se_threshold = None in
+  let form_trustees_add =
+    if show_add_remove then
+      post_form
+        ~service:election_setup_threshold_trustee_add
+        (fun name ->
+          [
+            pcdata "Trustee's e-mail address: ";
+            string_input ~input_type:`Text ~name ();
+            string_input ~input_type:`Submit ~value:"Add" ();
+          ]
+        ) uuid
+    else pcdata ""
+  in
+  let mk_form_trustee_del value =
+    post_form
+      ~service:election_setup_threshold_trustee_del
+      (fun name ->
+        [
+          int_input ~input_type:`Hidden ~name ~value ();
+          string_input ~input_type:`Submit ~value:"Remove" ();
+      ]) uuid
+  in
+  let trustees = match se.se_threshold_trustees with
+    | None -> pcdata ""
+    | Some ts ->
+       table (
+         tr (
+           [
+             th [pcdata "Trustee"];
+             th [pcdata "Mail"];
+             th [pcdata "Link"];
+             th [pcdata "Step"];
+           ] @ (if show_add_remove then [th [pcdata "Remove"]] else [])
+         ) ::
+           List.mapi (fun i t ->
+             tr (
+                 [
+                   td [
+                       pcdata t.stt_id;
+                     ];
+                   td [
+                       let uri = rewrite_prefix @@
+                                   Eliom_uri.make_string_uri
+                                     ~absolute:true ~service:election_setup_threshold_trustee t.stt_token
+                       in
+                       let body = Printf.sprintf mail_trustee_generation uri in
+                       let subject = "Link to generate the decryption key" in
+                       a_mailto ~dest:t.stt_id ~subject ~body "Mail"
+                     ];
+                   td [
+                       a ~service:election_setup_threshold_trustee [pcdata "Link"] t.stt_token;
+                     ];
+                   td [
+                       pcdata (string_of_int (match t.stt_step with None -> 0 | Some x -> x));
+                     ];
+                 ] @ (if show_add_remove then [td [mk_form_trustee_del i]] else [])
+               )
+             ) ts
+         )
+  in
+  let form_threshold =
+    div [
+        let value =
+          match se.se_threshold with
+          | None -> 0
+          | Some i -> i
+        in
+        post_form
+          ~service:election_setup_threshold_set
+          (fun name ->
+            [
+              pcdata "Threshold: ";
+              int_input ~input_type:`Text ~name ~value ();
+              string_input ~input_type:`Submit ~value:"Set" ();
+            ]
+          ) uuid
+      ]
+  in
+  let maybe_error =
+    match se.se_threshold_error with
+    | None -> pcdata ""
+    | Some e -> div [b [pcdata "ERROR: "]; pcdata e; br (); br ()]
+  in
+  let div_content =
+    div [
+      div [pcdata "On this page, you can configure a group of trustees such that only a threshold of them is needed to perform the decryption."];
+      br ();
+      form_threshold;
+      br ();
+      trustees;
+      (if se.se_threshold_trustees <> None then
+          div [
+            pcdata "There is one link per trustee. Send each trustee her link.";
+            br ();
+            br ();
+            maybe_error;
+          ]
+       else pcdata "");
+      form_trustees_add;
+    ]
+  in
+  let back_link = div [
+    a ~service:Web_services.election_setup
+      [pcdata "Go back to election setup"] uuid;
+  ] in
+  let content = [
+    div_content;
+    back_link;
+  ] in
+  let%lwt login_box = site_login_box () in
+  base ~title ?login_box ~content ()
+
 let election_setup_credential_authority _ se () =
   let title = "Credentials for election " ^ se.se_questions.t_name in
   let content = [
@@ -928,6 +1048,83 @@ let election_setup_trustee token uuid se () =
   ] in
   base ~title ~content ()
 
+let unsafe_textarea id contents =
+  Printf.ksprintf Unsafe.data
+    "<textarea id=\"%s\">%s</textarea>"
+    id contents
+
+let election_setup_threshold_trustee token uuid se () =
+  let title = "Trustee for election " ^ se.se_questions.t_name in
+  let div_link =
+    let url = Eliom_uri.make_string_uri ~absolute:true
+                ~service:election_home (uuid, ()) |> rewrite_prefix
+    in
+    div [
+        pcdata "The link to the election will be:";
+        ul [li [pcdata url]];
+      ]
+  in
+  let%lwt trustee =
+    match se.se_threshold_trustees with
+    | None -> fail_http 404
+    | Some ts ->
+       try return (List.find (fun x -> x.stt_token = token) ts)
+       with Not_found -> fail_http 404
+  in
+  let%lwt certs =
+    match se.se_threshold_trustees with
+    | None -> fail_http 404
+    | Some ts ->
+       let certs = List.fold_left (fun accu x ->
+           match x.stt_cert with
+           | None -> accu
+           | Some c -> c :: accu
+         ) [] ts |> Array.of_list
+       in return {certs}
+  in
+  let inputs =
+    div [
+        div [
+            pcdata "Step: ";
+            unsafe_textarea "step" (match trustee.stt_step with None -> "0" | Some x -> string_of_int x);
+          ];
+        div [
+            pcdata "Group parameters: ";
+            unsafe_textarea "group" se.se_group;
+          ];
+        div [
+            pcdata "Certificates: ";
+            unsafe_textarea "certs" (string_of_certs certs);
+          ];
+        div [
+            pcdata "Vinput: ";
+            unsafe_textarea "vinput" (match trustee.stt_vinput with None -> "" | Some x -> string_of_vinput x);
+          ];
+      ]
+  in
+  let form =
+    post_form
+      ~service:election_setup_threshold_trustee_post
+      (fun data ->
+        [
+          div [
+              div [
+                  pcdata "Data: ";
+                  textarea ~name:data ();
+                ];
+              div [string_input ~input_type:`Submit ~value:"Submit" ()];
+            ];
+        ]
+      ) token
+  in
+  let content = [
+      div_link;
+      inputs;
+      form;
+    ]
+  in
+  base ~title ~content ()
+
 let election_setup_importer ~service ~title uuid (elections, tallied, archived) () =
   let format_election election =
     let module W = (val election : ELECTION_DATA) in

src/web/web_templates.mli

@@ -43,7 +43,9 @@ val election_setup_questions : Uuidm.t -> setup_election -> unit -> [> `Html ] E
 val election_setup_credential_authority : Uuidm.t -> setup_election -> unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
 val election_setup_credentials : string -> Uuidm.t -> setup_election -> unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
 val election_setup_trustees : Uuidm.t -> setup_election -> unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
+val election_setup_threshold_trustees : Uuidm.t -> setup_election -> unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
 val election_setup_trustee : string -> Uuidm.t -> setup_election -> unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
+val election_setup_threshold_trustee : string -> Uuidm.t -> setup_election -> unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
 val election_setup_import : Uuidm.t -> setup_election -> (module ELECTION_DATA) list * (module ELECTION_DATA) list * (module ELECTION_DATA) list -> unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
 val election_setup_import_trustees : Uuidm.t -> setup_election -> (module ELECTION_DATA) list * (module ELECTION_DATA) list * (module ELECTION_DATA) list -> unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
 val election_setup_confirm : Uuidm.t -> setup_election -> unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t