Add a pre-setup page

On this page, the user can choose how credential will be managed, and
the authentication scheme. The goal is to simplify the workflow
afterwards.

src/web/web_services.ml

@@ -35,7 +35,8 @@ let get_randomness = service ~path:["get-randomness"] ~get_params:unit ()
 
 let tool = preapply (static_dir ()) ["static"; "belenios-tool.html"]
 
-let election_setup_new = post_coservice ~csrf_safe:true ~fallback:admin ~post_params:unit ()
+let election_setup_new = post_coservice ~csrf_safe:true ~fallback:admin ~post_params:(radio string "credmgmt" ** radio string "auth" ** string "cas_server") ()
+let election_setup_pre = service ~path:["setup"; "new"] ~get_params:unit ()
 let election_setup = service ~path:["setup"; "election"] ~get_params:(uuid "uuid") ()
 let election_setup_group = post_coservice ~fallback:election_setup ~post_params:(string "group") ()
 let election_setup_metadata = post_coservice ~fallback:election_setup ~post_params:(string "metadata") ()

src/web/web_site.ml

@@ -323,44 +323,69 @@ let () = String.register
 
 let generate_uuid = Uuidm.v4_gen (Random.State.make_self_init ())
 
+let create_new_election owner cred auth =
+  let e_cred_authority = match cred with
+    | `Automatic -> Some "server"
+    | `Manual -> None
+  in
+  let e_auth_config = match auth with
+    | `Password -> Some [{auth_system = "password"; auth_instance = "password"; 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]}]
+  in
+  let uuid = generate_uuid () in
+  let uuid_s = Uuidm.to_string uuid in
+  lwt token = generate_token () in
+  let se_metadata = {
+    e_owner = Some owner;
+    e_auth_config;
+    e_cred_authority;
+  } in
+  let question = {
+    q_answers = [| "Answer 1"; "Answer 2"; "Blank" |];
+    q_min = 1;
+    q_max = 1;
+    q_question = "Question 1?";
+  } in
+  let se_questions = {
+    t_description = "Description of the election.";
+    t_name = "Name of the election";
+    t_questions = [| question |];
+    t_short_name = "short_name";
+  } in
+  let se = {
+    se_owner = owner;
+    se_group = "{\"g\":\"14887492224963187634282421537186040801304008017743492304481737382571933937568724473847106029915040150784031882206090286938661464458896494215273989547889201144857352611058572236578734319505128042602372864570426550855201448111746579871811249114781674309062693442442368697449970648232621880001709535143047913661432883287150003429802392229361583608686643243349727791976247247948618930423866180410558458272606627111270040091203073580238905303994472202930783207472394578498507764703191288249547659899997131166130259700604433891232298182348403175947450284433411265966789131024573629546048637848902243503970966798589660808533\",\"p\":\"16328632084933010002384055033805457329601614771185955389739167309086214800406465799038583634953752941675645562182498120750264980492381375579367675648771293800310370964745767014243638518442553823973482995267304044326777047662957480269391322789378384619428596446446984694306187644767462460965622580087564339212631775817895958409016676398975671266179637898557687317076177218843233150695157881061257053019133078545928983562221396313169622475509818442661047018436264806901023966236718367204710755935899013750306107738002364137917426595737403871114187750804346564731250609196846638183903982387884578266136503697493474682071\",\"q\":\"61329566248342901292543872769978950870633559608669337131139375508370458778917\"}";
+    se_voters = [];
+    se_questions;
+    se_public_keys = [];
+    se_metadata;
+    se_public_creds = token;
+  } in
+  lwt () = Ocsipersist.add election_stable uuid_s se in
+  lwt () = Ocsipersist.add election_credtokens token uuid_s in
+  return (preapply election_setup uuid)
+
+let () = Html5.register ~service:election_setup_pre
+  (fun () () -> T.election_setup_pre ())
+
 let () = Redirection.register ~service:election_setup_new
-  (fun () () ->
+  (fun () (credmgmt, (auth, cas_server)) ->
    match_lwt Web_auth_state.get_site_user () with
    | Some u ->
-      let uuid = generate_uuid () in
-      let uuid_s = Uuidm.to_string uuid in
-      lwt token = generate_token () in
-      let se_metadata = {
-        e_owner = Some u;
-        e_auth_config = Some [{auth_system = "password"; auth_instance = "password"; auth_config = []}];
-        e_cred_authority = None;
-      } in
-      let question = {
-        q_answers = [| "Answer 1"; "Answer 2"; "Blank" |];
-        q_min = 1;
-        q_max = 1;
-        q_question = "Question 1?";
-      } in
-      let se_questions = {
-        t_description = "Description of the election.";
-        t_name = "Name of the election";
-        t_questions = [| question |];
-        t_short_name = "short_name";
-      } in
-      let se = {
-        se_owner = u;
-        se_group = "{\"g\":\"14887492224963187634282421537186040801304008017743492304481737382571933937568724473847106029915040150784031882206090286938661464458896494215273989547889201144857352611058572236578734319505128042602372864570426550855201448111746579871811249114781674309062693442442368697449970648232621880001709535143047913661432883287150003429802392229361583608686643243349727791976247247948618930423866180410558458272606627111270040091203073580238905303994472202930783207472394578498507764703191288249547659899997131166130259700604433891232298182348403175947450284433411265966789131024573629546048637848902243503970966798589660808533\",\"p\":\"16328632084933010002384055033805457329601614771185955389739167309086214800406465799038583634953752941675645562182498120750264980492381375579367675648771293800310370964745767014243638518442553823973482995267304044326777047662957480269391322789378384619428596446446984694306187644767462460965622580087564339212631775817895958409016676398975671266179637898557687317076177218843233150695157881061257053019133078545928983562221396313169622475509818442661047018436264806901023966236718367204710755935899013750306107738002364137917426595737403871114187750804346564731250609196846638183903982387884578266136503697493474682071\",\"q\":\"61329566248342901292543872769978950870633559608669337131139375508370458778917\"}";
-        se_voters = [];
-        se_questions;
-        se_public_keys = [];
-        se_metadata;
-        se_public_creds = token;
-      } in
-      lwt () = Ocsipersist.add election_stable uuid_s se in
-      lwt () = Ocsipersist.add election_credtokens token uuid_s in
-      return (preapply election_setup uuid)
-  | None -> forbidden ()
-  )
+      lwt credmgmt = match credmgmt with
+        | Some "auto" -> return `Automatic
+        | Some "manual" -> return `Manual
+        | _ -> fail_http 400
+      in
+      lwt auth = match auth with
+        | Some "password" -> return `Password
+        | Some "dummy" -> return `Dummy
+        | Some "cas" -> return @@ `CAS cas_server
+        | _ -> fail_http 400
+      in
+      create_new_election u credmgmt auth
+   | None -> forbidden ())
 
 let generic_setup_page f uuid () =
   match_lwt Web_auth_state.get_site_user () with

