Commit 794f02e4 authored by Stephane Glondu's avatar Stephane Glondu
Browse files

Cast/confirm

parent 744ae2a8
......@@ -115,21 +115,21 @@ let fail_http status =
let forbidden () = fail_http 403
let check_acl acl election user =
let open Web_common in
match acl election with
| Any -> return true
| Restricted p ->
match user with
| Some user -> p user
| None -> return false
let if_eligible acl f uuid x =
lwt election = get_election_by_uuid uuid in
let module X = (val election : Web_common.WEB_ELECTION) in
lwt user = Eliom_reference.get Services.user in
lwt () =
let open Web_common in
match acl X.data with
| Any -> return ()
| Restricted p ->
match user with
| Some user ->
lwt ok = p user in
if ok then return () else forbidden ()
| None -> forbidden ()
in f uuid election user x
lwt b = check_acl acl X.data user in
if b then f uuid election user x else forbidden ()
let () = Eliom_registration.Html5.register
~service:Services.home
......@@ -287,6 +287,7 @@ let () = Eliom_registration.Html5.register
~service:Services.election_index
(if_eligible can_read
(fun uuid election user () ->
Eliom_reference.set Services.saved_service (Services.Election uuid) >>
let module X = (val election : Web_common.WEB_ELECTION) in
Templates.election_view ~election:X.data ~user
)
......@@ -294,48 +295,73 @@ let () = Eliom_registration.Html5.register
let () = Eliom_registration.Redirection.register
~service:Services.election_vote
(if_eligible can_vote
(if_eligible can_read
(fun uuid election user () ->
Eliom_reference.set Services.saved_service (Services.Election uuid) >>
return (Services.make_booth uuid)
)
)
let () = Eliom_registration.Redirection.register
let do_cast election uuid () =
match_lwt Eliom_reference.get Services.ballot with
| Some ballot ->
begin
Eliom_reference.unset Services.ballot >>
let open Web_common in
let module X = (val election : WEB_ELECTION) in
match_lwt Eliom_reference.get Services.user with
| Some {user_type; user_name} as u ->
lwt b = check_acl can_vote X.data u in
if b then (
let t = string_of_user_type user_type in
let record =
Printf.sprintf "%s:%s" t user_name,
(CalendarLib.Fcalendar.Precise.now (), None)
in
lwt result =
try_lwt
X.B.cast ballot record >>
return (`Valid (sha256_b64 ballot))
with
| Serialization e -> return (`Malformed e)
| ProofCheck -> return `Invalid
in
Eliom_reference.unset Services.ballot >>
Templates.do_cast_ballot ~election:X.data ~result
) else forbidden ()
| None -> forbidden ()
end
| None -> fail_http 404
let ballot_received uuid election user =
let module X = (val election : Web_common.WEB_ELECTION) in
Eliom_reference.set Services.saved_service (Services.Cast uuid) >>
let confirm () =
let service = Services.create_confirm () in
let () = Eliom_registration.Html5.register
~service
~scope:Eliom_common.default_session_scope
(do_cast election)
in service
in
Templates.ballot_received ~election:X.data ~confirm ~user
let () = Eliom_registration.Html5.register
~service:Services.election_cast
(if_eligible can_vote
(if_eligible can_read
(fun uuid election user () ->
let module X = (val election : Web_common.WEB_ELECTION) in
return (
Services.(preapply_uuid election_index X.data)
)
match_lwt Eliom_reference.get Services.ballot with
| Some _ -> ballot_received uuid election user
| None -> fail_http 404
)
)
let () = Eliom_registration.Html5.register
~service:Services.election_cast_post
(if_eligible can_vote
(if_eligible can_read
(fun uuid election user ballot ->
let open Web_common in
let module X = (val election : WEB_ELECTION) in
match user with
| Some {user_type; user_name} ->
begin
let t = string_of_user_type user_type in
let record =
Printf.sprintf "%s:%s" t user_name,
(CalendarLib.Fcalendar.Precise.now (), None)
in
lwt result =
try_lwt
X.B.cast ballot record >>
return (`Valid (sha256_b64 ballot))
with
| Serialization e -> return (`Malformed e)
| ProofCheck -> return `Invalid
in
Templates.cast_ballot ~election:X.data ~result
end
| None ->
Templates.cast_ballot ~election:X.data ~result:`Anon
Eliom_reference.set Services.ballot (Some ballot) >>
ballot_received uuid election user
)
)
......@@ -60,6 +60,10 @@ let user = Eliom_reference.eref
~scope:Eliom_common.default_session_scope
(None : Web_common.user option)
let ballot = Eliom_reference.eref
~scope:Eliom_common.default_session_scope
(None : string option)
let uuid = Eliom_parameter.user_type
(fun x -> match Uuidm.of_string x with
| Some x -> x
......@@ -109,6 +113,14 @@ let election_cast_post = post_service
~post_params:(string "encrypted_vote")
()
let create_confirm () =
Eliom_service.post_coservice
~csrf_safe:true
~csrf_scope:Eliom_common.default_session_scope
~fallback:election_cast
~post_params:Eliom_parameter.unit
()
let get_randomness = service
~path:["get-randomness"]
~get_params:unit
......@@ -129,6 +141,8 @@ let preapply_uuid s e = Eliom_service.preapply s e.Web_common.election.e_uuid
type savable_service =
| Home
| Cast of Uuidm.t
| Election of Uuidm.t
let saved_service = Eliom_reference.eref
~scope:Eliom_common.default_session_scope
......@@ -136,6 +150,8 @@ let saved_service = Eliom_reference.eref
let to_service = function
| Home -> home
| Cast u -> Eliom_service.preapply election_cast u
| Election u -> Eliom_service.preapply election_index u
open Lwt
......
......@@ -150,7 +150,6 @@ let dummy_login ~service =
let election_view ~election ~user =
let service = Services.(preapply_uuid election_raw election) in
let booth = Services.make_booth election.Web_common.election.e_uuid in
lwt permissions =
let open Web_common in
match election.can_vote with
......@@ -191,9 +190,6 @@ let election_view ~election ~user =
] ();
pcdata ".";
];
div [
a ~service:booth [ pcdata "Voting booth" ] ();
];
]
] in
let content = [
......@@ -210,19 +206,54 @@ let election_view ~election ~user =
] in
base ~title:election.Web_common.election.e_name ~content
let cast_ballot ~election ~result =
let ballot_received ~election ~confirm ~user =
let name = election.Web_common.election.e_name in
let user_div = match user with
| Some u ->
let service = confirm () in
post_form ~service (fun () -> [
div [
pcdata "I am ";
format_user u;
pcdata " and ";
string_input ~input_type:`Submit ~value:"I confirm my vote" ();
pcdata ".";
]
]) election.Web_common.election.e_uuid
| None ->
div [
pcdata "Please log in to confirm your vote.";
]
in
let content = [
h1 [ pcdata name ];
div [
p [
pcdata "Your ballot for ";
em [pcdata name];
pcdata " has been received, but not recorded yet.";
];
user_div;
] in
base ~title:name ~content
let do_cast_ballot ~election ~result =
let name = election.Web_common.election.e_name in
let content = [
h1 [ pcdata name ];
p [
pcdata "Your ballot for ";
em [pcdata name];
(match result with
| `Valid hash -> pcdata (" has been accepted, its hash is " ^ hash ^ ".")
| `Invalid -> pcdata " is invalid!"
| `Malformed e -> Printf.ksprintf pcdata " is malformed! (%s)" (Printexc.to_string e)
| `Anon -> pcdata " cannot be accepted, you must log in first!"
);
]
];
div [
a ~service:(Services.(preapply_uuid election_index election)) [
pcdata "Go back to election"
] ();
pcdata ".";
];
] in
base ~title:name ~content
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