Skip to content

GitLab

Commit 261865eb authored by Stephane Glondu's avatar Stephane Glondu
Browse files

Simplification of the web_election type 

Now, everything needed by the web server to handle an election is
bundled into a module of type WEB_ELECTION which is passed around
everywhere.
parent 789b20c1
Hide whitespace changes
Inline Side-by-side
Showing with 124 additions and 148 deletions
src/web/registration.ml
View file @ 261865eb
......@@ -167,35 +167,17 @@ lwt election_table =
return (SSet.add c accu)
)
in
let can_vote = match metadata.e_voters with
| None -> Any
| Some acls ->
let set = List.fold_left (fun accu u ->
AclSet.add u accu
) AclSet.empty acls in
Restricted (fun u ->
return (
AclSet.mem `Any set ||
AclSet.mem (`Domain u.user_domain) set ||
AclSet.mem (`User u) set
)
)
let featured_p = true in
let election = Web_election.make_web_election
raw_election metadata
~featured_p
~params_fname
~public_keys_fname
in
let election_web = Web_election.({
params_fname;
public_keys_fname;
featured_p = true;
can_read = Any;
can_vote;
}) in
let open Web_election in
let web_election = make_web_election
raw_election metadata election_web
in
let module X = (val web_election.modules : WEB_BALLOT_BOX_BUNDLE with type elt = Z.t) in
let module X = (val election : WEB_ELECTION) in
X.B.inject_creds public_creds >>
let uuid = web_election.election.e_params.e_uuid in
return (EMap.add uuid web_election accu)
let uuid = X.election.e_params.e_uuid in
return (EMap.add uuid election accu)
) else return accu
)
)
......@@ -208,30 +190,37 @@ let get_election_by_uuid x =
raise_lwt Eliom_common.Eliom_404
let get_featured_elections () =
let open Web_election in
EMap.fold (fun uuid e res ->
if e.election_web.featured_p then
e.election.e_params :: res
let module X = (val e : WEB_ELECTION) in
if X.featured_p then
e :: res
else res
) election_table [] |> return
let check_acl acl election user =
let open Web_election in
match acl election user with
| Any -> return true
| Restricted p ->
match user with
| Some user -> p user.user_user
| None -> return false
let if_eligible get_user acl f uuid x =
lwt election = get_election_by_uuid uuid in
let module X = (val election : WEB_ELECTION) in
lwt user = get_user () in
lwt b = check_acl acl election.election_web user in
if b then f uuid election user x else forbidden ()
let can_read x u = x.can_read
let can_vote x u = x.can_vote
if acl X.metadata user then
f uuid election user x
else
forbidden ()
let can_read m user =
match m.e_readers with
| None -> false
| Some acls ->
match user with
| None -> List.mem `Any acls (* readers can be anonymous *)
| Some u -> check_acl (Some acls) u.user_user
let can_vote m user =
match m.e_voters with
| None -> false
| Some acls ->
match user with
| None -> false (* voters must log in *)
| Some u -> check_acl (Some acls) u.user_user
module SAuth = Auth_common.Make (struct end)
......@@ -352,8 +341,7 @@ module SSite = struct
match user with
| Some u when u.user_admin ->
lwt election = get_election_by_uuid uuid in
let open Web_election in
let module X = (val election.modules : WEB_BALLOT_BOX_BUNDLE with type elt = Z.t) in
let module X = (val election : WEB_ELECTION) in
begin try_lwt
X.B.update_cred ~old ~new_ >>
return ("OK", "text/plain")
......@@ -404,14 +392,15 @@ module SElection = struct
open Eliom_registration
let f_raw uuid election user () =
return Web_election.(election.election_web.params_fname)
let module X = (val election : WEB_ELECTION) in
return X.params_fname
let f_keys uuid election user () =
return Web_election.(election.election_web.public_keys_fname)
let module X = (val election : WEB_ELECTION) in
return X.public_keys_fname
let f_creds uuid election user () =
let open Web_election in
let module X = (val election.modules : WEB_BALLOT_BOX_BUNDLE with type elt = Z.t) in
let module X = (val election : WEB_ELECTION) in
lwt creds = X.B.extract_creds () in
let s = SSet.fold (fun x accu ->
(fun () -> return (Ocsigen_stream.of_string (x^"\n"))) :: accu
......@@ -419,8 +408,7 @@ module SElection = struct
return (List.rev s, "text/plain")
let f_ballots uuid election user () =
let open Web_election in
let module X = (val election.modules : WEB_BALLOT_BOX_BUNDLE with type elt = Z.t) in
let module X = (val election : WEB_ELECTION) in
(* TODO: streaming *)
lwt ballots = X.B.Ballots.fold (fun _ x xs ->
return ((x^"\n")::xs)
......@@ -433,8 +421,7 @@ module SElection = struct
let f_records uuid election user () =
match user with
| Some u when u.user_admin ->
let open Web_election in
let module X = (val election.modules : WEB_BALLOT_BOX_BUNDLE with type elt = Z.t) in
let module X = (val election : WEB_ELECTION) in
(* TODO: streaming *)
lwt ballots = X.B.Records.fold (fun u (d, _) xs ->
let x = Printf.sprintf "%s %S\n"
......@@ -537,14 +524,13 @@ module SVoting = struct
| Some the_ballot ->
begin
Eliom_reference.unset ballot >>
let open Web_election in
let module X = (val election.modules : WEB_BALLOT_BOX_BUNDLE with type elt = Z.t) in
let module X = (val election : WEB_ELECTION) in
match_lwt S.get_logged_user () with
| Some user as u ->
lwt b = check_acl can_vote election.election_web u in
| Some u ->
let b = check_acl X.metadata.e_voters u.user_user in
if b then (
let record =
Auth_common.string_of_user user.user_user,
Auth_common.string_of_user u.user_user,
(CalendarLib.Fcalendar.Precise.now (), None)
in
lwt result =
......@@ -561,8 +547,7 @@ module SVoting = struct
| None -> fail_http 404
let ballot_received uuid election user =
let open Web_election in
let module X = (val election.modules : WEB_BALLOT_BOX_BUNDLE with type elt = Z.t) in
let module X = (val election : WEB_ELECTION) in
let confirm () =
let service = S.create_confirm () in
let () = Html5.register
......@@ -571,7 +556,7 @@ module SVoting = struct
(do_cast election)
in service
in
lwt can_vote = check_acl can_vote election.election_web user in
let can_vote = can_vote X.metadata user in
T.ballot_received ~election ~confirm ~user ~can_vote
let () = Html5.register
......@@ -631,10 +616,7 @@ module S = struct
end
module T = struct
type 'a election = 'a web_election
include Templates.Make (S)
end
module T = Templates.Make (S)
let () =
let module X : EMPTY = SAuth.Register (S) (T) in
......
src/web/templates.ml
View file @ 261865eb
......@@ -22,7 +22,9 @@
open Signatures
open Util
open Serializable_t
open Web_serializable_t
open Web_signatures
open Web_common
open Eliom_content.Html5.F
(* TODO: these pages should be redesigned *)
......@@ -33,7 +35,7 @@ let welcome_message = "Welcome!"
let format_user u =
em [pcdata (Auth_common.(string_of_user u.user_user))]
module Make (S : Web_signatures.ALL_SERVICES) = struct
module Make (S : ALL_SERVICES) : TEMPLATES = struct
let base ~title ~content =
lwt user = S.get_logged_user () in
......@@ -87,7 +89,9 @@ module Make (S : Web_signatures.ALL_SERVICES) = struct
]
]))
let format_one_featured_election e =
let format_one_featured_election election =
let module X = (val election : WEB_ELECTION) in
let e = X.election.e_params in
li [
h3 [
a ~service:(S.election_file e Services.ESIndex)
......@@ -184,30 +188,26 @@ module Make (S : Web_signatures.ALL_SERVICES) = struct
contents
let election_view ~election ~user =
let open Web_election in
let params = election.election.e_params in
let module X = (val election : WEB_ELECTION) in
let params = X.election.e_params and m = X.metadata in
let service = S.election_file params Services.ESRaw in
lwt permissions =
match election.election_web.can_vote with
| Any ->
Lwt.return [ pcdata "Anyone can vote in this election." ]
| Restricted p ->
match user with
| None ->
Lwt.return [
pcdata "Log in to check if you can vote. Alternatively, you can try to vote and log in at the last moment.";
]
| Some u ->
lwt b = p u.user_user in
let can = if b then pcdata "can" else pcdata "cannot" in
Lwt.return [
pcdata "You ";
can;
pcdata " vote in this election.";
]
match user with
| None ->
Lwt.return [
pcdata "Log in to check if you can vote. ";
pcdata "Alternatively, you can try to vote and ";
pcdata "log in at the last moment.";
]
| Some u ->
let can = if check_acl m.e_voters u.user_user then "can" else "cannot" in
Lwt.return [
pcdata "You ";
pcdata can;
pcdata " vote in this election.";
]
in
let voting_period =
let m = election.metadata in
match m.e_voting_starts_at, m.e_voting_ends_at with
| None, None ->
[
......@@ -239,7 +239,7 @@ module Make (S : Web_signatures.ALL_SERVICES) = struct
div [
div [
pcdata "Election fingerprint: ";
code [ pcdata election.election.e_fingerprint ];
code [ pcdata X.election.e_fingerprint ];
];
div [
pcdata "Election data: ";
......@@ -284,8 +284,8 @@ module Make (S : Web_signatures.ALL_SERVICES) = struct
base ~title:params.e_name ~content
let election_cast_raw ~election =
let open Web_election in
let params = election.election.e_params in
let module X = (val election : WEB_ELECTION) in
let params = X.election.e_params in
let form_rawballot = post_form ~service:S.election_cast_post
(fun (name, _) ->
[
......@@ -317,8 +317,8 @@ module Make (S : Web_signatures.ALL_SERVICES) = struct
base ~title:params.e_name ~content
let ballot_received ~election ~confirm ~user ~can_vote =
let open Web_election in
let params = election.election.e_params in
let module X = (val election : WEB_ELECTION) in
let params = X.election.e_params in
let name = params.e_name in
let user_div = match user with
| Some u when can_vote ->
......@@ -359,7 +359,8 @@ module Make (S : Web_signatures.ALL_SERVICES) = struct
base ~title:name ~content
let do_cast_ballot ~election ~result =
let params = election.election.e_params in
let module X = (val election : WEB_ELECTION) in
let params = X.election.e_params in
let name = params.e_name in
let content = [
h1 [ pcdata name ];
......@@ -381,7 +382,8 @@ module Make (S : Web_signatures.ALL_SERVICES) = struct
base ~title:name ~content
let election_update_credential ~election =
let params = election.election.e_params in
let module X = (val election : WEB_ELECTION) in
let params = X.election.e_params in
let form = post_form ~service:S.election_update_credential
(fun (old, new_) ->
[
......
src/web/web_common.ml
View file @ 261865eb
......@@ -154,3 +154,15 @@ let empty_metadata = {
e_voters = None;
e_owner = None;
}
let check_acl a u =
match a with
| Some acls ->
let rec loop = function
| [] -> false
| `Any :: _ -> true
| `Domain x :: _ when x = u.user_domain -> true
| `User x :: _ when x = u -> true
| _ :: xs -> loop xs
in loop acls
| _ -> false
src/web/web_common.mli
View file @ 261865eb
......@@ -67,3 +67,5 @@ val rewrite_prefix : string -> string
val set_rewrite_prefix : src:string -> dst:string -> unit
val empty_metadata : metadata
val check_acl : acl list option -> user -> bool
src/web/web_election.ml
View file @ 261865eb
......@@ -28,7 +28,7 @@ open Serializable_t
open Web_serializable_t
open Web_common
let make_web_election raw_election metadata election_web =
let make_web_election raw_election metadata ~featured_p ~params_fname ~public_keys_fname =
let e_fingerprint = sha256_b64 raw_election in
let wrapped_params = Serializable_j.params_of_string
......@@ -37,15 +37,19 @@ let make_web_election raw_election metadata election_web =
let {ffpk_g = g; ffpk_p = p; ffpk_q = q; ffpk_y = y} = wrapped_params.e_public_key in
let group = {g; p; q} in
let e_params = { wrapped_params with e_public_key = y } in
let election = {e_params; e_pks = None; e_fingerprint} in
let module X : WEB_BALLOT_BOX_BUNDLE with type elt = Z.t = struct
type elt = Z.t
let module X : WEB_ELECTION = struct
module G = (val Election.finite_field group : Election.FF_GROUP)
module M = MakeLwtRandom(struct let rng = make_rng () end)
module E = Election.MakeElection(G)(M)
let election = {e_params; e_pks = None; e_fingerprint}
let metadata = metadata
let public_keys_fname = public_keys_fname
let params_fname = params_fname
let featured_p = featured_p
module B : WEB_BALLOT_BOX = struct
let suffix = "_" ^ String.map (function
......@@ -200,9 +204,5 @@ let make_web_election raw_election metadata election_web =
Lwt_mutex.with_lock mutex (fun () -> do_update_cred ~old ~new_)
end
end in
{
modules = (module X : WEB_BALLOT_BOX_BUNDLE with type elt = Z.t);
election;
metadata;
election_web;
}
(module X : WEB_ELECTION)
src/web/web_election.mli
View file @ 261865eb
......@@ -27,5 +27,7 @@ open Web_signatures
val make_web_election :
string ->
metadata ->
election_web ->
Z.t web_election
featured_p:bool ->
params_fname:string ->
public_keys_fname:string ->
(module WEB_ELECTION)
src/web/web_signatures.mli
View file @ 261865eb
......@@ -228,29 +228,6 @@ module type AUTH_SERVICES = sig
end
type acl =
| Any
| Restricted of (user -> bool Lwt.t)
type election_web = {
params_fname : string;
public_keys_fname : string;
featured_p : bool;
can_read : acl;
can_vote : acl;
}
module type ELECTION_BUNDLE = sig
(* It seems that with OCaml 3.12.1, "with" constraints in package
types cannot be made on types in submodules, so we export a type
here, that will be aliased in submodules and constrained in
package types. *)
type elt
module G : GROUP with type t = elt
module E : ELECTION with type elt = elt
end
module type WEB_BALLOT_BOX = sig
module Ballots : MONADIC_MAP_RO
with type 'a m = 'a Lwt.t
......@@ -267,43 +244,42 @@ module type WEB_BALLOT_BOX = sig
val update_cred : old:string -> new_:string -> unit Lwt.t
end
module type WEB_ELECTION_BUNDLE =
ELECTION_BUNDLE with type 'a E.m = 'a Lwt.t
module type WEB_ELECTION = sig
module G : GROUP
module E : ELECTION with type elt = G.t
val election : G.t election
val metadata : metadata
module type WEB_BALLOT_BOX_BUNDLE = sig
include WEB_ELECTION_BUNDLE
module B : WEB_BALLOT_BOX
end
type 'a web_election = {
modules : (module WEB_BALLOT_BOX_BUNDLE with type elt = 'a);
election : 'a election;
metadata : metadata;
election_web : election_web;
}
val featured_p : bool
val params_fname : string
val public_keys_fname : string
end
module type TEMPLATES = sig
val index :
featured:'a Serializable_t.params list ->
featured:(module WEB_ELECTION) list ->
[> `Html ] Eliom_content.Html5.F.elt Lwt.t
val election_update_credential :
election:'a web_election ->
election:(module WEB_ELECTION) ->
[> `Html ] Eliom_content.Html5.F.elt Lwt.t
val election_view :
election:'a web_election ->
election:(module WEB_ELECTION) ->
user:logged_user option ->
[> `Html ] Eliom_content.Html5.F.elt Lwt.t
val do_cast_ballot :
election:'a web_election ->
election:(module WEB_ELECTION) ->
result:[< `Error of Web_common.error | `Valid of string ] ->
[> `Html ] Eliom_content.Html5.F.elt Lwt.t
val ballot_received :
election:'a web_election ->
election:(module WEB_ELECTION) ->
confirm:(unit ->
(Serializable_t.uuid, 'b,
[< Eliom_service.post_service_kind ],
......@@ -314,7 +290,7 @@ module type TEMPLATES = sig
can_vote:bool -> [> `Html ] Eliom_content.Html5.F.elt Lwt.t
val election_cast_raw :
election:'a web_election ->
election:(module WEB_ELECTION) ->
[> `Html ] Eliom_content.Html5.F.elt Lwt.t
val dummy_login :
......
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