src/web/web_templates.ml

@@ -195,13 +195,6 @@ let admin ~elections () =
      lwt login_box = site_login_box () in
      base ~title ~login_box ~content ()
   | Some (elections, tallied, setup_elections) ->
-    let setup_form = post_form ~service:election_setup_new
-      (fun () ->
-       [
-         div [string_input ~a:[a_style "font-size:24px;"] ~input_type:`Submit ~value:"Prepare a new election" ()]
-       ]
-      ) ()
-    in
     let elections =
       match elections with
       | [] -> p [pcdata "You own no such elections!"]
@@ -222,7 +215,11 @@ let admin ~elections () =
     in
     let content = [
       div [
-        div [setup_form];
+        div [
+          a ~service:election_setup_pre [
+            pcdata "Prepare a new election";
+          ] ();
+        ];
         div [br ()];
         h2 [pcdata "Elections being prepared"];
         setup_elections;
@@ -269,6 +266,53 @@ let generic_page ~title message () =
   let login_box = pcdata "" in
   base ~title ~login_box ~content ()
 
+let election_setup_pre () =
+  let title = "Prepare a new election" in
+  let form =
+    post_form ~service:election_setup_new
+      (fun (credmgmt, (auth, cas_server)) ->
+        [
+          fieldset
+            ~legend:(legend [pcdata "Credential management"])
+            [
+              div [
+                string_radio ~checked:true ~name:credmgmt ~value:"auto" ();
+                pcdata " Automatic (degraded mode)";
+              ];
+              div [
+                string_radio ~name:credmgmt ~value:"manual" ();
+                pcdata " Manual (safe mode)";
+              ];
+            ];
+          fieldset
+            ~legend:(legend [pcdata "Authentication"])
+            [
+              div [
+                string_radio ~checked:true ~name:auth ~value:"password" ();
+                pcdata " Password (passwords will be emailed to voters)";
+              ];
+              div [
+                string_radio ~name:auth ~value:"dummy" ();
+                pcdata " Dummy (typically for a test election)";
+              ];
+              div [
+                string_radio ~name:auth ~value:"cas" ();
+                pcdata " CAS (external authentication server), server address: ";
+                string_input ~input_type:`Text ~name:cas_server ();
+              ];
+            ];
+          div [
+            string_input ~input_type:`Submit ~value:"Proceed" ();
+          ];
+        ]
+      ) ()
+  in
+  let content = [
+    form
+  ] in
+  lwt login_box = site_login_box () in
+  base ~title ~login_box ~content ()
+
 let election_setup uuid se () =
   let title = "Preparation of election " ^ se.se_questions.t_name in
   let make_form ?a service value title =
@@ -324,73 +368,38 @@ let election_setup uuid se () =
       (Eliom_service.preapply election_setup_metadata uuid)
       value "Election metadata"
   in
-  let form_auth =
-    let checked_dummy, checked_password, checked_cas =
-      match se.se_metadata.e_auth_config with
-      | Some [x] ->
-         (match x.auth_system with
-         | "dummy" -> true, false, false
-         | "password" -> false, true, false
-         | "cas" -> false, false, true
-         | _ -> false, false, false)
-      | _ -> false, false, false
-    in
-    post_form ~service:election_setup_auth
-      (fun name ->
-        [
-          div [
-            string_radio ~checked:checked_password ~name ~value:"password" ();
-            pcdata "Password (passwords will be emailed to voters)";
-          ];
-          div [
-            string_radio ~checked:checked_dummy ~name ~value:"dummy" ();
-            pcdata "Dummy (typically for a test election)";
-          ];
-          div [
-            string_radio ~checked:checked_cas ~name ~value:"cas" ();
-            pcdata "CAS (external authentication server)";
-          ];
-          div [
-            string_input ~input_type:`Submit ~value:"Change authentication mode" ();
-          ];
-        ])
-      uuid
+  let has_credentials = match se.se_metadata.e_cred_authority with
+    | None -> false
+    | Some _ -> true
   in
