From 4c3672d4f4e6d29a638fdf530884353c27130415 Mon Sep 17 00:00:00 2001 From: Maxime Lalisse Date: Fri, 20 Oct 2023 13:38:55 +0200 Subject: [PATCH] Allow to import and export elections --- src/web/clients/admin/account.ml | 35 +++++++++++ src/web/clients/admin/common.ml | 14 +++++ src/web/clients/admin/common.mli | 3 + src/web/clients/admin/elections.ml | 93 +++++++++++++++++++++++++----- 4 files changed, 129 insertions(+), 16 deletions(-) diff --git a/src/web/clients/admin/account.ml b/src/web/clients/admin/account.ml index 51ad33c6..b3a7957c 100644 --- a/src/web/clients/admin/account.ml +++ b/src/web/clients/admin/account.ml @@ -25,6 +25,8 @@ open Js_of_ocaml_tyxml open Tyxml_js.Html5 open Belenios_core.Common open Belenios_js.Common +open Belenios_js.Session +open Belenios_api.Serializable_j open Common let rec update_main_zone () = @@ -71,6 +73,38 @@ let rec update_main_zone () = update_main ()); select in + let import_election = + let open Tyxml_js.Html in + let file_elt = input ~a:[ a_input_type `File ] () in + let file_dom = Tyxml_js.To_dom.of_input file_elt in + let upload_button = + Belenios_js.Common.button (s_ "Import election") (fun () -> + let files = file_dom##.files in + let files = Js.Optdef.get files (fun () -> assert false) in + if files##.length = 0 then + Lwt.return_unit + else + let file = files##item 0 in + let file = Js.Opt.get file (fun () -> assert false) in + let* text = Common.read_full file in + let text = Js.to_string text in + let* x = post_with_token text "drafts" + |> wrap uuid_of_string + in + match x with + | Ok uuid -> + where_am_i := Election { uuid; status = Draft; tab = Title }; + Dom_html.window##.location##.hash + := Js.string (Uuid.unwrap uuid); + Lwt.return_unit + | Error e -> + alert ("Creation failed: " + ^ Belenios_js.Session.(string_of_error e)); + Lwt.return_unit + ) + in + div [ file_elt; upload_button ]; + in let content = [ h2 [ txt @@ s_ "Administrator's profile: " ]; @@ -92,6 +126,7 @@ let rec update_main_zone () = input_language; ]; ]; + import_election; ] in let&&* container = document##getElementById (Js.string "main_zone") in diff --git a/src/web/clients/admin/common.ml b/src/web/clients/admin/common.ml index c0832a5d..1d04f285 100644 --- a/src/web/clients/admin/common.ml +++ b/src/web/clients/admin/common.ml @@ -47,6 +47,7 @@ type tab = | ElectionPage | CreateOpenClose | Tally + | Export | Destroy type status = Draft | Running | Tallied | Archived @@ -96,3 +97,16 @@ let url_prefix () = | Some pr -> pr) let default_version = Belenios.Election.(Version V1) + +let read_full file = + let t, u = Lwt.task () in + let reader = new%js File.fileReader in + reader##.onload := + Dom.handler (fun _ -> + let () = + let$ text = File.CoerceTo.string reader##.result in + Lwt.wakeup_later u text + in + Js._false); + reader##readAsText file; + t diff --git a/src/web/clients/admin/common.mli b/src/web/clients/admin/common.mli index dc5d01e0..6963255e 100644 --- a/src/web/clients/admin/common.mli +++ b/src/web/clients/admin/common.mli @@ -19,6 +19,7 @@ (* . *) (**************************************************************************) +open Js_of_ocaml open Belenios_core.Common (** Session management *) @@ -40,6 +41,7 @@ type tab = | ElectionPage | CreateOpenClose | Tally + | Export | Destroy type status = Draft | Running | Tallied | Archived @@ -63,3 +65,4 @@ val is_finished : unit -> bool val popup_failsync : string -> unit Lwt.t val url_prefix : unit -> string val default_version : Belenios.Election.some_version +val read_full : #File.blob Js.t -> Js.js_string Js.t Lwt.t diff --git a/src/web/clients/admin/elections.ml b/src/web/clients/admin/elections.ml index 4cc27b54..1a992f33 100644 --- a/src/web/clients/admin/elections.ml +++ b/src/web/clients/admin/elections.ml @@ -21,7 +21,6 @@ open Lwt.Syntax open Js_of_ocaml -open Js_of_ocaml_lwt open Js_of_ocaml_tyxml open Belenios_core.Common open Belenios_api.Serializable_j @@ -37,19 +36,6 @@ open Common *) let ( let^ ) x f = Js.Optdef.case x (fun () -> Lwt.return_unit) f -let read_full file = - let t, u = Lwt.task () in - let reader = new%js File.fileReader in - reader##.onload := - Dom.handler (fun _ -> - let () = - let$ text = File.CoerceTo.string reader##.result in - Lwt.wakeup_later u text - in - Js._false); - reader##readAsText file; - t - (* FIXME: get timezone offset from browser *) let datestring_of_float x = let x = new%js Js.date_fromTimeValue (x *. 1000.) in @@ -204,7 +190,7 @@ let default_handler tab () = * and associated to them is the following data * - string to print in the menu (internationalized) * - function to decide its status (done, doing, todo...) - * - function to decide its availability (clicable ?) + * - function to decide its availability (clickable ?) * - function to compute the onclick handler (or directly the handler?) *) @@ -466,6 +452,11 @@ let tabs x = | _ -> alert ("Failed with error code " ^ string_of_int x.code); Lwt.return_unit ) + | Export -> + ( s_ "Export the election", + (fun () -> Lwt.return `None), + (fun () -> Lwt.return true), + default_handler x ) | Destroy -> ( s_ "Delete the election", (fun () -> Lwt.return `None), @@ -580,8 +571,9 @@ let tab_manage () = let* tab_electionpage = subtab_elt ElectionPage () in let* tab_create = subtab_elt CreateOpenClose () in let* tab_tally = subtab_elt Tally () in + let* tab_export = subtab_elt Export () in let* tab_destroy = subtab_elt Destroy () in - let elt = [ tab_electionpage; tab_create; tab_tally; tab_destroy ] in + let elt = [ tab_electionpage; tab_create; tab_tally; tab_export; tab_destroy ] in Lwt.return (title :: flatten_with_sep @@ -1612,6 +1604,74 @@ let result_archived_content () = but; ] +let draft_of_params (Belenios.Election.Template (V1, params)) = + let* x = Cache.get Cache.config in + let* configuration_opt = + match x with + | Error e -> + alert ("Failed to retrieve server config: " ^ e); + Lwt.return None + | Ok c -> Lwt.return @@ Some c + in + let* account_opt = + let* x = get api_account_of_string "account" in + match x with + | Error e -> + alert ("Failed to retrieve account info: " ^ string_of_error e); + Lwt.return None + | Ok (c, _) -> Lwt.return @@ Some c + in + let owners = + match (account_opt) with + | Some a -> [ a.id ] + | None -> [] + in + let contact = + match (account_opt) with + | Some a -> (Printf.sprintf "%s <%s>" a.name a.address); + | None -> Option.get(params.t_administrator) + in + let draft_group = (Option.get configuration_opt).default_group in + let questions = + { + t_description = params.t_description; + t_name = params.t_name; + t_questions = params.t_questions; + t_administrator = params.t_administrator; + t_credential_authority = params.t_credential_authority; + } + in + Lwt.return (Belenios_api.Common.Draft (V1, { + draft_version = 1; + draft_questions = questions; + draft_owners = owners; + draft_languages = [ "en"; "fr" ]; + draft_booth = 1; + draft_group; + draft_authentication = `Password; + draft_contact = Some(contact) + })) + +let export_content () = + let open (val !Belenios_js.I18n.gettext) in + let* draft = if is_draft () then ( + let* draft = Cache.get_until_success Cache.draft in + Lwt.return draft + ) else ( + let* election = Cache.get_until_success Cache.e_elec in + let* draft = (draft_of_params election) in + Lwt.return draft + ) in + let button_text = s_ "Click here to export the election" in + let encoded_data = Js.encodeURIComponent (Js.string @@ Belenios_api.Common.string_of_draft draft) in + let href = "data:text/json;charset=utf-8," ^ (Js.to_string encoded_data) in + let uuid = get_current_uuid () in + let link = a ~a:[ (a_target "_download_election"); (a_download (Some(uuid ^ ".json"))) ] ~href button_text in + Lwt.return + [ + link; + ] + let update_main_zone () = let&&* container = document##getElementById (Js.string "main_zone") in let* content = @@ -1628,6 +1688,7 @@ let update_main_zone () = | Election { tab = ElectionPage; _ } -> result_archived_content () | Election { tab = CreateOpenClose; _ } -> if is_draft () then create_content () else open_close_content () + | Election { tab = Export; _ } -> export_content () | _ -> Lwt.return [ txt "Error: should never print this" ] in show_in container (fun () -> Lwt.return content)