Une MAJ de sécurité est nécessaire sur notre version actuelle. Elle sera effectuée lundi 02/08 entre 12h30 et 13h. L'interruption de service devrait durer quelques minutes (probablement moins de 5 minutes).

Commit 0dfe307a authored by Stephane Glondu's avatar Stephane Glondu
Browse files

Move Web_election contents to Web_persist and Web_site

Rationale: the mutex in Web_election was ineffective. Database
manipulations (and the mutex) have been moved to Web_persist; the rest
has been moved to Web_site.
parent eed63d2f
......@@ -32,6 +32,5 @@ Web_auth_dummy
Web_auth_password
Web_auth_cas
Web_auth_oidc
Web_election
Web_site
Web_main
......@@ -54,18 +54,21 @@ module LwtRandom = struct
end
type cast_error =
| ECastSerialization of exn
| ECastMissingCredential
| ECastInvalidCredential
| ECastProofCheck
| ECastWrongCredential
| ECastRevoteNotAllowed
| ECastReusedCredential
type error =
| Serialization of exn
| ProofCheck
| ElectionClosed
| MissingCredential
| InvalidCredential
| RevoteNotAllowed
| ReusedCredential
| WrongCredential
| UsedCredential
| CredentialNotFound
| UnauthorizedVoter
| CastError of cast_error
exception Error of error
......@@ -74,17 +77,17 @@ let fail e = Lwt.fail (Error e)
let explain_error l e =
let module L = (val l : Web_i18n_sig.LocalizedStrings) in
match e with
| Serialization e -> Printf.sprintf L.error_Serialization (Printexc.to_string e)
| ProofCheck -> L.error_ProofCheck
| ElectionClosed -> L.error_ElectionClosed
| MissingCredential -> L.error_MissingCredential
| InvalidCredential -> L.error_InvalidCredential
| RevoteNotAllowed -> L.error_RevoteNotAllowed
| ReusedCredential -> L.error_ReusedCredential
| WrongCredential -> L.error_WrongCredential
| UsedCredential -> L.error_UsedCredential
| CredentialNotFound -> L.error_CredentialNotFound
| UnauthorizedVoter -> L.error_UnauthorizedVoter
| CastError (ECastSerialization e) -> Printf.sprintf L.error_Serialization (Printexc.to_string e)
| CastError ECastProofCheck -> L.error_ProofCheck
| CastError ECastMissingCredential -> L.error_MissingCredential
| CastError ECastInvalidCredential -> L.error_InvalidCredential
| CastError ECastRevoteNotAllowed -> L.error_RevoteNotAllowed
| CastError ECastReusedCredential -> L.error_ReusedCredential
| CastError ECastWrongCredential -> L.error_WrongCredential
let security_logfile = ref None
......
......@@ -26,18 +26,21 @@ open Web_serializable_t
module LwtRandom : RANDOM with type 'a t = 'a Lwt.t
(** Lwt-compatible random number generation. *)
type cast_error =
| ECastSerialization of exn
| ECastMissingCredential
| ECastInvalidCredential
| ECastProofCheck
| ECastWrongCredential
| ECastRevoteNotAllowed
| ECastReusedCredential
type error =
| Serialization of exn
| ProofCheck
| ElectionClosed
| MissingCredential
| InvalidCredential
| RevoteNotAllowed
| ReusedCredential
| WrongCredential
| UsedCredential
| CredentialNotFound
| UnauthorizedVoter
| CastError of cast_error
exception Error of error
......
(**************************************************************************)
(* BELENIOS *)
(* *)
(* Copyright © 2012-2018 Inria *)
(* *)
(* This program is free software: you can redistribute it and/or modify *)
(* it under the terms of the GNU Affero General Public License as *)
(* published by the Free Software Foundation, either version 3 of the *)
(* License, or (at your option) any later version, with the additional *)
(* exemption that compiling, linking, and/or using OpenSSL is allowed. *)
(* *)
(* This program is distributed in the hope that it will be useful, but *)
(* WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *)
(* Affero General Public License for more details. *)
(* *)
(* You should have received a copy of the GNU Affero General Public *)
(* License along with this program. If not, see *)
(* <http://www.gnu.org/licenses/>. *)
(**************************************************************************)
open Lwt
open Serializable_j
open Signatures
open Common
open Web_serializable_j
open Web_common
module type WEB_BALLOT_BOX = sig
val cast : string -> user * datetime -> string Lwt.t
end
module Make (E : ELECTION with type 'a m = 'a Lwt.t) : WEB_BALLOT_BOX = struct
let uuid = E.election.e_params.e_uuid
module G = E.G
let send_confirmation_email revote user email hash =
let title = E.election.e_params.e_name in
let uuid = E.election.e_params.e_uuid in
let%lwt metadata = Web_persist.get_election_metadata uuid in
let x = (uuid, ()) in
let url1 = Eliom_uri.make_string_uri ~absolute:true
~service:Web_services.election_pretty_ballots x |> rewrite_prefix
in
let url2 = Eliom_uri.make_string_uri ~absolute:true
~service:Web_services.election_home x |> rewrite_prefix
in
let%lwt language = Eliom_reference.get Web_state.language in
let module L = (val Web_i18n.get_lang language) in
let subject = Printf.sprintf L.mail_confirmation_subject title in
let contact = Web_templates.contact_footer metadata L.please_contact in
let revote = if revote then L.this_vote_replaces else "" in
let body = Printf.sprintf L.mail_confirmation user title hash revote url1 url2 contact in
send_email email subject body
let do_cast rawballot (user, date) =
let%lwt voters = read_file ~uuid "voters.txt" in
let%lwt email, login =
let rec loop = function
| x :: xs ->
let email, login = split_identity x in
if login = user.user_name then return (email, login) else loop xs
| [] -> fail UnauthorizedVoter
in loop (match voters with Some xs -> xs | None -> [])
in
let user = string_of_user user in
let%lwt state = Web_persist.get_election_state uuid in
let voting_open = state = `Open in
let%lwt () = if not voting_open then fail ElectionClosed else return_unit in
let%lwt () =
if String.contains rawballot '\n' then (
fail (Serialization (Invalid_argument "multiline ballot"))
) else return_unit
in
let%lwt ballot =
try Lwt.return (ballot_of_string G.read rawballot)
with e -> fail (Serialization e)
in
let%lwt credential =
match ballot.signature with
| Some s -> Lwt.return (G.to_string s.s_public_key)
| None -> fail MissingCredential
in
let%lwt old_cred =
try%lwt Web_persist.find_credential_mapping uuid credential
with Not_found -> fail InvalidCredential
and old_record =
Web_persist.find_extended_record uuid user
in
match old_cred, old_record with
| None, None ->
(* first vote *)
let%lwt b = Lwt_preemptive.detach E.check_ballot ballot in
if b then (
let%lwt hash = Web_persist.add_ballot uuid rawballot in
let%lwt () = Web_persist.add_credential_mapping uuid credential (Some hash) in
let%lwt () = Web_persist.add_extended_record uuid user (date, credential) in
let%lwt () = send_confirmation_email false login email hash in
return hash
) else (
fail ProofCheck
)
| Some h, Some (_, old_credential) ->
(* revote *)
if credential = old_credential then (
let%lwt b = Lwt_preemptive.detach E.check_ballot ballot in
if b then (
let%lwt hash = Web_persist.replace_ballot uuid h rawballot in
let%lwt () = Web_persist.add_credential_mapping uuid credential (Some hash) in
let%lwt () = Web_persist.add_extended_record uuid user (date, credential) in
let%lwt () = send_confirmation_email true login email hash in
return hash
) else (
fail ProofCheck
)
) else (
let%lwt () =
security_log (fun () ->
Printf.sprintf
"%s attempted to revote with already used credential %s"
user credential
)
in
fail WrongCredential
)
| None, Some _ ->
let%lwt () =
security_log (fun () ->
Printf.sprintf
"%s attempted to revote using a new credential %s"
user credential
)
in
fail RevoteNotAllowed
| Some _, None ->
let%lwt () =
security_log (fun () ->
Printf.sprintf
"%s attempted to vote with already used credential %s"
user credential
)
in
fail ReusedCredential
let mutex = Lwt_mutex.create ()
let cast rawballot (user, date) =
Lwt_mutex.with_lock mutex (fun () ->
do_cast rawballot (user, date)
)
end
(**************************************************************************)
(* BELENIOS *)
(* *)
(* Copyright © 2012-2018 Inria *)
(* *)
(* This program is free software: you can redistribute it and/or modify *)
(* it under the terms of the GNU Affero General Public License as *)
(* published by the Free Software Foundation, either version 3 of the *)
(* License, or (at your option) any later version, with the additional *)
(* exemption that compiling, linking, and/or using OpenSSL is allowed. *)
(* *)
(* This program is distributed in the hope that it will be useful, but *)
(* WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *)
(* Affero General Public License for more details. *)
(* *)
(* You should have received a copy of the GNU Affero General Public *)
(* License along with this program. If not, see *)
(* <http://www.gnu.org/licenses/>. *)
(**************************************************************************)
open Signatures
open Web_serializable_t
module type WEB_BALLOT_BOX = sig
val cast : string -> user * datetime -> string Lwt.t
end
module Make (E : ELECTION with type 'a m = 'a Lwt.t) : WEB_BALLOT_BOX
......@@ -348,9 +348,9 @@ let remove_ballot uuid hash =
let ballots_dir = !Web_config.spool_dir / raw_string_of_uuid uuid / "ballots" in
try%lwt Lwt_unix.unlink (ballots_dir / urlize hash) with _ -> return_unit
let replace_ballot uuid hash ballot =
let replace_ballot uuid ~hash ~rawballot =
let%lwt () = remove_ballot uuid hash in
add_ballot uuid ballot
add_ballot uuid rawballot
let compute_encrypted_tally uuid =
let%lwt election = get_raw_election uuid in
......@@ -468,7 +468,7 @@ let init_credential_mapping uuid xs =
let find_credential_mapping uuid cred =
let%lwt xs = credential_mappings_cache#find uuid in
return @@ StringMap.find cred xs
return @@ StringMap.find_opt cred xs
let add_credential_mapping uuid cred mapping =
let%lwt xs = credential_mappings_cache#find uuid in
......@@ -494,3 +494,56 @@ let replace_credential uuid old_ new_ =
let xs = StringMap.add new_ None xs in
credential_mappings_cache#add uuid xs;
dump_credential_mappings uuid xs
let do_cast_ballot election ~rawballot ~user date =
let module E = (val election : ELECTION) in
let uuid = E.election.e_params.e_uuid in
match
try
if String.contains rawballot '\n' then invalid_arg "multiline ballot";
Ok (ballot_of_string E.G.read rawballot)
with e -> Pervasives.Error (ECastSerialization e)
with
| Pervasives.Error _ as x -> return x
| Ok ballot ->
match ballot.signature with
| None -> return (Pervasives.Error ECastMissingCredential)
| Some s ->
let credential = E.G.to_string s.s_public_key in
match%lwt find_credential_mapping uuid credential with
| None -> return (Pervasives.Error ECastInvalidCredential)
| Some old_cred ->
let%lwt old_record = find_extended_record uuid user in
match old_cred, old_record with
| None, None ->
(* first vote *)
if%lwt Lwt_preemptive.detach E.check_ballot ballot then (
let%lwt hash = add_ballot uuid rawballot in
let%lwt () = add_credential_mapping uuid credential (Some hash) in
let%lwt () = add_extended_record uuid user (date, credential) in
return (Ok (hash, false))
) else return (Pervasives.Error ECastProofCheck)
| Some hash, Some (_, old_credential) ->
(* revote *)
if credential = old_credential then (
if%lwt Lwt_preemptive.detach E.check_ballot ballot then (
let%lwt hash = replace_ballot uuid ~hash ~rawballot in
let%lwt () = add_credential_mapping uuid credential (Some hash) in
let%lwt () = add_extended_record uuid user (date, credential) in
return (Ok (hash, true))
) else return (Pervasives.Error ECastProofCheck)
) else return (Pervasives.Error ECastWrongCredential)
| None, Some _ -> return (Pervasives.Error ECastRevoteNotAllowed)
| Some _, None -> return (Pervasives.Error ECastReusedCredential)
let cast_mutex = Lwt_mutex.create ()
let cast_ballot uuid ~rawballot ~user date =
match%lwt get_raw_election uuid with
| None -> Lwt.fail Not_found
| Some raw_election ->
let election = Election.of_string raw_election in
let module W = (val Election.get_group election) in
let module E = Election.Make (W) (LwtRandom) in
Lwt_mutex.with_lock cast_mutex
(fun () -> do_cast_ballot (module E) ~rawballot ~user date)
......@@ -22,6 +22,7 @@
open Serializable_t
open Common
open Web_serializable_t
open Web_common
val get_draft_election : uuid -> draft_election option Lwt.t
val set_draft_election : uuid -> draft_election -> unit Lwt.t
......@@ -76,16 +77,11 @@ val get_threshold : uuid -> string option Lwt.t
val get_ballot_hashes : uuid -> string list Lwt.t
val get_ballot_by_hash : uuid -> string -> string option Lwt.t
val add_ballot : uuid -> string -> string Lwt.t
val replace_ballot : uuid -> string -> string -> string Lwt.t
val compute_encrypted_tally : uuid -> (int * string * string) option Lwt.t
val find_extended_record : uuid -> string -> (datetime * string) option Lwt.t
val add_extended_record : uuid -> string -> datetime * string -> unit Lwt.t
val has_voted : uuid -> user -> bool Lwt.t
val init_credential_mapping : uuid -> string list -> unit Lwt.t
val find_credential_mapping : uuid -> string -> string option Lwt.t
val add_credential_mapping : uuid -> string -> string option -> unit Lwt.t
val replace_credential : uuid -> string -> string -> unit Lwt.t
val cast_ballot : uuid -> rawballot:string -> user:string -> datetime -> (string * bool, cast_error) Pervasives.result Lwt.t
......@@ -1403,31 +1403,75 @@ let () =
submit_ballot ballot
)
let send_confirmation_email uuid revote user email hash =
let%lwt election = find_election uuid in
let title = election.e_params.e_name in
let%lwt metadata = Web_persist.get_election_metadata uuid in
let x = (uuid, ()) in
let url1 = Eliom_uri.make_string_uri ~absolute:true
~service:Web_services.election_pretty_ballots x |> rewrite_prefix
in
let url2 = Eliom_uri.make_string_uri ~absolute:true
~service:Web_services.election_home x |> rewrite_prefix
in
let%lwt language = Eliom_reference.get Web_state.language in
let module L = (val Web_i18n.get_lang language) in
let subject = Printf.sprintf L.mail_confirmation_subject title in
let contact = Web_templates.contact_footer metadata L.please_contact in
let revote = if revote then L.this_vote_replaces else "" in
let body = Printf.sprintf L.mail_confirmation user title hash revote url1 url2 contact in
send_email email subject body
let cast_ballot uuid ~rawballot ~user =
let%lwt voters = read_file ~uuid "voters.txt" in
let%lwt email, login =
let rec loop = function
| x :: xs ->
let email, login = split_identity x in
if login = user.user_name then return (email, login) else loop xs
| [] -> fail UnauthorizedVoter
in loop (match voters with Some xs -> xs | None -> [])
in
let user = string_of_user user in
let%lwt state = Web_persist.get_election_state uuid in
let voting_open = state = `Open in
let%lwt () = if not voting_open then fail ElectionClosed else return_unit in
match%lwt Web_persist.cast_ballot uuid ~rawballot ~user (now ()) with
| Ok (hash, revote) ->
let%lwt () = send_confirmation_email uuid revote login email hash in
return hash
| Pervasives.Error e ->
let msg = match e with
| ECastWrongCredential -> Some "attempted to revote with already used credential"
| ECastRevoteNotAllowed -> Some "attempted to revote using a new credential"
| ECastReusedCredential -> Some "attempted to vote with already used credential"
| _ -> None
in
let%lwt () = match msg with
| Some msg -> security_log (fun () -> user ^ " " ^ msg)
| None -> return_unit
in
fail (CastError e)
let () =
Any.register ~service:election_cast_confirm
(fun uuid () ->
let%lwt election = find_election uuid in
let module W = (val Election.get_group election) in
let module E = Election.Make (W) (LwtRandom) in
let module B = Web_election.Make (E) in
match%lwt Eliom_reference.get Web_state.ballot with
| Some the_ballot ->
begin
let%lwt () = Eliom_reference.unset Web_state.ballot in
match%lwt Web_state.get_election_user uuid with
| Some u ->
let record = u, now () in
let%lwt result =
try%lwt
let%lwt hash = B.cast the_ballot record in
return (`Valid hash)
with Error e -> return (`Error e)
in
let%lwt () = Eliom_reference.set Web_state.cast_confirmed (Some result) in
redir_preapply election_home (uuid, ()) ()
| None -> forbidden ()
end
| None -> fail_http 404)
| None -> fail_http 404
| Some rawballot ->
let%lwt () = Eliom_reference.unset Web_state.ballot in
match%lwt Web_state.get_election_user uuid with
| None -> forbidden ()
| Some user ->
let%lwt result =
try%lwt
let%lwt hash = cast_ballot uuid ~rawballot ~user in
return (`Valid hash)
with Error e -> return (`Error e)
in
let%lwt () = Eliom_reference.set Web_state.cast_confirmed (Some result) in
redir_preapply election_home (uuid, ()) ()
)
let () =
Any.register ~service:election_pretty_ballots
......
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