Commit 11373f79 authored by Stephane Glondu's avatar Stephane Glondu

Merge tag '1.9' into explicit-homomorphism

Version 1.9
parents ee73ff61 57dad9e0
Pipeline #81832 passed with stages
in 19 minutes and 9 seconds
#use "topfind";;
#require "zarith";;
#require "calendar";;
#require "uuidm";;
#require "atdgen";;
#require "yojson";;
#require "cryptokit";;
#camlp4o;;
#require "lwt.unix";;
#require "lwt.syntax";;
#directory "_build/src/lib";;
#load "lib.cma";;
let pp_print_datetime ppf x =
Format.pp_print_string ppf (Serializable_builtin_j.string_of_datetime x)
;;
let pp_print_uuid ppf x =
Format.pp_print_string ppf (Serializable_builtin_j.string_of_uuid x)
;;
#install_printer Z.pp_print;;
#install_printer pp_print_datetime;;
#install_printer pp_print_uuid;;
1.8 (2018-02-04)
1.9 (2019-05-28)
================
* Fix use of SOURCE_DATE_EPOCH
* Web server:
+ Fix a bug that seldom caused the server to not perform its
partial decryption
+ Check that cookies are not blocked on ballot submission
+ Add the possibility to temporarily hide the result from the
public
1.8 (2019-02-04)
================
* Add the possibility to override sendmail via an environment variable
......
minimal.otarget
src/lib/lib.cma
src/web/server.cma
src/static/logo.png
src/static/placeholder.png
......
src/platform/native/Platform
Serializable_builtin_t
Serializable_builtin_j
Serializable_t
Serializable_j
Common
Group_field
Group
Trustees
Election
Credential
......@@ -38,17 +38,17 @@ module LwtRandom = struct
let prng = ref (init_prng ())
let _ =
let () =
let rec loop () =
let%lwt () = Lwt_unix.sleep 1800. in
prng := init_prng ();
loop ()
in
loop ()
Lwt.async loop
let random q =
let size = bytes_to_sample q in
let%lwt rng = Lwt_preemptive.detach Lazy.force !prng in
let rng = Lazy.force !prng in
let r = random_string rng size in
return Z.(of_bits r mod q)
......@@ -261,10 +261,7 @@ let b58_digits = "123456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz"
let prng = lazy (pseudo_rng (random_string secure_rng 16))
let random_char () =
let%lwt rng =
if Lazy.is_val prng then return (Lazy.force prng) else
Lwt_preemptive.detach (fun () -> Lazy.force prng) ()
in
let rng = Lazy.force prng in
return (int_of_char (random_string rng 1).[0])
let generate_token ?(length=14) () =
......@@ -453,3 +450,4 @@ let days_to_archive = 7
let days_to_delete = 365
let days_to_mail = 30
let days_between_mails = 7
let days_to_publish_result = 7
......@@ -169,3 +169,4 @@ val days_to_archive : int
val days_to_delete : int
val days_to_mail : int
val days_between_mails : int
val days_to_publish_result : int
......@@ -120,6 +120,7 @@ module type LocalizedStrings = sig
val hours : string
val minutes : string
val seconds : string
val result_currently_not_public : (string -> 'f, 'b, 'c, 'e, 'e, 'f) format6
val mail_password_subject : (string -> 'f, 'b, 'c, 'e, 'e, 'f) format6
val mail_password : (string -> string -> string -> string -> string -> 'f, 'b, 'c, 'e, 'e, 'f) format6
val mail_credential_subject : (string -> 'f, 'b, 'c, 'e, 'e, 'f) format6
......
......@@ -119,6 +119,7 @@ let days = " Tag(en)"
let hours = " Stunde(n)"
let minutes = " Minute(n)"
let seconds = " Sekunde(n)"
let result_currently_not_public : ('a, 'b, 'c, 'd, 'e, 'f) format6 = "Das Ergebnis dieser Abstimmung ist derzeit noch nicht verfügbar. Es wird in %s veröffentlicht."
let mail_password_subject : ('a, 'b, 'c, 'd, 'e, 'f) format6 =
......
......@@ -119,6 +119,7 @@ let days = " day(s)"
let hours = " hour(s)"
let minutes = " minute(s)"
let seconds = " second(s)"
let result_currently_not_public : ('a, 'b, 'c, 'd, 'e, 'f) format6 = "The result of this election is currently not publicly available. It will be in %s."
let mail_password_subject : ('a, 'b, 'c, 'd, 'e, 'f) format6 =
......
......@@ -119,6 +119,7 @@ let days = " jour(s)"
let hours = " heure(s)"
let minutes = " minute(s)"
let seconds = " seconde(s)"
let result_currently_not_public : ('a, 'b, 'c, 'd, 'e, 'f) format6 = "Le résultat de cette élection n'est actuellement pas public. Il le sera dans %s."
let mail_password_subject : ('a, 'b, 'c, 'd, 'e, 'f) format6 =
......
......@@ -119,6 +119,7 @@ let days = " day(s)"
let hours = " hour(s)"
let minutes = " minute(s)"
let seconds = " second(s)"
let result_currently_not_public : ('a, 'b, 'c, 'd, 'e, 'f) format6 = "The result of this election is currently not publicly available. It will be in %s."
let mail_password_subject : ('a, 'b, 'c, 'd, 'e, 'f) format6 =
......
......@@ -119,6 +119,7 @@ let days = " zi(le) "
let hours = " ora(e)"
let minutes = " minut(e)"
let seconds = " secundă(e)"
let result_currently_not_public : ('a, 'b, 'c, 'd, 'e, 'f) format6 = "Rezultatul acestei alegeri nu este disponibil deocamdată. Va fi disponibil în %s."
let mail_password_subject : ('a, 'b, 'c, 'd, 'e, 'f) format6 =
......
......@@ -44,6 +44,26 @@ let get_election_result uuid =
| Some [x] -> return (Some (election_result_of_string Yojson.Safe.read_json x))
| _ -> return_none
let set_election_result_hidden uuid hidden =
match hidden with
| None ->
(
try%lwt Lwt_unix.unlink (!Web_config.spool_dir / raw_string_of_uuid uuid / "hide_result")
with _ -> return_unit
)
| Some d -> write_file ~uuid "hide_result" [string_of_datetime d]
let get_election_result_hidden uuid =
match%lwt read_file ~uuid "hide_result" with
| Some [x] ->
let t = datetime_of_string x in
if datetime_compare (now ()) t < 0 then
return (Some t)
else
let%lwt () = set_election_result_hidden uuid None in
return_none
| _ -> return_none
type election_date =
[ `Creation
| `Validation
......
......@@ -59,6 +59,9 @@ val get_raw_election : uuid -> string option Lwt.t
val get_election_metadata : uuid -> metadata Lwt.t
val get_election_result : uuid -> Yojson.Safe.json election_result option Lwt.t
val get_election_result_hidden : uuid -> datetime option Lwt.t
val set_election_result_hidden : uuid -> datetime option -> unit Lwt.t
type election_kind =
[ `Draft
| `Validated
......
......@@ -83,6 +83,8 @@ let election_regenpwd_post = create_attached_post ~fallback:election_regenpwd ~p
let election_login = create ~path:(Path ["elections"]) ~meth:(Get (suffix_prod (uuid "uuid" ** suffix_const "login") (opt (string "service")))) ()
let election_open = create_attached_post ~fallback:election_admin ~post_params:unit ()
let election_close = create_attached_post ~fallback:election_admin ~post_params:unit ()
let election_hide_result = create_attached_post ~fallback:election_admin ~post_params:(string "date") ()
let election_show_result = create_attached_post ~fallback:election_admin ~post_params:unit ()
let election_auto_post = create_attached_post ~fallback:election_admin ~post_params:(string "open" ** string "close") ()
let election_archive = create_attached_post ~fallback:election_admin ~post_params:unit ()
let election_delete = create_attached_post ~fallback:election_admin ~post_params:unit ()
......@@ -92,6 +94,7 @@ let election_vote = create ~path:(Path ["vote.html"]) ~meth:(Get unit) ()
let election_cast = create ~path:(Path ["election"; "cast"]) ~meth:(Get (uuid "uuid")) ()
let election_submit_ballot = create ~path:(Path ["election"; "submit-ballot"]) ~meth:(Post (unit, string "encrypted_vote")) ()
let election_submit_ballot_file = create ~path:(Path ["election"; "submit-ballot-file"]) ~meth:(Post (unit, file "encrypted_vote")) ()
let election_submit_ballot_check = create ~path:(Path ["election"; "submit-ballot-check"]) ~meth:(Get unit) ()
let election_cast_confirm = create_attached_post ~csrf_safe:true ~fallback:election_cast ~post_params:unit ()
let election_pretty_ballots = create ~path:(Path ["elections"]) ~meth:(Get (suffix (uuid "uuid" ** suffix_const "ballots"))) ()
let election_pretty_ballot = create ~path:(Path ["elections"]) ~meth:(Get (suffix_prod (uuid "uuid" ** suffix_const "ballot") (string "hash"))) ()
......
......@@ -312,6 +312,7 @@ let delete_election uuid =
"threshold.json";
"records";
"result.json";
"hide_result";
"voters.txt";
"archive.zip";
]
......@@ -1276,6 +1277,43 @@ let election_set_state state uuid () =
let () = Any.register ~service:election_open (election_set_state true)
let () = Any.register ~service:election_close (election_set_state false)
let election_set_result_hidden f uuid x =
with_site_user (fun u ->
let%lwt metadata = Web_persist.get_election_metadata uuid in
if metadata.e_owner = Some u then (
try%lwt
let%lwt () = Web_persist.set_election_result_hidden uuid (f x) in
redir_preapply election_admin uuid ()
with
| Failure msg ->
let service = preapply election_admin uuid in
T.generic_page ~title:"Error" ~service msg () >>= Html.send
) else forbidden ()
)
let parse_datetime_from_post x =
try datetime_of_string ("\"" ^ x ^ ".000000\"")
with _ -> Printf.ksprintf failwith "%s is not a valid date!" x
let () =
Any.register ~service:election_hide_result
(election_set_result_hidden
(fun x ->
let t = parse_datetime_from_post x in
let max = datetime_add (now ()) (day days_to_publish_result) in
if datetime_compare t max > 0 then
Printf.ksprintf failwith
"The date must be less than %d days in the future!"
days_to_publish_result
else
Some t
)
)
let () =
Any.register ~service:election_show_result
(election_set_result_hidden (fun () -> None))
let () =
Any.register ~service:election_auto_post
(fun uuid (auto_open, auto_close) ->
......@@ -1286,10 +1324,7 @@ let () =
try
let format x =
if x = "" then None
else Some (
try datetime_of_string ("\"" ^ x ^ ".000000\"")
with _ -> Printf.ksprintf failwith "%s is not a valid date!" x
)
else Some (parse_datetime_from_post x)
in
let auto_open = format auto_open in
let auto_close = format auto_close in
......@@ -1377,20 +1412,8 @@ let () =
let submit_ballot ballot =
let ballot = PString.trim ballot in
let%lwt uuid =
try
let ballot = ballot_of_string Yojson.Safe.read_json ballot in
return ballot.election_uuid
with _ -> fail_http 400
in
match%lwt Web_persist.get_draft_election uuid with
| Some _ -> redir_preapply election_draft uuid ()
| None ->
let%lwt user = Web_state.get_election_user uuid in
let%lwt () = Eliom_reference.set Web_state.ballot (Some ballot) in
match user with
| None -> redir_preapply election_login ((uuid, ()), None) ()
| Some _ -> redir_preapply election_cast uuid ()
let%lwt () = Eliom_reference.set Web_state.ballot (Some ballot) in
redir_preapply election_submit_ballot_check () ()
let () =
Any.register ~service:election_submit_ballot
......@@ -1406,6 +1429,30 @@ let () =
submit_ballot ballot
)
let () =
Any.register ~service:election_submit_ballot_check
(fun () () ->
match%lwt Eliom_reference.get Web_state.ballot with
| None ->
let%lwt lang = Eliom_reference.get Web_state.language in
let module L = (val Web_i18n.get_lang lang) in
T.generic_page ~title:L.cookies_are_blocked L.please_enable_them ()
>>= Html.send
| Some ballot ->
match
try
let ballot = ballot_of_string Yojson.Safe.read_json ballot in
Some ballot.election_uuid
with _ -> None
with
| None ->
T.generic_page ~title:"Error" "Ill-formed ballot" () >>= Html.send
| Some uuid ->
match%lwt Web_persist.get_draft_election uuid with
| Some _ -> redir_preapply election_draft uuid ()
| None -> redir_preapply election_login ((uuid, ()), None) ()
)
let send_confirmation_email uuid revote user email hash =
let%lwt election = find_election uuid in
let title = election.e_params.e_name in
......@@ -1805,10 +1852,14 @@ let content_type_of_file = function
| ESCreds | ESRecords | ESVoters -> "text/plain"
let handle_pseudo_file uuid f site_user =
let confidential =
let%lwt confidential =
match f with
| ESRaw | ESKeys | ESTParams | ESBallots | ESETally | ESResult | ESCreds -> false
| ESRecords | ESVoters -> true
| ESRaw | ESKeys | ESTParams | ESBallots | ESETally | ESCreds -> return false
| ESRecords | ESVoters -> return true
| ESResult ->
match%lwt Web_persist.get_election_result_hidden uuid with
| None -> return false
| Some _ -> return true
in
let%lwt () =
if confidential then (
......
......@@ -311,7 +311,7 @@ let election_draft_pre () =
let title = "Prepare a new election" in
let cred_info = Eliom_service.extern
~prefix:"http://www.belenios.org"
~path:["setup.php"]
~path:["setup.html"]
~meth:(Eliom_service.Get Eliom_parameter.unit)
()
in
......@@ -1789,8 +1789,14 @@ let election_home election state () =
in
let%lwt middle =
let%lwt result = Web_persist.get_election_result uuid in
let%lwt hidden = Web_persist.get_election_result_hidden uuid in
let%lwt is_admin =
let%lwt metadata = Web_persist.get_election_metadata uuid in
let%lwt site_user = Eliom_reference.get Web_state.site_user in
return (metadata.e_owner = site_user)
in
match result with
| Some r ->
| Some r when hidden = None || is_admin ->
let result = Shape.to_shape_array r.result in
return @@ div [
ul (
......@@ -1809,6 +1815,17 @@ let election_home election state () =
pcdata ".";
];
]
| Some _ ->
let t =
match hidden with
| Some t -> t
| None -> failwith "Impossible case in election_admin"
in
return @@
div [
Printf.ksprintf pcdata L.result_currently_not_public
(format_period l (datetime_sub t now));
]
| None -> return go_to_the_booth
in
let languages =
......@@ -2049,8 +2066,39 @@ let election_admin election metadata state get_tokens_decrypt () =
release_form;
]
| `Tallied ->
let%lwt hidden = Web_persist.get_election_result_hidden uuid in
let form_toggle =
match hidden with
| Some _ ->
post_form ~service:election_show_result
(fun () ->
[input ~input_type:`Submit ~value:"Publish the result now" string]
) uuid
| None ->
post_form ~service:election_hide_result
(fun date ->
[
div [
Printf.ksprintf pcdata "You may postpone the publication of the election result up to %d days in the future." days_to_publish_result;
];
div [
input ~input_type:`Submit ~value:"Postpone publication until" string;
pcdata " ";
input ~name:date ~input_type:`Text string;
];
div [
pcdata "Enter the date in UTC, in format YYYY-MM-DD HH:MM:SS. For example, now is ";
pcdata (String.sub (string_of_datetime (now ())) 1 19);
pcdata ".";
];
]
) uuid
in
return @@ div [
pcdata "This election has been tallied.";
div [pcdata "This election has been tallied."];
br ();
hr ();
form_toggle;
]
| `Archived ->
return @@ div [
......
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