-  let form_cas =
-    match se.se_metadata.e_auth_config with
-    | Some [x] ->
-       (match x.auth_system with
-       | "cas" ->
-          let value =
-            match x.auth_config with
-            | ["server", x] -> x
-            | _ -> ""
-          in
-          post_form ~service:election_setup_auth_cas
-            (fun name ->
-              [
-                div [
-                  pcdata "CAS server address: ";
-                  string_input ~name ~input_type:`Text ~a:[a_size 40] ~value ();
-                  string_input ~input_type:`Submit ~value:"Submit" ();
-                ]
-              ]) uuid
-       | _ -> pcdata "")
-    | _ -> pcdata ""
+  let auth = match se.se_metadata.e_auth_config with
+    | Some [{auth_system = "password"; _}] -> `Password
+    | Some [{auth_system = "dummy"; _}] -> `Dummy
+    | Some [{auth_system = "cas"; auth_config = ["server", server]; _}] -> `CAS server
+    | _ -> failwith "unknown authentication scheme in election_setup"
   in
-  let form_password =
-    match se.se_metadata.e_auth_config with
-    | Some [x] ->
-       (match x.auth_system with
-       | "password" ->
-          post_form ~service:election_setup_auth_genpwd
-            (fun () ->
-              [div [
-                string_input ~input_type:`Submit ~value:"Generate passwords" ()
-              ]]
-            ) uuid
-       | _ -> pcdata "")
-    | _ -> pcdata ""
+  let div_auth =
+    div [
+      h2 [pcdata "Authentication"];
+      match auth with
+      | `Password ->
+         post_form ~service:election_setup_auth_genpwd
+           (fun () ->
+             [div [
+               pcdata "Authentication scheme: password ";
+               string_input ~input_type:`Submit ~value:"Generate passwords" ()
+             ]]
+           ) uuid
+      | `Dummy ->
+         div [
+           pcdata "Authentication scheme: dummy"
+         ]
+      | `CAS server ->
+         div [
+           pcdata "Authentication scheme: CAS with server ";
+           pcdata server;
+         ]
+    ]
   in
   let div_questions =
     div [
@@ -429,15 +438,16 @@ let election_setup uuid se () =
   let div_credentials =
     div [
       h2 [pcdata "Credentials"];
-      div [
-        pcdata "The server may generate and email the credentials to the voters. If you prefer to delegate this task to another authority, click ";
-        a ~service:election_setup_credential_authority [pcdata "here"] uuid;
-        pcdata ".";
-      ];
-      post_form ~service:election_setup_credentials_server
-        (fun () ->
-          [string_input ~input_type:`Submit ~value:"Generate on server" ()]
-        ) uuid;
+      if has_credentials then (
+        post_form ~service:election_setup_credentials_server
+          (fun () ->
+            [string_input ~input_type:`Submit ~value:"Generate on server" ()]
+          ) uuid
+      ) else (
+        div [
+          a ~service:election_setup_credential_authority [pcdata "Credential management"] uuid;
+        ]
+      )
     ]
   in
   let form_create =
@@ -460,12 +470,7 @@ let election_setup uuid se () =
     hr ();
     form_group;
     form_metadata;
-    div [
-      h2 [pcdata "Authentication"];
-      form_auth;
-      form_cas;
-      form_password;
-    ];
+    div_auth;
     hr ();
     div_trustees;
     hr ();
@@ -524,8 +529,7 @@ let election_setup_credential_authority uuid se () =
   let title = "Credentials for election " ^ se.se_questions.t_name in
   let content = [
     div [
-      pcdata "If you wish the credentials to be generated and managed by ";
-      pcdata "an external authority, please send her the following link:";
+      pcdata "Please send the credential authority the following link:";
     ];
     ul [
       li [

src/web/web_templates.mli

@@ -28,6 +28,7 @@ val new_election_failure : [ `Exists | `Exception of exn ] -> unit -> [> `Html ]
 
 val generic_page : title:string -> string -> unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
 
+val election_setup_pre : unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
 val election_setup : Uuidm.t -> Web_common.setup_election -> unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
 val election_setup_voters : Uuidm.t -> Web_common.setup_election -> unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
 val election_setup_questions : Uuidm.t -> Web_common.setup_election -> unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t