Add Tool_js_tkeygen

_tags

@@ -2,5 +2,5 @@
 <src/platform/native/*>: package(zarith), package(calendar), package(cryptokit)
 <src/web/*.{ml,mli,byte,native,odoc}>: thread, package(eliom.server), syntax(camlp4o), package(lwt.syntax), package(csv)
 <src/tool/tool_cmdline.*>: package(zarith), package(calendar), package(cryptokit), package(cmdliner), use_platform-native
-<src/tool/tool_js.*> or <src/platform/js/*> or <src/booth/*>: package(js_of_ocaml), syntax(camlp4o), package(js_of_ocaml.syntax), use_platform-js
+<src/tool/tool_js*> or <src/platform/js/*> or <src/booth/*>: package(js_of_ocaml), syntax(camlp4o), package(js_of_ocaml.syntax), use_platform-js
 <src/booth/*>: package(lwt.syntax)

all.itarget

@@ -3,3 +3,4 @@ src/lib/lib.cma
 src/web/server.cma
 src/static/belenios-tool.html.otarget
 src/static/vote.html.otarget
+src/static/tool_js_tkeygen.js

myocamlbuild.ml

@@ -116,4 +116,6 @@ let () = dispatch & function
     copy_rule "booth.js" "src/booth/booth.js" "src/static/booth.js";
     copy_rule "vote.html" "src/booth/vote.html" "src/static/vote.html";
 
+    copy_rule "tool_js_tkeygen.js" "src/tool/tool_js_tkeygen.js" "src/static/tool_js_tkeygen.js";
+
   | _ -> ()

src/tool/tool_js_tkeygen.ml

+(**************************************************************************)
+(*                                BELENIOS                                *)
+(*                                                                        *)
+(*  Copyright © 2012-2014 Inria                                           *)
+(*                                                                        *)
+(*  This program is free software: you can redistribute it and/or modify  *)
+(*  it under the terms of the GNU Affero General Public License as        *)
+(*  published by the Free Software Foundation, either version 3 of the    *)
+(*  License, or (at your option) any later version, with the additional   *)
+(*  exemption that compiling, linking, and/or using OpenSSL is allowed.   *)
+(*                                                                        *)
+(*  This program is distributed in the hope that it will be useful, but   *)
+(*  WITHOUT ANY WARRANTY; without even the implied warranty of            *)
+(*  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU     *)
+(*  Affero General Public License for more details.                       *)
+(*                                                                        *)
+(*  You should have received a copy of the GNU Affero General Public      *)
+(*  License along with this program.  If not, see                         *)
+(*  <http://www.gnu.org/licenses/>.                                       *)
+(**************************************************************************)
+
+open Platform
+open Serializable_j
+
+let document = Dom_html.window##document
+
+let alert s : unit =
+  let open Js.Unsafe in
+  fun_call (variable "alert") [| s |> Js.string |> inject |]
+
+let get_textarea id =
+  let res = ref None in
+  Js.Opt.iter
+    (document##getElementById (Js.string id))
+    (fun e ->
+      Js.Opt.iter
+        (Dom_html.CoerceTo.textarea e)
+        (fun x -> res := Some (Js.to_string (x##value)))
+    );
+  match !res with
+  | None -> raise Not_found
+  | Some x -> x
+
+let set_textarea id z =
+  Js.Opt.iter
+    (document##getElementById (Js.string id))
+    (fun e ->
+      Js.Opt.iter
+        (Dom_html.CoerceTo.textarea e)
+        (fun x -> x##value <- Js.string z)
+    )
+
+open Tool_tkeygen
+
+let tkeygen _ =
+  let module P : PARAMS = struct
+    let group = get_textarea "group"
+  end in
+  let module X = (val make (module P : PARAMS) : S) in
+  let open X in
+  let {id; priv; pub} = trustee_keygen () in
+  let data_uri = (Js.string "data:application/json,")##concat (Js.encodeURI (Js.string priv)) in
+  ignore (Dom_html.window##open_ (data_uri, Js.string id, Js.null));
+  set_textarea "pk" pub;
+  alert "The private key has been open in a new window (or tab). Please save it before submitting the public key!";
+  Js._false
+
+let fill_interactivity _ =
+  Js.Opt.iter
+    (document##getElementById (Js.string "interactivity"))
+    (fun e ->
+     let b = document##createElement (Js.string "button") in
+     let t = document##createTextNode (Js.string "Generate a new keypair") in
+     b##onclick <- Dom_html.handler tkeygen;
+     Dom.appendChild b t;
+     Dom.appendChild e b;
+    );
+  Js._false
+
+let () =
+  Dom_html.window##onload <- Dom_html.handler fill_interactivity;

src/web/web_templates.ml

@@ -491,14 +491,37 @@ let make_login_box style auth links =
          [
            div [
              div [pcdata "Public key:"];
-             div [textarea ~a:[a_rows 5; a_cols 40] ~name ~value ()];
+             div [textarea ~a:[a_rows 5; a_cols 40; a_id "pk"] ~name ~value ()];
              div [string_input ~input_type:`Submit ~value:"Submit" ()];
            ]
          ]
         ) ()
     in
+    let group =
+      let name : 'a Eliom_parameter.param_name = Obj.magic "group" in
+      let value = se.se_group in
+      div
+        ~a:[a_style "display:none;"]
+        [
+          div [pcdata "Group parameters:"];
+          div [textarea ~a:[a_id "group"; a_rows 5; a_cols 40; a_readonly `ReadOnly] ~name ~value ()];
+        ]
+    in
+    let interactivity =
+      div
+        ~a:[a_id "interactivity"]
+        [
+          script ~a:[a_src (uri_of_string (fun () -> "../static/sjcl.js"))] (pcdata "");
+          script ~a:[a_src (uri_of_string (fun () -> "../static/jsbn.js"))] (pcdata "");
+          script ~a:[a_src (uri_of_string (fun () -> "../static/jsbn2.js"))] (pcdata "");
+          script ~a:[a_src (uri_of_string (fun () -> "../static/random.js"))] (pcdata "");
+          script ~a:[a_src (uri_of_string (fun () -> "../static/tool_js_tkeygen.js"))] (pcdata "");
+        ]
+    in
     let content = [
       h1 [pcdata title];
+      group;
+      interactivity;
       form;
     ] in
     let login_box = pcdata "" in