Commit 919b3281 authored by Stephane Glondu's avatar Stephane Glondu

Do no longer rely on Ocsipersist for credential management

parent 83b27c28
......@@ -197,9 +197,6 @@ let generate_token ?(length=14) () =
let string_of_user {user_domain; user_name} =
user_domain ^ ":" ^ user_name
let underscorize x =
String.map (function '-' -> '_' | c -> c) (raw_string_of_uuid x)
let sendmail ?return_path message =
let mailer =
match return_path with
......
......@@ -94,8 +94,6 @@ val generate_token : ?length:int -> unit -> string Lwt.t
val string_of_user : user -> string
val underscorize : uuid -> string
val send_email : string -> string -> string -> unit Lwt.t
val split_identity : string -> string * string
......
......@@ -21,7 +21,6 @@
open Lwt
open Platform
open Serializable_builtin_t
open Serializable_j
open Signatures
open Common
......@@ -29,24 +28,12 @@ open Web_serializable_j
open Web_signatures
open Web_common
let ( / ) = Filename.concat
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 uuid_u = underscorize uuid
let cred_table = Ocsipersist.open_table ("creds_" ^ uuid_u)
let inject_cred cred =
try%lwt
let%lwt _ = Ocsipersist.find cred_table cred in
failwith "trying to add duplicate credential"
with Not_found ->
Ocsipersist.add cred_table cred None
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
......@@ -93,7 +80,7 @@ module Make (E : ELECTION with type 'a m = 'a Lwt.t) : WEB_BALLOT_BOX = struct
| None -> fail MissingCredential
in
let%lwt old_cred =
try%lwt Ocsipersist.find cred_table credential
try%lwt Web_persist.find_credential_mapping uuid credential
with Not_found -> fail InvalidCredential
and old_record =
Web_persist.find_extended_record uuid user
......@@ -104,7 +91,7 @@ module Make (E : ELECTION with type 'a m = 'a Lwt.t) : WEB_BALLOT_BOX = struct
let%lwt b = Lwt_preemptive.detach E.check_ballot ballot in
if b then (
let hash = sha256_b64 rawballot in
Ocsipersist.add cred_table credential (Some hash) >>
Web_persist.add_credential_mapping uuid credential (Some hash) >>
Web_persist.add_ballot uuid hash rawballot >>
Web_persist.add_extended_record uuid user (date, credential) >>
send_confirmation_email false login email hash >>
......@@ -119,7 +106,7 @@ module Make (E : ELECTION with type 'a m = 'a Lwt.t) : WEB_BALLOT_BOX = struct
if b then (
Web_persist.remove_ballot uuid h >>
let hash = sha256_b64 rawballot in
Ocsipersist.add cred_table credential (Some hash) >>
Web_persist.add_credential_mapping uuid credential (Some hash) >>
Web_persist.add_ballot uuid hash rawballot >>
Web_persist.add_extended_record uuid user (date, credential) >>
send_confirmation_email true login email hash >>
......@@ -141,32 +128,9 @@ module Make (E : ELECTION with type 'a m = 'a Lwt.t) : WEB_BALLOT_BOX = struct
Printf.sprintf "%s attempted to vote with already used credential %s" user credential
) >> fail ReusedCredential
let do_update_cred ~old ~new_ =
match%lwt Ocsipersist.fold_step (fun k v x ->
if sha256_hex k = old then (
match v with
| Some _ -> fail UsedCredential
| None -> return (Some k)
) else return x
) cred_table None with
| None -> fail CredentialNotFound
| Some x ->
Ocsipersist.remove cred_table x >>
Ocsipersist.add cred_table new_ None
let do_write f =
Lwt_io.(with_file ~mode:Output (!spool_dir / raw_string_of_uuid uuid / string_of_election_file f))
let do_write_ballots () =
Web_persist.dump_ballots uuid
let do_write_creds () =
do_write ESCreds (fun oc ->
Ocsipersist.iter_step (fun x _ ->
Lwt_io.write_line oc x
) cred_table
)
let mutex = Lwt_mutex.create ()
let cast rawballot (user, date) =
......@@ -176,16 +140,9 @@ module Make (E : ELECTION with type 'a m = 'a Lwt.t) : WEB_BALLOT_BOX = struct
return r
)
let update_cred ~old ~new_ =
Lwt_mutex.with_lock mutex (fun () ->
let%lwt r = do_update_cred ~old ~new_ in
do_write_creds () >> return r
)
let update_files () =
Lwt_mutex.with_lock mutex (fun () ->
do_write_ballots () >>
do_write_creds ()
do_write_ballots ()
)
end
......@@ -319,3 +319,76 @@ let add_extended_record uuid username r =
let has_voted uuid user =
let%lwt rs = extended_records_cache#find uuid in
return @@ StringMap.mem (string_of_user user) rs
module CredMappingsCacheTypes = struct
type key = uuid
type value = string option StringMap.t
end
module CredMappingsCache = Ocsigen_cache.Make (CredMappingsCacheTypes)
let raw_get_credential_mappings uuid =
match%lwt read_file ~uuid "credential_mappings.jsons" with
| Some xs ->
let xs = List.map credential_mapping_of_string xs in
return (
List.fold_left (fun accu x ->
StringMap.add x.c_credential x.c_ballot accu
) StringMap.empty xs
)
| None -> return StringMap.empty
let dump_credential_mappings uuid xs =
let xs = StringMap.bindings xs in
let mappings =
List.map (fun (c_credential, c_ballot) ->
string_of_credential_mapping {c_credential; c_ballot}
) xs
in
let creds = List.map fst xs in
write_file ~uuid "credential_mappings.jsons" mappings >>
write_file ~uuid "public_creds.txt" creds
let credential_mappings_cache =
new CredMappingsCache.cache raw_get_credential_mappings ~timer:3600. 10
let init_credential_mapping uuid xs =
let xs =
List.fold_left (fun accu x ->
if StringMap.mem x accu then
failwith "trying to add duplicate credential"
else
StringMap.add x None accu
) StringMap.empty xs
in
credential_mappings_cache#add uuid xs;
dump_credential_mappings uuid xs
let find_credential_mapping uuid cred =
let%lwt xs = credential_mappings_cache#find uuid in
return @@ StringMap.find cred xs
let add_credential_mapping uuid cred mapping =
let%lwt xs = credential_mappings_cache#find uuid in
let xs = StringMap.add cred mapping xs in
credential_mappings_cache#add uuid xs;
dump_credential_mappings uuid xs
let replace_credential uuid old_ new_ =
let%lwt xs = credential_mappings_cache#find uuid in
let old_cred =
StringMap.fold (fun k v accu ->
if sha256_hex k = old_ then (
match v with
| Some _ -> raise (Error UsedCredential)
| None -> Some k
) else accu
) xs None
in
match old_cred with
| None -> fail CredentialNotFound
| Some old_cred ->
let xs = StringMap.remove old_cred xs in
let xs = StringMap.add new_ None xs in
credential_mappings_cache#add uuid xs;
dump_credential_mappings uuid xs
......@@ -73,3 +73,8 @@ 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
......@@ -69,6 +69,11 @@ type extended_record = {
credential : string;
} <ocaml field_prefix="r_">
type credential_mapping = {
credential : string;
?ballot : string option;
} <ocaml field_prefix="c_">
(** {1 Types related to elections being prepared} *)
type draft_voter = {
......
......@@ -58,7 +58,5 @@ type content =
module type WEB_BALLOT_BOX = sig
val cast : string -> user * datetime -> string Lwt.t
val inject_cred : string -> unit Lwt.t
val update_files : unit -> unit Lwt.t
val update_cred : old:string -> new_:string -> unit Lwt.t
end
......@@ -200,14 +200,13 @@ let validate_election uuid se =
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
(* inject credentials *)
(* initialize credentials *)
let%lwt () =
let fname = !spool_dir / uuid_s ^ ".public_creds.txt" in
match%lwt read_file fname with
| Some xs ->
Lwt_list.iter_s B.inject_cred xs
>> B.update_files ()
>> Lwt_unix.unlink fname
Web_persist.init_credential_mapping uuid xs >>
Lwt_unix.unlink fname
| None -> return_unit
in
(* create file with private keys, if any *)
......@@ -252,12 +251,11 @@ let cleanup_file f =
let delete_sensitive_data uuid =
let uuid_s = raw_string_of_uuid uuid in
let uuid_u = underscorize uuid in
let%lwt () = cleanup_table ~uuid_s "election_states" in
let%lwt () = cleanup_table ~uuid_s "site_tokens_decrypt" in
let%lwt () = cleanup_table ~uuid_s "election_pds" in
let%lwt () = cleanup_file (!spool_dir / uuid_s / "extended_records.jsons") in
let%lwt () = cleanup_table ("creds_" ^ uuid_u) in
let%lwt () = cleanup_file (!spool_dir / uuid_s / "credential_mappings.jsons") in
let%lwt () = rmdir (!spool_dir / uuid_s / "ballots") in
let%lwt () = cleanup_file (!spool_dir / uuid_s / "private_key.json") in
let%lwt () = cleanup_file (!spool_dir / uuid_s / "private_keys.jsons") in
......@@ -1343,14 +1341,10 @@ let () =
Any.register ~service:election_update_credential_post
(fun (uuid, ()) (old, new_) ->
with_site_user (fun u ->
let%lwt election = find_election uuid in
let%lwt metadata = Web_persist.get_election_metadata 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
if metadata.e_owner = Some u then (
try%lwt
B.update_cred ~old ~new_ >>
Web_persist.replace_credential uuid old new_ >>
String.send ("OK", "text/plain")
with Error e ->
let%lwt lang = Eliom_reference.get Web_state.language in
......
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