Commit ae5339c9 authored by Stephane Glondu's avatar Stephane Glondu
Browse files

Change in web_common datatypes

parent 857da2e5
......@@ -200,3 +200,19 @@ module type ELECTION = sig
val extract_tally : result -> plaintext
(** Extract the plaintext result of the election. *)
end
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 BALLOT_BOX_BUNDLE = sig
include ELECTION_BUNDLE
include BALLOT_BOX with type 'a m = 'a E.m
end
......@@ -116,14 +116,10 @@ lwt election_table =
Ocsigen_messages.debug (fun () ->
"-- registering " ^ subdir
);
lwt raw =
lwt raw_election =
Lwt_io.chars_of_file params_fname |>
Lwt_stream.to_string
in
let params = Serializable_j.params_of_string
Serializable_j.read_ff_pubkey raw
in
let fingerprint = sha256_b64 raw in
lwt metadata =
let fname = path/"metadata.json" in
lwt b = file_exists fname in
......@@ -153,12 +149,6 @@ lwt election_table =
return (Web_common.SSet.mem (Web_common.string_of_user u) set)
)
in
let election = {
e_params = params;
e_meta = metadata;
e_pks = None;
e_fingerprint = fingerprint;
} in
let election_web = Web_common.({
params_fname;
public_keys_fname;
......@@ -166,13 +156,13 @@ lwt election_table =
can_read = Any;
can_vote;
}) in
let web_election = Web_common.make_web_election
(module E : Web_common.LWT_ELECTION with type elt = Z.t)
election election_web
let open Web_common in
let web_election = make_web_election
raw_election metadata election_web
in
let module X = (val web_election : Web_common.WEB_ELECTION) in
let module X = (val web_election.modules : WEB_BALLOT_BOX_BUNDLE with type elt = Z.t) in
X.B.inject_creds public_creds >>
let uuid = params.e_uuid in
let uuid = web_election.election.e_params.e_uuid in
return (EMap.add uuid web_election accu)
) else return accu
)
......@@ -186,10 +176,10 @@ let get_election_by_uuid x =
raise_lwt Eliom_common.Eliom_404
let get_featured_elections () =
let open Web_common in
EMap.fold (fun uuid e res ->
let module X = (val e : Web_common.WEB_ELECTION) in
if X.election_web.Web_common.featured_p then
X.election :: res
if e.election_web.featured_p then
e.election.e_params :: res
else res
) election_table [] |> return
......@@ -212,9 +202,8 @@ let check_acl acl election user =
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 b = check_acl acl X.election_web user in
lwt b = check_acl acl election.Web_common.election_web user in
if b then f uuid election user x else forbidden ()
let () =
......@@ -374,8 +363,7 @@ let () = Eliom_registration.File.register
~content_type:"application/json"
(if_eligible can_read
(fun uuid election user () ->
let module X = (val election : Web_common.WEB_ELECTION) in
return X.election_web.Web_common.params_fname
return Web_common.(election.election_web.params_fname)
)
)
......@@ -384,8 +372,7 @@ let () = Eliom_registration.File.register
~content_type:"application/json"
(if_eligible can_read
(fun uuid election user () ->
let module X = (val election : Web_common.WEB_ELECTION) in
return X.election_web.Web_common.public_keys_fname
return Web_common.(election.election_web.public_keys_fname)
)
)
......@@ -393,7 +380,8 @@ let () = Eliom_registration.Streamlist.register
~service:Services.election_public_creds
(if_eligible can_read
(fun uuid election user () ->
let module X = (val election : Web_common.WEB_ELECTION) in
let open Web_common in
let module X = (val election.modules : WEB_BALLOT_BOX_BUNDLE with type elt = Z.t) in
lwt creds = X.B.extract_creds () in
let s = Web_common.SSet.fold (fun x accu ->
(fun () -> return (Ocsigen_stream.of_string (x^"\n"))) :: accu
......@@ -406,7 +394,8 @@ let () = Eliom_registration.Streamlist.register
~service:Services.election_ballots
(if_eligible can_read
(fun uuid election user () ->
let module X = (val election : Web_common.WEB_ELECTION) in
let open Web_common in
let module X = (val election.modules : WEB_BALLOT_BOX_BUNDLE with type elt = Z.t) in
(* TODO: streaming *)
lwt ballots = X.B.fold_ballots (fun x xs ->
return ((x^"\n")::xs)
......@@ -423,7 +412,8 @@ let () = Eliom_registration.Streamlist.register
(if_eligible can_read
(fun uuid election user () ->
if Web_common.is_admin user then (
let module X = (val election : Web_common.WEB_ELECTION) in
let open Web_common in
let module X = (val election.modules : WEB_BALLOT_BOX_BUNDLE with type elt = Z.t) in
(* TODO: streaming *)
lwt ballots = X.B.fold_records (fun (u, d) xs ->
let x = Printf.sprintf "%s %S\n"
......@@ -484,10 +474,10 @@ let do_cast election uuid () =
begin
Eliom_reference.unset Services.ballot >>
let open Web_common in
let module X = (val election : WEB_ELECTION) in
let module X = (val election.modules : WEB_BALLOT_BOX_BUNDLE with type elt = Z.t) in
match_lwt Eliom_reference.get Services.user with
| Some user as u ->
lwt b = check_acl can_vote X.election_web u in
lwt b = check_acl can_vote election.election_web u in
if b then (
let record =
Web_common.string_of_user user,
......@@ -500,14 +490,15 @@ let do_cast election uuid () =
with Error e -> return (`Error e)
in
Eliom_reference.unset Services.ballot >>
Templates.do_cast_ballot ~auth_systems ~election:X.election ~result
Templates.do_cast_ballot ~auth_systems ~election ~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
let open Web_common in
let module X = (val election.modules : WEB_BALLOT_BOX_BUNDLE with type elt = Z.t) in
Eliom_reference.set Services.saved_service (Services.Cast uuid) >>
let confirm () =
let service = Services.create_confirm () in
......@@ -517,8 +508,8 @@ let ballot_received uuid election user =
(do_cast election)
in service
in
lwt can_vote = check_acl can_vote X.election_web user in
Templates.ballot_received ~auth_systems ~election:X.election ~confirm ~user ~can_vote
lwt can_vote = check_acl can_vote election.election_web user in
Templates.ballot_received ~auth_systems ~election ~confirm ~user ~can_vote
let () = Eliom_registration.Html5.register
......@@ -563,10 +554,11 @@ let () = Eliom_registration.Html5.register
let () = Eliom_registration.String.register
~service:Services.election_update_credential
(fun uuid (old, new_) ->
let open Web_common in
lwt user = Eliom_reference.get Services.user in
if Web_common.is_admin user then (
lwt election = get_election_by_uuid uuid in
let module X = (val election : Web_common.WEB_ELECTION) in
let module X = (val election.modules : WEB_BALLOT_BOX_BUNDLE with type elt = Z.t) in
try_lwt
X.B.update_cred ~old ~new_ >>
return ("OK", "text/plain")
......
......@@ -157,7 +157,7 @@ let make_booth uuid =
Eliom_uri.make_string_uri ~absolute_path:true ~service ()
)
let preapply_uuid s e = Eliom_service.preapply s e.Signatures.e_params.e_uuid
let preapply_uuid s e = Eliom_service.preapply s e.e_uuid
type savable_service =
| Home
......
......@@ -105,9 +105,9 @@ let format_one_featured_election e =
li [
h3 [
a ~service:Services.(preapply_uuid election_index e)
[pcdata e.e_params.e_name] ();
[pcdata e.e_name] ();
];
p [pcdata e.e_params.e_description];
p [pcdata e.e_description];
]
let index ~auth_systems ~featured =
......@@ -164,13 +164,11 @@ let make_button ~service contents =
contents
let election_view ~auth_systems ~election ~user =
let module X = (val election : Web_common.WEB_ELECTION) in
let election = X.election in
let params = election.e_params in
let service = Services.(preapply_uuid election_raw election) in
let open Web_common in
let params = election.election.e_params in
let service = Services.(preapply_uuid election_raw params) in
lwt permissions =
let open Web_common in
match X.election_web.can_vote with
match election.election_web.can_vote with
| Any ->
Lwt.return [ pcdata "Anyone can vote in this election." ]
| Restricted p ->
......@@ -188,7 +186,7 @@ let election_view ~auth_systems ~election ~user =
pcdata " vote in this election.";
]
in
let voting_period = match election.e_meta with
let voting_period = match election.election.e_meta with
| Some m ->
[
pcdata "This election starts on ";
......@@ -207,21 +205,21 @@ let election_view ~auth_systems ~election ~user =
div [
div [
pcdata "Election fingerprint: ";
code [ pcdata election.e_fingerprint ];
code [ pcdata election.election.e_fingerprint ];
];
div [
pcdata "Election data: ";
a ~service [ pcdata "parameters" ] ();
pcdata ", ";
a ~service:Services.(preapply_uuid election_public_creds election) [
a ~service:Services.(preapply_uuid election_public_creds params) [
pcdata "public credentials"
] ();
pcdata ", ";
a ~service:Services.(preapply_uuid election_public_keys election) [
a ~service:Services.(preapply_uuid election_public_keys params) [
pcdata "trustee public keys"
] ();
pcdata ", ";
a ~service:Services.(preapply_uuid election_ballots election) [
a ~service:Services.(preapply_uuid election_ballots params) [
pcdata "ballots";
] ();
pcdata ".";
......@@ -238,11 +236,11 @@ let election_view ~auth_systems ~election ~user =
div [
div [
make_button
~service:(Services.(preapply_uuid election_vote election))
~service:(Services.(preapply_uuid election_vote params))
"Go to the booth";
pcdata " or ";
make_button
~service:(Services.(preapply_uuid election_cast election))
~service:(Services.(preapply_uuid election_cast params))
"Submit a raw ballot";
];
];
......@@ -252,8 +250,8 @@ let election_view ~auth_systems ~election ~user =
base ~auth_systems ~title:params.e_name ~content
let election_cast_raw ~election =
let module X = (val election : Web_common.WEB_ELECTION) in
let params = X.election.e_params in
let open Web_common in
let params = election.election.e_params in
let form_rawballot = post_form ~service:Services.election_cast_post
(fun (name, _) ->
[
......@@ -285,7 +283,9 @@ let election_cast_raw ~election =
base ~title:params.e_name ~content
let ballot_received ~election ~confirm ~user ~can_vote =
let name = election.e_params.e_name in
let open Web_common in
let params = election.election.e_params in
let name = params.e_name in
let user_div = match user with
| Some u when can_vote ->
let service = confirm () in
......@@ -297,7 +297,7 @@ let ballot_received ~election ~confirm ~user ~can_vote =
string_input ~input_type:`Submit ~value:"I confirm my vote" ();
pcdata ".";
]
]) election.e_params.e_uuid
]) params.e_uuid
| Some _ ->
div [
pcdata "You cannot vote in this election!";
......@@ -316,7 +316,7 @@ let ballot_received ~election ~confirm ~user ~can_vote =
];
user_div;
p [
a ~service:(Services.(preapply_uuid election_index election)) [
a ~service:(Services.(preapply_uuid election_index params)) [
pcdata "Go back to election"
] ();
pcdata ".";
......@@ -325,7 +325,8 @@ let ballot_received ~election ~confirm ~user ~can_vote =
base ~title:name ~content
let do_cast_ballot ~election ~result =
let name = election.e_params.e_name in
let params = election.Web_common.election.e_params in
let name = params.e_name in
let content = [
h1 [ pcdata name ];
p [
......@@ -337,7 +338,7 @@ let do_cast_ballot ~election ~result =
);
];
p [
a ~service:(Services.(preapply_uuid election_index election)) [
a ~service:(Services.(preapply_uuid election_index params)) [
pcdata "Go back to election"
] ();
pcdata ".";
......@@ -346,8 +347,7 @@ let do_cast_ballot ~election ~result =
base ~title:name ~content
let election_update_credential ~election =
let module X = (val election : Web_common.WEB_ELECTION) in
let params = X.election.e_params in
let params = election.Web_common.election.e_params in
let form = post_form ~service:Services.election_update_credential
(fun (old, new_) ->
[
......
......@@ -54,6 +54,8 @@ let make_rng = Lwt_preemptive.detach (fun () ->
Cryptokit.Random.(pseudo_rng (string secure_rng 16))
)
module type LWT_RANDOM = Signatures.RANDOM with type 'a t = 'a Lwt.t
module type LWT_RNG = sig
val rng : Cryptokit.Random.rng Lwt.t
end
......@@ -102,20 +104,6 @@ let explain_error = function
| UsedCredential -> "the credential has already been used"
| CredentialNotFound -> "the credential has not been found"
module type LWT_ELECTION = Signatures.ELECTION
with type 'a m = 'a Lwt.t
module type WEB_BBOX = sig
include Signatures.BALLOT_BOX
with type 'a m := 'a Lwt.t
and type ballot = string
and type record = string * datetime
val inject_creds : SSet.t -> unit Lwt.t
val extract_creds : unit -> SSet.t Lwt.t
val update_cred : old:string -> new_:string -> unit Lwt.t
end
let security_logfile = ref None
let open_security_log f =
......@@ -147,123 +135,124 @@ let security_log s =
Lwt_io.flush ic
) ic
module type WEB_ELECTION = sig
module G : Signatures.GROUP with type t = Z.t
module E : LWT_ELECTION with type elt = G.t
module B : WEB_BBOX
val election : G.t Signatures.election
val election_web : election_web
module type WEB_BALLOT_BOX = sig
include Signatures.BALLOT_BOX
with type 'a m = 'a Lwt.t
and type ballot = string
and type record = string * datetime
val inject_creds : SSet.t -> unit Lwt.t
val extract_creds : unit -> SSet.t Lwt.t
val update_cred : old:string -> new_:string -> unit Lwt.t
end
let make_web_election lwt_election wrapped_election election_web = begin
module type WEB_ELECTION_BUNDLE =
Signatures.ELECTION_BUNDLE with type 'a E.m = 'a Lwt.t
let wrapped_params = wrapped_election.e_params in
let {group; y} = wrapped_params.e_public_key in
module type WEB_BALLOT_BOX_BUNDLE = sig
include WEB_ELECTION_BUNDLE
module B : WEB_BALLOT_BOX
end
let module G : Signatures.GROUP with type t = Z.t =
(val Election.finite_field group : Election.FF_GROUP)
in
type 'a web_election = {
modules : (module WEB_BALLOT_BOX_BUNDLE with type elt = 'a);
election : 'a Signatures.election;
election_web : election_web;
}
let make_web_election raw_election e_meta election_web =
let election = { wrapped_election with
e_params = { wrapped_params with e_public_key = y };
e_pks = None
} in
let module E = (val lwt_election : LWT_ELECTION with type elt = G.t) in
let module B : WEB_BBOX = struct
let suffix = "_" ^ String.map (function
| '-' -> '_'
| c -> c
) (Uuidm.to_string election.e_params.e_uuid)
let ballot_table = Ocsipersist.open_table ("ballots" ^ suffix)
let record_table = Ocsipersist.open_table ("records" ^ suffix)
let cred_table = Ocsipersist.open_table ("creds" ^ suffix)
type ballot = string
type record = string * Serializable_builtin_t.datetime
let extract_creds () =
Ocsipersist.fold_step (fun k v x ->
return (SSet.add k x)
) cred_table SSet.empty
let inject_creds creds =
lwt existing_creds = extract_creds () in
if SSet.is_empty existing_creds then (
Ocsigen_messages.debug (fun () ->
"-- injecting credentials"
);
SSet.fold (fun x unit ->
unit >> Ocsipersist.add cred_table x None
) creds (return ())
) else (
if SSet.(is_empty (diff creds existing_creds)) then (
Lwt.return ()
let e_fingerprint = sha256_b64 raw_election in
let wrapped_params = Serializable_j.params_of_string
Serializable_j.read_ff_pubkey raw_election
in
let {group; y} = wrapped_params.e_public_key in
let e_params = { wrapped_params with e_public_key = y } in
let election = {e_params; e_meta; e_pks = None; e_fingerprint} in
let module X : WEB_ELECTION_BUNDLE with type elt = Z.t = struct
type elt = Z.t
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)
module B : WEB_BALLOT_BOX = struct
type 'a m = 'a Lwt.t
let suffix = "_" ^ String.map (function
| '-' -> '_'
| c -> c
) (Uuidm.to_string e_params.e_uuid)
let ballot_table = Ocsipersist.open_table ("ballots" ^ suffix)
let record_table = Ocsipersist.open_table ("records" ^ suffix)
let cred_table = Ocsipersist.open_table ("creds" ^ suffix)
type ballot = string
type record = string * Serializable_builtin_t.datetime
let extract_creds () =
Ocsipersist.fold_step (fun k v x ->
return (SSet.add k x)
) cred_table SSet.empty
let inject_creds creds =
lwt existing_creds = extract_creds () in
if SSet.is_empty existing_creds then (
Ocsigen_messages.debug (fun () ->
"-- injecting credentials"
);
SSet.fold (fun x unit ->
unit >> Ocsipersist.add cred_table x None
) creds (return ())
) else (
Ocsigen_messages.warning "public_creds.txt does not match db!";
Lwt.return ()
)
)
let do_cast rawballot (user, date) =
let voting_open = match election.e_meta with
| Some m ->
let date = fst date in
let open CalendarLib.Fcalendar.Precise in
compare (fst m.e_voting_starts_at) date <= 0 &&
compare date (fst m.e_voting_ends_at) < 0
| None -> true
in
if not voting_open then fail ElectionClosed else return () >>
if String.contains rawballot '\n' then (
fail (Serialization (Invalid_argument "multiline ballot"))
) else return () >>
lwt ballot =
try Lwt.return (
Serializable_j.ballot_of_string
Serializable_builtin_j.read_number rawballot
) with e -> fail (Serialization e)
in
lwt credential =
match ballot.signature with
| Some s -> Lwt.return (Z.to_string s.s_public_key)
| None -> fail MissingCredential
in
lwt old_cred =
try_lwt Ocsipersist.find cred_table credential
with Not_found -> fail InvalidCredential
and old_record =
try_lwt
lwt x = Ocsipersist.find record_table user in
Lwt.return (Some x)
with Not_found -> Lwt.return None
in
match old_cred, old_record with
| None, None ->
(* first vote *)
if E.check_ballot election ballot then (
let hash = sha256_b64 rawballot in
Ocsipersist.add cred_table credential (Some hash) >>
Ocsipersist.add ballot_table hash rawballot >>
Ocsipersist.add record_table user (date, credential) >>
security_log (fun () ->
Printf.sprintf "%s successfully cast ballot %s" user hash
)
if SSet.(is_empty (diff creds existing_creds)) then (
Lwt.return ()
) else (
fail ProofCheck
Ocsigen_messages.warning "public_creds.txt does not match db!";
Lwt.return ()
)
| Some h, Some (_, old_credential) ->
(* revote *)
if credential = old_credential then (
)
let do_cast rawballot (user, date) =
let voting_open = match election.e_meta with
| Some m ->
let date = fst date in
let open CalendarLib.Fcalendar.Precise in
compare (fst m.e_voting_starts_at) date <= 0 &&
compare date (fst m.e_voting_ends_at) < 0
| None -> true
in
if not voting_open then fail ElectionClosed else return () >>
if String.contains rawballot '\n' then (
fail (Serialization (Invalid_argument "multiline ballot"))
) else return () >>
lwt ballot =
try Lwt.return (
Serializable_j.ballot_of_string
Serializable_builtin_j.read_number rawballot
) with e -> fail (Serialization e)
in
lwt credential =
match ballot.signature with
| Some s -> Lwt.return (Z.to_string s.s_public_key)
| None -> fail MissingCredential
in
lwt old_cred =
try_lwt Ocsipersist.find cred_table credential
with Not_found -> fail InvalidCredential
and old_record =
try_lwt
lwt x = Ocsipersist.find record_table user in
Lwt.return (Some x)
with Not_found -> Lwt.return None
in
match old_cred, old_record with
| None, None ->
(* first vote *)
if E.check_ballot election ballot then (
lwt old_ballot = Ocsipersist.find ballot_table h in
Ocsipersist.remove ballot_table h >>
security_log (fun () ->
Printf.sprintf "%s successfully removed ballot %S" user old_ballot
) >>
let hash = sha256_b64 rawballot in
Ocsipersist.add cred_table credential (Some hash) >>
Ocsipersist.add ballot_table hash rawballot >>
......@@ -274,57 +263,71 @@ let make_web_election lwt_election wrapped_election election_web = begin
) else (