Commit 4e63aa8b authored by Stephane Glondu's avatar Stephane Glondu
Browse files

Add a pretty list of accepted ballots

parent 944f0679
...@@ -479,6 +479,35 @@ module Make (D : ELECTION_DATA) (P : WEB_PARAMS) : REGISTRABLE = struct ...@@ -479,6 +479,35 @@ module Make (D : ELECTION_DATA) (P : WEB_PARAMS) : REGISTRABLE = struct
) )
) )
let election_pretty_ballots start () =
lwt user = W.S.get_user () in
if can_read W.metadata user then (
lwt res, _ =
W.B.Ballots.fold
(fun h _ (accu, i) ->
if i >= start && i < start+50 then
return (h :: accu, i+1)
else return (accu, i+1)
) ([], 1)
in T.pretty_ballots (module W) res () >>= Html5.send
) else forbidden ()
let election_pretty_ballot hash () =
lwt user = W.S.get_user () in
if can_read W.metadata user then (
lwt ballot =
W.B.Ballots.fold
(fun h b accu ->
if h = hash then return (Some b) else return accu
) None
in
match ballot with
| None -> fail_http 404
| Some b ->
String.send (b, "application/json") >>=
(fun x -> return @@ cast_unknown_content_kind x)
) else forbidden ()
end end
end end
......
...@@ -64,6 +64,8 @@ let election_vote = service ~path:["elections"] ~get_params:(suffix (uuid "uuid" ...@@ -64,6 +64,8 @@ let election_vote = service ~path:["elections"] ~get_params:(suffix (uuid "uuid"
let election_cast = service ~path:["elections"] ~get_params:(suffix (uuid "uuid" ** suffix_const "cast")) () let election_cast = service ~path:["elections"] ~get_params:(suffix (uuid "uuid" ** suffix_const "cast")) ()
let election_cast_post = post_service ~fallback:election_cast ~post_params:(opt (string "encrypted_vote") ** opt (file "encrypted_vote_file")) () let election_cast_post = post_service ~fallback:election_cast ~post_params:(opt (string "encrypted_vote") ** opt (file "encrypted_vote_file")) ()
let election_cast_confirm = post_coservice ~csrf_safe:true ~fallback:election_cast ~post_params:unit () let election_cast_confirm = post_coservice ~csrf_safe:true ~fallback:election_cast ~post_params:unit ()
let election_pretty_ballots = service ~path:["elections"] ~get_params:(suffix_prod (uuid "uuid" ** suffix_const "ballots") (int "start")) ()
let election_pretty_ballot = service ~path:["elections"] ~get_params:(suffix_prod (uuid "uuid" ** suffix_const "ballot") (string "hash")) ()
let election_dir = service ~path:["elections"] ~get_params:(suffix (uuid "uuid" ** election_file "file")) () let election_dir = service ~path:["elections"] ~get_params:(suffix (uuid "uuid" ** election_file "file")) ()
let scope = Eliom_common.default_session_scope let scope = Eliom_common.default_session_scope
......
...@@ -76,6 +76,8 @@ module type ELECTION_HANDLERS = ...@@ -76,6 +76,8 @@ module type ELECTION_HANDLERS =
val election_cast_post : val election_cast_post :
unit -> string option * Eliom_lib.file_info option -> content unit -> string option * Eliom_lib.file_info option -> content
val election_cast_confirm : unit -> unit -> content val election_cast_confirm : unit -> unit -> content
val election_pretty_ballots : int -> unit -> content
val election_pretty_ballot : string -> unit -> content
end end
module type AUTH_HANDLERS_RAW = module type AUTH_HANDLERS_RAW =
......
...@@ -820,6 +820,24 @@ let delete_shallow_directory dir = ...@@ -820,6 +820,24 @@ let delete_shallow_directory dir =
let module W = (val w : WEB_ELECTION) in let module W = (val w : WEB_ELECTION) in
W.Z.election_cast_confirm () x) W.Z.election_cast_confirm () x)
let () =
Any.register
~service:election_pretty_ballots
(fun ((uuid, ()), start) () ->
let uuid_s = Uuidm.to_string uuid in
let w = SMap.find uuid_s !election_table in
let module W = (val w : WEB_ELECTION) in
W.Z.election_pretty_ballots start ())
let () =
Any.register
~service:election_pretty_ballot
(fun ((uuid, ()), hash) () ->
let uuid_s = Uuidm.to_string uuid in
let w = SMap.find uuid_s !election_table in
let module W = (val w : WEB_ELECTION) in
W.Z.election_pretty_ballot hash ())
let () = let () =
Any.register Any.register
~service:election_dir ~service:election_dir
......
...@@ -585,6 +585,13 @@ let make_login_box style auth links = ...@@ -585,6 +585,13 @@ let make_login_box style auth links =
pcdata "."; pcdata ".";
] ]
in in
let ballots_link =
p [
a ~service:election_pretty_ballots [
pcdata "List of accepted ballots"
] ((params.e_uuid, ()), 1)
]
in
let audit_info = div [ let audit_info = div [
h3 [pcdata "Audit Info"]; h3 [pcdata "Audit Info"];
div [ div [
...@@ -631,6 +638,7 @@ let make_login_box style auth links = ...@@ -631,6 +638,7 @@ let make_login_box style auth links =
"Submit a raw ballot"; "Submit a raw ballot";
]; ];
]; ];
ballots_link;
br (); br ();
audit_info; audit_info;
] in ] in
...@@ -815,3 +823,33 @@ let make_login_box style auth links = ...@@ -815,3 +823,33 @@ let make_login_box style auth links =
lwt login_box = election_login_box w () in lwt login_box = election_login_box w () in
base ~title:name ~login_box ~content base ~title:name ~login_box ~content
let pretty_ballots w hashes () =
let module W = (val w : WEB_ELECTION_) in
let params = W.election.e_params in
let title = params.e_name ^ " — Accepted ballots" in
let nballots = ref 0 in
let ballots =
List.rev_map
(fun h ->
incr nballots;
li
[a
~service:election_pretty_ballot
[pcdata h]
((params.e_uuid, ()), h)]
) hashes
in
let links =
p
[a
~service:Web_services.election_home
[pcdata "Back to election"]
(params.e_uuid, ())]
in
let content = [
h1 [pcdata title];
ul ballots;
links;
] in
lwt login_box = election_login_box w () in
base ~title ~login_box ~content
...@@ -40,5 +40,6 @@ val update_credential : (module WEB_ELECTION_) -> unit -> [> `Html ] Eliom_conte ...@@ -40,5 +40,6 @@ val update_credential : (module WEB_ELECTION_) -> unit -> [> `Html ] Eliom_conte
val cast_raw : (module WEB_ELECTION_) -> unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t val cast_raw : (module WEB_ELECTION_) -> unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
val cast_confirmation : (module WEB_ELECTION_) -> can_vote:bool -> unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t val cast_confirmation : (module WEB_ELECTION_) -> can_vote:bool -> unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
val cast_confirmed : (module WEB_ELECTION_) -> result:[< `Error of Web_common.error | `Valid of string ] -> unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t val cast_confirmed : (module WEB_ELECTION_) -> result:[< `Error of Web_common.error | `Valid of string ] -> unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
val pretty_ballots : (module WEB_ELECTION_) -> string list -> unit -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
module Login (S : AUTH_SERVICES) (L : AUTH_LINKS) : LOGIN_TEMPLATES module Login (S : AUTH_SERVICES) (L : AUTH_LINKS) : LOGIN_TEMPLATES
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