Commit a51a270c authored by Stephane Glondu's avatar Stephane Glondu

Do not ask for group in pre-setup

The group is initially set to the H one, and changed to NH when the
questions require it.
parent 4b4cec75
Pipeline #74358 passed with stages
in 16 minutes and 40 seconds
......@@ -411,6 +411,14 @@ let unwebize_trustee_public_key pk =
trustee_public_key = pk.web_trustee_public_key;
}
let get_suitable_group_kind {t_questions; _} =
let group = ref `H in
Array.iter (function
| Question.Open _ -> group := `NH
| Question.Standard _ -> ()
) t_questions;
!group
let default_contact = "Name <user@example.org>"
let default_questions =
......
......@@ -152,6 +152,8 @@ val unurlize : string -> string
val webize_trustee_public_key : bool -> 'a trustee_public_key -> 'a web_trustee_public_key
val unwebize_trustee_public_key : 'a web_trustee_public_key -> 'a trustee_public_key
val get_suitable_group_kind : template -> [ `H | `NH ]
val default_contact : string
val default_questions : question array
val default_name : string
......
......@@ -120,7 +120,7 @@ type draft_threshold_trustee = {
type draft_election = {
owner : user;
group : string;
group <ocaml mutable> : string;
voters <ocaml mutable> : draft_voter list;
questions <ocaml mutable> : template;
public_keys <ocaml mutable> : draft_trustee list;
......
......@@ -33,7 +33,7 @@ let logout = create ~path:(Path ["logout"]) ~meth:(Get (site_cont "cont")) ()
let source_code = create ~path:(Path ["belenios.tar.gz"]) ~meth:(Get unit) ()
let election_draft_new = create_attached_post ~csrf_safe:true ~fallback:admin ~post_params:(radio string "credmgmt" ** radio string "auth" ** string "cas_server" ** radio string "group") ()
let election_draft_new = create_attached_post ~csrf_safe:true ~fallback:admin ~post_params:(radio string "credmgmt" ** radio string "auth" ** string "cas_server") ()
let election_draft_pre = create ~path:(Path ["draft"; "new"]) ~meth:(Get unit) ()
let election_draft = create ~path:(Path ["draft"; "election"]) ~meth:(Get (uuid "uuid")) ()
let election_draft_questions = create ~path:(Path ["draft"; "questions"]) ~meth:(Get (uuid "uuid")) ()
......
......@@ -387,7 +387,7 @@ let generate_uuid =
let redir_preapply s u () = Redirection.send (Redirection (preapply s u))
let create_new_election owner cred auth group =
let create_new_election owner cred auth =
let e_cred_authority = match cred with
| `Automatic -> Some "server"
| `Manual -> None
......@@ -397,10 +397,6 @@ let create_new_election owner cred auth group =
| `Dummy -> Some [{auth_system = "dummy"; auth_instance = "dummy"; auth_config = []}]
| `CAS server -> Some [{auth_system = "cas"; auth_instance = "cas"; auth_config = ["server", server]}]
in
let se_group = match group with
| `Default -> !Web_config.default_group
| `NH -> !Web_config.nh_group
in
let%lwt uuid = generate_uuid () in
let%lwt token = generate_token () in
let se_metadata = {
......@@ -419,7 +415,7 @@ let create_new_election owner cred auth group =
} in
let se = {
se_owner = owner;
se_group;
se_group = !Web_config.default_group;
se_voters = [];
se_questions;
se_public_keys = [];
......@@ -440,7 +436,7 @@ let () = Html.register ~service:election_draft_pre
(fun () () -> T.election_draft_pre ())
let () = Any.register ~service:election_draft_new
(fun () (credmgmt, (auth, (cas_server, group))) ->
(fun () (credmgmt, (auth, cas_server)) ->
with_site_user (fun u ->
let%lwt credmgmt = match credmgmt with
| Some "auto" -> return `Automatic
......@@ -453,12 +449,7 @@ let () = Any.register ~service:election_draft_new
| Some "cas" -> return @@ `CAS cas_server
| _ -> fail_http 400
in
let%lwt group = match group with
| Some "default" -> return `Default
| Some "nh" -> return `NH
| _ -> fail_http 400
in
create_new_election u credmgmt auth group
create_new_election u credmgmt auth
)
)
......@@ -694,6 +685,14 @@ let () =
)
)
let is_group_fixed se =
se.se_public_creds_received
|| se.se_public_keys <> []
|| (match se.se_threshold_trustees with
| Some l -> l <> []
| None -> false
)
let () =
Html.register ~service:election_draft_questions
(fun uuid () ->
......@@ -706,7 +705,16 @@ let () =
Any.register ~service:election_draft_questions_post
(fun uuid template ->
with_draft_election uuid (fun se ->
se.se_questions <- template_of_string template;
let template = template_of_string template in
let fixed_group = is_group_fixed se in
(match get_suitable_group_kind se.se_questions, get_suitable_group_kind template with
| `NH, `NH | `H, `H -> ()
| `NH, `H when fixed_group -> ()
| `NH, `H -> se.se_group <- !Web_config.default_group
| `H, `NH when fixed_group -> failwith "This kind of change is not allowed now!"
| `H, `NH -> se.se_group <- !Web_config.nh_group
);
se.se_questions <- template;
redir_preapply election_draft uuid ()
)
)
......
......@@ -317,7 +317,7 @@ let election_draft_pre () =
in
let form =
post_form ~service:election_draft_new
(fun (credmgmt, (auth, (cas_server, group))) ->
(fun (credmgmt, (auth, cas_server)) ->
[
fieldset
~legend:(legend [
......@@ -349,18 +349,6 @@ let election_draft_pre () =
pcdata " (for example: https://cas.inria.fr/cas)";
];
];
fieldset
~legend:(legend [pcdata "Group"])
[
div [
radio ~checked:true ~name:group ~value:"default" string;
pcdata " Homomorphic";
];
div [
radio ~name:group ~value:"nh" string;
pcdata " Non-homomorphic";
];
];
div [
input ~input_type:`Submit ~value:"Proceed" string;
];
......
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