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 = ...@@ -411,6 +411,14 @@ let unwebize_trustee_public_key pk =
trustee_public_key = pk.web_trustee_public_key; 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_contact = "Name <user@example.org>"
let default_questions = let default_questions =
......
...@@ -152,6 +152,8 @@ val unurlize : string -> string ...@@ -152,6 +152,8 @@ val unurlize : string -> string
val webize_trustee_public_key : bool -> 'a trustee_public_key -> 'a web_trustee_public_key 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 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_contact : string
val default_questions : question array val default_questions : question array
val default_name : string val default_name : string
......
...@@ -120,7 +120,7 @@ type draft_threshold_trustee = { ...@@ -120,7 +120,7 @@ type draft_threshold_trustee = {
type draft_election = { type draft_election = {
owner : user; owner : user;
group : string; group <ocaml mutable> : string;
voters <ocaml mutable> : draft_voter list; voters <ocaml mutable> : draft_voter list;
questions <ocaml mutable> : template; questions <ocaml mutable> : template;
public_keys <ocaml mutable> : draft_trustee list; public_keys <ocaml mutable> : draft_trustee list;
......
...@@ -33,7 +33,7 @@ let logout = create ~path:(Path ["logout"]) ~meth:(Get (site_cont "cont")) () ...@@ -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 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_pre = create ~path:(Path ["draft"; "new"]) ~meth:(Get unit) ()
let election_draft = create ~path:(Path ["draft"; "election"]) ~meth:(Get (uuid "uuid")) () 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")) () let election_draft_questions = create ~path:(Path ["draft"; "questions"]) ~meth:(Get (uuid "uuid")) ()
......
...@@ -387,7 +387,7 @@ let generate_uuid = ...@@ -387,7 +387,7 @@ let generate_uuid =
let redir_preapply s u () = Redirection.send (Redirection (preapply s u)) 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 let e_cred_authority = match cred with
| `Automatic -> Some "server" | `Automatic -> Some "server"
| `Manual -> None | `Manual -> None
...@@ -397,10 +397,6 @@ let create_new_election owner cred auth group = ...@@ -397,10 +397,6 @@ let create_new_election owner cred auth group =
| `Dummy -> Some [{auth_system = "dummy"; auth_instance = "dummy"; auth_config = []}] | `Dummy -> Some [{auth_system = "dummy"; auth_instance = "dummy"; auth_config = []}]
| `CAS server -> Some [{auth_system = "cas"; auth_instance = "cas"; auth_config = ["server", server]}] | `CAS server -> Some [{auth_system = "cas"; auth_instance = "cas"; auth_config = ["server", server]}]
in 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 uuid = generate_uuid () in
let%lwt token = generate_token () in let%lwt token = generate_token () in
let se_metadata = { let se_metadata = {
...@@ -419,7 +415,7 @@ let create_new_election owner cred auth group = ...@@ -419,7 +415,7 @@ let create_new_election owner cred auth group =
} in } in
let se = { let se = {
se_owner = owner; se_owner = owner;
se_group; se_group = !Web_config.default_group;
se_voters = []; se_voters = [];
se_questions; se_questions;
se_public_keys = []; se_public_keys = [];
...@@ -440,7 +436,7 @@ let () = Html.register ~service:election_draft_pre ...@@ -440,7 +436,7 @@ let () = Html.register ~service:election_draft_pre
(fun () () -> T.election_draft_pre ()) (fun () () -> T.election_draft_pre ())
let () = Any.register ~service:election_draft_new let () = Any.register ~service:election_draft_new
(fun () (credmgmt, (auth, (cas_server, group))) -> (fun () (credmgmt, (auth, cas_server)) ->
with_site_user (fun u -> with_site_user (fun u ->
let%lwt credmgmt = match credmgmt with let%lwt credmgmt = match credmgmt with
| Some "auto" -> return `Automatic | Some "auto" -> return `Automatic
...@@ -453,12 +449,7 @@ let () = Any.register ~service:election_draft_new ...@@ -453,12 +449,7 @@ let () = Any.register ~service:election_draft_new
| Some "cas" -> return @@ `CAS cas_server | Some "cas" -> return @@ `CAS cas_server
| _ -> fail_http 400 | _ -> fail_http 400
in in
let%lwt group = match group with create_new_election u credmgmt auth
| Some "default" -> return `Default
| Some "nh" -> return `NH
| _ -> fail_http 400
in
create_new_election u credmgmt auth group
) )
) )
...@@ -694,6 +685,14 @@ let () = ...@@ -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 () = let () =
Html.register ~service:election_draft_questions Html.register ~service:election_draft_questions
(fun uuid () -> (fun uuid () ->
...@@ -706,7 +705,16 @@ let () = ...@@ -706,7 +705,16 @@ let () =
Any.register ~service:election_draft_questions_post Any.register ~service:election_draft_questions_post
(fun uuid template -> (fun uuid template ->
with_draft_election uuid (fun se -> 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 () redir_preapply election_draft uuid ()
) )
) )
......
...@@ -317,7 +317,7 @@ let election_draft_pre () = ...@@ -317,7 +317,7 @@ let election_draft_pre () =
in in
let form = let form =
post_form ~service:election_draft_new post_form ~service:election_draft_new
(fun (credmgmt, (auth, (cas_server, group))) -> (fun (credmgmt, (auth, cas_server)) ->
[ [
fieldset fieldset
~legend:(legend [ ~legend:(legend [
...@@ -349,18 +349,6 @@ let election_draft_pre () = ...@@ -349,18 +349,6 @@ let election_draft_pre () =
pcdata " (for example: https://cas.inria.fr/cas)"; 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 [ div [
input ~input_type:`Submit ~value:"Proceed" string; 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