Commit ce9691fb authored by Stephane Glondu's avatar Stephane Glondu

Add an election creation service

parent b3ad3752
......@@ -91,6 +91,31 @@ module type CORE_SERVICES = sig
[< Eliom_service.registrable > `Registrable ], 'a)
Eliom_service.service
val new_election :
(unit, unit,
[> `Attached of
([> `Internal of [> `Service ] ], [> `Get ])
Eliom_service.a_s ],
[ `WithoutSuffix ], unit, unit,
[< Eliom_service.registrable > `Registrable ], 'a)
Eliom_service.service
val new_election_post :
(unit,
Eliom_lib.file_info *
(Eliom_lib.file_info *
(Eliom_lib.file_info * Eliom_lib.file_info)),
[> `Attached of
([> `Internal of [ `Coservice | `Service ] ], [> `Post ])
Eliom_service.a_s ],
[ `WithoutSuffix ], unit,
[ `One of Eliom_lib.file_info ] Eliom_parameter.param_name *
([ `One of Eliom_lib.file_info ] Eliom_parameter.param_name *
([ `One of Eliom_lib.file_info ] Eliom_parameter.param_name *
[ `One of Eliom_lib.file_info ] Eliom_parameter.param_name)),
[< Eliom_service.registrable > `Registrable ], 'a)
Eliom_service.service
end
module type ELECTION_SERVICES = sig
......@@ -345,6 +370,13 @@ module type TEMPLATES = sig
elections:(module WEB_ELECTION_RO) list ->
unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
val new_election :
unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
val new_election_failure :
[ `Exists | `Exception of exn ] ->
unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
module Login (S : AUTH_SERVICES) : LOGIN_TEMPLATES
module Election (W : WEB_ELECTION_RO) : ELECTION_TEMPLATES
......
......@@ -116,6 +116,18 @@ module Make (C : CONFIG) : SITE = struct
~get_params:unit
()
let new_election = service
~path:(make_path ["new-election"])
~get_params:unit
()
let new_election_post = post_service
~fallback:new_election
~post_params:(
file "election" ** file "metadata"
** file "public_keys" ** file "public_creds"
) ()
let cont = Eliom_reference.eref ~scope
(fun () () -> Eliom_registration.Redirection.send home)
......@@ -350,4 +362,38 @@ module Make (C : CONFIG) : SITE = struct
(fun x -> return (x, "application/json"))
)
let () = Html5.register ~service:new_election
(fun () () ->
match_lwt S.get_user () with
| None -> forbidden ()
| Some _ -> T.new_election ()
)
let () = Any.register ~service:new_election_post
(fun () (election, (metadata, (public_keys, public_creds))) ->
match_lwt S.get_user () with
| Some u ->
let open Ocsigen_extensions in
let files = {
f_election = election.tmp_filename;
f_metadata = metadata.tmp_filename;
f_public_keys = public_keys.tmp_filename;
f_public_creds = public_creds.tmp_filename;
} in
begin try_lwt
begin match_lwt S.import_election files with
| None ->
T.new_election_failure `Exists () >>= Html5.send
| Some w ->
let module W = (val w : REGISTRABLE_ELECTION) in
lwt w = W.register () in
let module W = (val w : WEB_ELECTION) in
W.S.admin |> Redirection.send
end
with e ->
T.new_election_failure (`Exception e) () >>= Html5.send
end
| None -> forbidden ()
)
end
......@@ -149,6 +149,7 @@ module Make (S : SITE_SERVICES) : TEMPLATES = struct
let content = [
h1 [pcdata title];
div [
a ~service:S.new_election [pcdata "Create a new election"] ();
h2 [pcdata "Elections you can administer"];
elections;
];
......@@ -264,6 +265,58 @@ module Make (S : SITE_SERVICES) : TEMPLATES = struct
uri
contents
let new_election () =
let title = "Create new election" in
lwt body =
let form = post_form ~service:S.new_election_post
(fun (election, (metadata, (public_keys, public_creds))) ->
[
div [
pcdata "Public election parameters: ";
file_input ~name:election ();
];
div [
pcdata "Optional metadata: ";
file_input ~name:metadata ()
];
div [
pcdata "Trustee public keys: ";
file_input ~name:public_keys ()
];
div [
pcdata "Public credentials: ";
file_input ~name:public_creds ()
];
div [string_input ~input_type:`Submit ~value:"Submit" ()];
]
) ()
in return [form]
in
let content = [
h1 [pcdata title];
div body;
] in
lwt login_box = site_login_box () in
base ~title ~login_box ~content
let new_election_failure reason () =
let title = "Create new election" in
let reason =
match reason with
| `Exists -> pcdata "An election with the same UUID already exists."
| `Exception e -> pcdata @@ Printexc.to_string e
in
let content = [
h1 [pcdata title];
div [
p [pcdata "The creation failed."];
p [reason];
p [a ~service:S.new_election [pcdata "Try again"] ()];
]
] in
lwt login_box = site_login_box () in
base ~title ~login_box ~content
module Election (W : WEB_ELECTION_RO) = struct
let election_login_box =
......
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