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 494a4d54 authored by Stephane Glondu's avatar Stephane Glondu
Browse files

Add Web_common.{read,write}_file and use them

parent b785f4aa
...@@ -238,3 +238,23 @@ let email_rex = Pcre.regexp ...@@ -238,3 +238,23 @@ let email_rex = Pcre.regexp
let is_email x = let is_email x =
try ignore (Pcre.pcre_exec ~rex:email_rex x); true try ignore (Pcre.pcre_exec ~rex:email_rex x); true
with Not_found -> false with Not_found -> false
let get_fname uuid x =
match uuid with
| None -> x
| Some uuid ->
let ( / ) = Filename.concat in
!spool_dir / raw_string_of_uuid uuid / x
let read_file ?uuid x =
try%lwt
let%lwt lines = Lwt_io.lines_of_file (get_fname uuid x) |> Lwt_stream.to_list in
return (Some lines)
with _ -> return_none
let write_file ?uuid x lines =
Lwt_io.(
with_file Output (get_fname uuid x) (fun oc ->
Lwt_list.iter_s (write_line oc) lines
)
)
...@@ -101,3 +101,6 @@ val string_of_languages : string list option -> string ...@@ -101,3 +101,6 @@ val string_of_languages : string list option -> string
val languages_of_string : string -> string list val languages_of_string : string -> string list
val is_email : string -> bool val is_email : string -> bool
val read_file : ?uuid:uuid -> string -> string list option Lwt.t
val write_file : ?uuid:uuid -> string -> string list -> unit Lwt.t
...@@ -65,15 +65,14 @@ module Make (E : ELECTION with type 'a m = 'a Lwt.t) : WEB_BALLOT_BOX = struct ...@@ -65,15 +65,14 @@ module Make (E : ELECTION with type 'a m = 'a Lwt.t) : WEB_BALLOT_BOX = struct
send_email email subject body send_email email subject body
let do_cast rawballot (user, date) = let do_cast rawballot (user, date) =
let voters = Lwt_io.lines_of_file (!spool_dir / raw_string_of_uuid uuid / "voters.txt") in let%lwt voters = read_file ~uuid "voters.txt" in
let%lwt voters = Lwt_stream.to_list voters in
let%lwt email, login = let%lwt email, login =
let rec loop = function let rec loop = function
| x :: xs -> | x :: xs ->
let email, login = split_identity x in let email, login = split_identity x in
if login = user.user_name then return (email, login) else loop xs if login = user.user_name then return (email, login) else loop xs
| [] -> fail UnauthorizedVoter | [] -> fail UnauthorizedVoter
in loop voters in loop (match voters with Some xs -> xs | None -> [])
in in
let user = string_of_user user in let user = string_of_user user in
let%lwt state = Web_persist.get_election_state uuid in let%lwt state = Web_persist.get_election_state uuid in
......
...@@ -30,11 +30,9 @@ open Web_common ...@@ -30,11 +30,9 @@ open Web_common
let ( / ) = Filename.concat let ( / ) = Filename.concat
let get_election_result uuid = let get_election_result uuid =
try%lwt match%lwt read_file ~uuid "result.json" with
Lwt_io.chars_of_file (!spool_dir / raw_string_of_uuid uuid / "result.json") |> | Some [x] -> return (Some (result_of_string Yojson.Safe.read_json x))
Lwt_stream.to_string >>= fun x -> | _ -> return_none
return @@ Some (result_of_string (Yojson.Safe.from_lexbuf ~stream:true) x)
with _ -> return_none
type election_state = type election_state =
[ `Open [ `Open
...@@ -56,19 +54,15 @@ let set_election_state x s = ...@@ -56,19 +54,15 @@ let set_election_state x s =
let past = datetime_of_string "\"2015-10-01 00:00:00.000000\"" let past = datetime_of_string "\"2015-10-01 00:00:00.000000\""
let set_election_date uuid d = let set_election_date uuid d =
let dates = { e_finalization = d } in let dates = string_of_election_dates { e_finalization = d } in
Lwt_io.(with_file Output (!spool_dir / raw_string_of_uuid uuid / "dates.json") (fun oc -> write_file ~uuid "dates.json" [dates]
write_line oc (string_of_election_dates dates)
))
let get_election_date uuid = let get_election_date uuid =
try%lwt match%lwt read_file ~uuid "dates.json" with
Lwt_io.chars_of_file (!spool_dir / raw_string_of_uuid uuid / "dates.json") |> | Some [x] ->
Lwt_stream.to_string >>= fun x -> let dates = election_dates_of_string x in
let dates = election_dates_of_string x in return dates.e_finalization
return dates.e_finalization | _ -> return past
with _ ->
return past
let election_pds = Ocsipersist.open_table "election_pds" let election_pds = Ocsipersist.open_table "election_pds"
...@@ -93,13 +87,9 @@ let set_auth_config x c = ...@@ -93,13 +87,9 @@ let set_auth_config x c =
Ocsipersist.add auth_configs (key_of_uuid_option x) c Ocsipersist.add auth_configs (key_of_uuid_option x) c
let get_raw_election uuid = let get_raw_election uuid =
try%lwt match%lwt read_file ~uuid "election.json" with
let lines = Lwt_io.lines_of_file (!spool_dir / raw_string_of_uuid uuid / "election.json") in | Some [x] -> return (Some x)
begin match%lwt Lwt_stream.to_list lines with | _ -> return_none
| x :: _ -> return @@ Some x
| [] -> return_none
end
with _ -> return_none
let empty_metadata = { let empty_metadata = {
e_owner = None; e_owner = None;
...@@ -112,11 +102,9 @@ let empty_metadata = { ...@@ -112,11 +102,9 @@ let empty_metadata = {
let return_empty_metadata = return empty_metadata let return_empty_metadata = return empty_metadata
let get_election_metadata uuid = let get_election_metadata uuid =
try%lwt match%lwt read_file ~uuid "metadata.json" with
Lwt_io.chars_of_file (!spool_dir / raw_string_of_uuid uuid / "metadata.json") |> | Some [x] -> return (metadata_of_string x)
Lwt_stream.to_string >>= fun x -> | _ -> return_empty_metadata
return @@ metadata_of_string x
with _ -> return_empty_metadata
let get_elections_by_owner user = let get_elections_by_owner user =
Lwt_unix.files_of_directory !spool_dir |> Lwt_unix.files_of_directory !spool_dir |>
...@@ -137,11 +125,7 @@ let get_elections_by_owner user = ...@@ -137,11 +125,7 @@ let get_elections_by_owner user =
Lwt_stream.to_list Lwt_stream.to_list
let get_voters uuid = let get_voters uuid =
try%lwt read_file ~uuid "voters.txt"
let lines = Lwt_io.lines_of_file (!spool_dir / raw_string_of_uuid uuid / "voters.txt") in
let%lwt lines = Lwt_stream.to_list lines in
return @@ Some lines
with _ -> return_none
let get_passwords uuid = let get_passwords uuid =
let csv = let csv =
...@@ -160,25 +144,15 @@ let get_passwords uuid = ...@@ -160,25 +144,15 @@ let get_passwords uuid =
return @@ Some res return @@ Some res
let get_public_keys uuid = let get_public_keys uuid =
try%lwt read_file ~uuid "public_keys.jsons"
let lines = Lwt_io.lines_of_file (!spool_dir / raw_string_of_uuid uuid / "public_keys.jsons") in
let%lwt lines = Lwt_stream.to_list lines in
return @@ Some lines
with _ -> return_none
let get_private_keys uuid = let get_private_keys uuid =
try%lwt read_file ~uuid "private_keys.jsons"
let lines = Lwt_io.lines_of_file (!spool_dir / raw_string_of_uuid uuid / "private_keys.jsons") in
let%lwt lines = Lwt_stream.to_list lines in
return @@ Some lines
with _ -> return_none
let get_threshold uuid = let get_threshold uuid =
try%lwt match%lwt read_file ~uuid "threshold.json" with
Lwt_io.chars_of_file (!spool_dir / raw_string_of_uuid uuid / "threshold.json") |> | Some [x] -> return (Some x)
Lwt_stream.to_string >>= fun x -> | _ -> return_none
return (Some x)
with _ -> return_none
module Ballots = Map.Make (String) module Ballots = Map.Make (String)
...@@ -190,13 +164,15 @@ end ...@@ -190,13 +164,15 @@ end
module BallotsCache = Ocsigen_cache.Make (BallotsCacheTypes) module BallotsCache = Ocsigen_cache.Make (BallotsCacheTypes)
let raw_get_ballots_archived uuid = let raw_get_ballots_archived uuid =
try%lwt match%lwt read_file ~uuid "ballots.jsons" with
let ballots = Lwt_io.lines_of_file (!spool_dir / raw_string_of_uuid uuid / "ballots.jsons") in | Some bs ->
Lwt_stream.fold (fun b accu -> return (
let hash = sha256_b64 b in List.fold_left (fun accu b ->
Ballots.add hash b accu let hash = sha256_b64 b in
) ballots Ballots.empty Ballots.add hash b accu
with _ -> return Ballots.empty ) Ballots.empty bs
)
| None -> return Ballots.empty
let archived_ballots_cache = let archived_ballots_cache =
new BallotsCache.cache raw_get_ballots_archived 10 new BallotsCache.cache raw_get_ballots_archived 10
......
...@@ -205,10 +205,12 @@ let finalize_election uuid se = ...@@ -205,10 +205,12 @@ let finalize_election uuid se =
(* inject credentials *) (* inject credentials *)
let%lwt () = let%lwt () =
let fname = !spool_dir / uuid_s ^ ".public_creds.txt" in let fname = !spool_dir / uuid_s ^ ".public_creds.txt" in
Lwt_io.lines_of_file fname |> match%lwt read_file fname with
Lwt_stream.iter_s B.inject_cred >> | Some xs ->
B.update_files () >> Lwt_list.iter_s B.inject_cred xs
Lwt_unix.unlink fname >> B.update_files ()
>> Lwt_unix.unlink fname
| None -> return_unit
in in
(* create file with private keys, if any *) (* create file with private keys, if any *)
let%lwt () = let%lwt () =
...@@ -635,8 +637,6 @@ let is_identity x = ...@@ -635,8 +637,6 @@ let is_identity x =
try ignore (Pcre.pcre_exec ~rex:identity_rex x); true try ignore (Pcre.pcre_exec ~rex:identity_rex x); true
with Not_found -> false with Not_found -> false
module SSet = Set.Make (PString)
let merge_voters a b f = let merge_voters a b f =
let existing = List.fold_left (fun accu sv -> let existing = List.fold_left (fun accu sv ->
SSet.add sv.sv_id accu SSet.add sv.sv_id accu
...@@ -768,15 +768,19 @@ let handle_credentials_post token creds = ...@@ -768,15 +768,19 @@ let handle_credentials_post token creds =
) >> ) >>
let%lwt () = let%lwt () =
let i = ref 1 in let i = ref 1 in
Lwt_stream.iter match%lwt read_file fname with
(fun x -> | Some xs ->
try return (
let x = G.of_string x in List.iter (fun x ->
if not (G.check x) then raise Exit; try
incr i let x = G.of_string x in
with _ -> if not (G.check x) then raise Exit;
Printf.ksprintf failwith "invalid credential at line %d" !i) incr i
(Lwt_io.lines_of_file fname) with _ ->
Printf.ksprintf failwith "invalid credential at line %d" !i
) xs
)
| None -> return_unit
in in
let () = se.se_metadata <- {se.se_metadata with e_cred_authority = None} in let () = se.se_metadata <- {se.se_metadata with e_cred_authority = None} in
let () = se.se_public_creds_received <- true in let () = se.se_public_creds_received <- true in
...@@ -818,7 +822,6 @@ let () = ...@@ -818,7 +822,6 @@ let () =
~absolute:true ~service:election_home ~absolute:true ~service:election_home
(uuid, ()) |> rewrite_prefix (uuid, ()) |> rewrite_prefix
in in
let module S = Set.Make (PString) in
let module G = (val Group.of_string se.se_group : GROUP) in let module G = (val Group.of_string se.se_group : GROUP) in
let module CD = Credential.MakeDerive (G) in let module CD = Credential.MakeDerive (G) in
let%lwt creds = let%lwt creds =
...@@ -843,10 +846,10 @@ let () = ...@@ -843,10 +846,10 @@ let () =
Printf.sprintf L.mail_credential_subject title Printf.sprintf L.mail_credential_subject title
in in
let%lwt () = send_email email subject body in let%lwt () = send_email email subject body in
return @@ S.add pub_cred accu return @@ SSet.add pub_cred accu
) S.empty se.se_voters ) SSet.empty se.se_voters
in in
let creds = S.elements creds in let creds = SSet.elements creds in
let fname = !spool_dir / raw_string_of_uuid uuid ^ ".public_creds.txt" in let fname = !spool_dir / raw_string_of_uuid uuid ^ ".public_creds.txt" in
let%lwt () = let%lwt () =
Lwt_io.with_file Lwt_io.with_file
...@@ -1262,27 +1265,33 @@ let () = ...@@ -1262,27 +1265,33 @@ let () =
Any.register ~service:election_missing_voters Any.register ~service:election_missing_voters
(fun (uuid, ()) () -> (fun (uuid, ()) () ->
with_site_user (fun u -> with_site_user (fun u ->
let uuid_s = raw_string_of_uuid uuid in
let%lwt metadata = Web_persist.get_election_metadata uuid in let%lwt metadata = Web_persist.get_election_metadata uuid in
if metadata.e_owner = Some u then ( if metadata.e_owner = Some u then (
let voters = Lwt_io.lines_of_file let%lwt voters =
(!spool_dir / uuid_s / string_of_election_file ESVoters) match%lwt read_file ~uuid (string_of_election_file ESVoters) with
| Some vs ->
return (
List.fold_left (fun accu v ->
let _, login = split_identity v in
SSet.add login accu
) SSet.empty vs
)
| None -> return SSet.empty
in in
let module S = Set.Make (PString) in let%lwt voters =
let%lwt voters = Lwt_stream.fold (fun v accu -> match%lwt read_file ~uuid (string_of_election_file ESRecords) with
let _, login = split_identity v in | Some rs ->
S.add login accu return (
) voters S.empty in List.fold_left (fun accu r ->
let records = Lwt_io.lines_of_file let s = Pcre.exec ~rex r in
(!spool_dir / uuid_s / string_of_election_file ESRecords) let v = Pcre.get_substring s 1 in
SSet.remove v accu
) voters rs
)
| None -> return voters
in in
let%lwt voters = Lwt_stream.fold (fun r accu ->
let s = Pcre.exec ~rex r in
let v = Pcre.get_substring s 1 in
S.remove v accu
) records voters in
let buf = Buffer.create 128 in let buf = Buffer.create 128 in
S.iter (fun v -> SSet.iter (fun v ->
Buffer.add_string buf v; Buffer.add_string buf v;
Buffer.add_char buf '\n' Buffer.add_char buf '\n'
) voters; ) voters;
...@@ -1299,15 +1308,19 @@ let () = ...@@ -1299,15 +1308,19 @@ let () =
let%lwt w = find_election uuid in let%lwt w = find_election uuid in
let%lwt metadata = Web_persist.get_election_metadata uuid in let%lwt metadata = Web_persist.get_election_metadata uuid in
if metadata.e_owner = Some u then ( if metadata.e_owner = Some u then (
let records = Lwt_io.lines_of_file let%lwt records =
(!spool_dir / raw_string_of_uuid uuid / string_of_election_file ESRecords) match%lwt read_file ~uuid (string_of_election_file ESRecords) with
| Some rs ->
return (
List.rev_map (fun r ->
let s = Pcre.exec ~rex r in
let date = Pcre.get_substring s 1 in
let voter = Pcre.get_substring s 2 in
(date, voter)
) rs
)
| None -> return []
in in
let%lwt records = Lwt_stream.fold (fun r accu ->
let s = Pcre.exec ~rex r in
let date = Pcre.get_substring s 1 in
let voter = Pcre.get_substring s 2 in
(date, voter) :: accu
) records [] in
T.pretty_records w (List.rev records) () >>= Html5.send T.pretty_records w (List.rev records) () >>= Html5.send
) else forbidden () ) else forbidden ()
) )
...@@ -1451,10 +1464,8 @@ let handle_election_tally_release (uuid, ()) () = ...@@ -1451,10 +1464,8 @@ let handle_election_tally_release (uuid, ()) () =
in in
let result = E.compute_result ntallied et pds combinator in let result = E.compute_result ntallied et pds combinator in
let%lwt () = let%lwt () =
let open Lwt_io in let result = string_of_result W.G.write result in
with_file write_file ~uuid (string_of_election_file ESResult) [result]
~mode:Output (!spool_dir / uuid_s / string_of_election_file ESResult)
(fun oc -> Lwt_io.write_line oc (string_of_result W.G.write result))
in in
let%lwt () = Web_persist.set_election_state uuid (`Tallied result.result) in let%lwt () = Web_persist.set_election_state uuid (`Tallied result.result) in
let%lwt () = Ocsipersist.remove election_tokens_decrypt uuid_s in let%lwt () = Ocsipersist.remove election_tokens_decrypt uuid_s in
...@@ -1525,9 +1536,9 @@ let () = ...@@ -1525,9 +1536,9 @@ let () =
if the (single) key is known *) if the (single) key is known *)
let skfile = !spool_dir / raw_string_of_uuid uuid / "private_key.json" in let skfile = !spool_dir / raw_string_of_uuid uuid / "private_key.json" in
if npks = 1 && Sys.file_exists skfile then ( if npks = 1 && Sys.file_exists skfile then (
let%lwt sk = Lwt_io.lines_of_file skfile |> Lwt_stream.to_list in let%lwt sk = read_file skfile in
let sk = match sk with let sk = match sk with
| [sk] -> number_of_string sk | Some [sk] -> number_of_string sk
| _ -> failwith "several private keys are available" | _ -> failwith "several private keys are available"
in in
let tally = encrypted_tally_of_string W.G.read tally in let tally = encrypted_tally_of_string W.G.read tally 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