Commit 87044b17 authored by Stephane Glondu's avatar Stephane Glondu

Ask the user to choose a group in election_draft_new

parent 41910171
......@@ -52,6 +52,7 @@
<!-- <auth name="google"><oidc server="https://accounts.google.com" client_id="client-id" client_secret="client-secret"/></auth> -->
<source file="../belenios.tar.gz"/>
<default-group file="demo/groups/default.json"/>
<nh-group file="demo/groups/rfc3526-2048.json"/>
<log file="_RUNDIR_/log/security.log"/>
<spool dir="_RUNDIR_/spool"/>
<warning file="demo/warning.html"/>
......
......@@ -30,3 +30,4 @@ let source_file = ref "belenios.tar.gz"
let maxmailsatonce = ref 1000
let uuid_length = ref None
let default_group = ref ""
let nh_group = ref ""
......@@ -32,3 +32,4 @@ val source_file : string ref
val maxmailsatonce : int ref
val uuid_length : int option ref
val default_group : string ref
val nh_group : string ref
......@@ -39,6 +39,7 @@ let source_file = ref None
let auth_instances = ref []
let gdpr_uri = ref None
let default_group_file = ref None
let nh_group_file = ref None
let () =
Eliom_config.get_config () |>
......@@ -52,6 +53,8 @@ let () =
source_file := Some file
| Element ("default-group", ["file", file], []) ->
default_group_file := Some file
| Element ("nh-group", ["file", file], []) ->
nh_group_file := Some file
| Element ("maxmailsatonce", ["value", limit], []) ->
Web_config.maxmailsatonce := int_of_string limit
| Element ("uuid", ["length", length], []) ->
......@@ -121,9 +124,19 @@ let%lwt default_group =
| [x] -> return x
| _ -> failwith "invalid default group file"
let%lwt nh_group =
match !nh_group_file with
| None -> failwith "missing <nh-group> in configuration"
| Some x ->
let%lwt x = Lwt_io.lines_of_file x |> Lwt_stream.to_list in
match x with
| [x] -> return x
| _ -> failwith "invalid NH group file"
(** Build up the site *)
let () = Web_config.source_file := source_file
let () = Web_config.spool_dir := spool_dir
let () = Web_config.default_group := default_group
let () = Web_config.nh_group := nh_group
let () = Web_config.site_auth_config := List.rev !auth_instances
......@@ -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") ()
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_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 =
let create_new_election owner cred auth group =
let e_cred_authority = match cred with
| `Automatic -> Some "server"
| `Manual -> None
......@@ -397,6 +397,10 @@ let create_new_election owner cred auth =
| `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 = {
......@@ -415,7 +419,7 @@ let create_new_election owner cred auth =
} in
let se = {
se_owner = owner;
se_group = !Web_config.default_group;
se_group;
se_voters = [];
se_questions;
se_public_keys = [];
......@@ -436,7 +440,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)) ->
(fun () (credmgmt, (auth, (cas_server, group))) ->
with_site_user (fun u ->
let%lwt credmgmt = match credmgmt with
| Some "auto" -> return `Automatic
......@@ -449,7 +453,12 @@ let () = Any.register ~service:election_draft_new
| Some "cas" -> return @@ `CAS cas_server
| _ -> fail_http 400
in
create_new_election u credmgmt auth
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
)
)
......
......@@ -317,7 +317,7 @@ let election_draft_pre () =
in
let form =
post_form ~service:election_draft_new
(fun (credmgmt, (auth, cas_server)) ->
(fun (credmgmt, (auth, (cas_server, group))) ->
[
fieldset
~legend:(legend [
......@@ -349,6 +349,18 @@ 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