Commit c2046470 authored by Stephane Glondu's avatar Stephane Glondu

Send warnings by mail before automatic actions

parent 1a5031aa
......@@ -244,14 +244,26 @@ let string_of_languages xs =
let languages_of_string x =
Pcre.split x
let email_rex = Pcre.regexp
~flags:[`CASELESS]
"^[A-Z0-9._%+-]+@[A-Z0-9.-]+\\.[A-Z]{2,7}$"
let email_rex = "[A-Z0-9._%+-]+@[A-Z0-9.-]+\\.[A-Z]{2,}"
let is_email x =
try ignore (Pcre.pcre_exec ~rex:email_rex x); true
let is_email =
let rex = Pcre.regexp ~flags:[`CASELESS] ("^" ^ email_rex ^ "$") in
fun x ->
try ignore (Pcre.pcre_exec ~rex x); true
with Not_found -> false
let extract_email =
let rex = Pcre.regexp ~flags:[`CASELESS] ("<(" ^ email_rex ^ ")>") in
fun x ->
if is_email x then
Some x
else (
try
let s = Pcre.exec ~rex x in
Some (Pcre.get_substring s 1)
with Not_found -> None
)
let get_fname uuid x =
match uuid with
| None -> x
......@@ -292,3 +304,5 @@ let default_archive_date = datetime_of_string "\"2018-06-06 00:00:00.000000\""
let days_to_archive = 14
let days_to_delete = 365
let days_to_mail = 30
let days_between_mails = 7
......@@ -105,6 +105,7 @@ val string_of_languages : string list option -> string
val languages_of_string : string -> string list
val is_email : string -> bool
val extract_email : string -> string option
val read_file : ?uuid:uuid -> string -> string list option Lwt.t
val write_file : ?uuid:uuid -> string -> string list -> unit Lwt.t
......@@ -119,3 +120,5 @@ val default_archive_date : datetime
val days_to_archive : int
val days_to_delete : int
val days_to_mail : int
val days_between_mails : int
......@@ -56,6 +56,7 @@ type election_date =
| `Validation
| `Tally
| `Archive
| `LastMail
]
let get_election_dates uuid =
......@@ -66,6 +67,7 @@ let get_election_dates uuid =
e_finalization = None;
e_tally = None;
e_archive = None;
e_last_mail = None;
}
let set_election_date kind uuid d =
......@@ -75,6 +77,7 @@ let set_election_date kind uuid d =
| `Validation -> { dates with e_finalization = Some d }
| `Tally -> { dates with e_tally = Some d }
| `Archive -> { dates with e_archive = Some d }
| `LastMail -> { dates with e_last_mail = Some d }
in
let dates = string_of_election_dates dates in
write_file ~uuid "dates.json" [dates]
......@@ -86,6 +89,7 @@ let get_election_date kind uuid =
| `Validation -> return dates.e_finalization
| `Tally -> return dates.e_tally
| `Archive -> return dates.e_archive
| `LastMail -> return dates.e_last_mail
let election_pds = Ocsipersist.open_table "election_pds"
......
......@@ -38,6 +38,7 @@ type election_date =
| `Validation
| `Tally
| `Archive
| `LastMail
]
val get_election_date : election_date -> uuid -> datetime option Lwt.t
val set_election_date : election_date -> uuid -> datetime -> unit Lwt.t
......
......@@ -60,6 +60,7 @@ type election_dates = {
?finalization : datetime option;
?tally : datetime option;
?archive : datetime option;
?last_mail : datetime option;
} <ocaml field_prefix="e_">
(** {1 Types related to elections being prepared} *)
......
......@@ -2028,68 +2028,110 @@ let () =
)
)
let get_all_validated_election_dates () =
let extract_automatic_data_validated uuid_s =
let uuid = uuid_of_raw_string uuid_s in
let%lwt election = Web_persist.get_raw_election uuid in
match election with
| None -> return_none
| Some election ->
let election = Election.of_string election in
let%lwt metadata = Web_persist.get_election_metadata uuid in
let name = election.e_params.e_name in
let contact = metadata.e_contact in
let%lwt state = Web_persist.get_election_state uuid in
match state with
| `Open | `Closed | `EncryptedTally _ ->
let%lwt t = Web_persist.get_election_date `Validation uuid in
let t = option_get t default_validation_date in
let next_t = datetime_add t (day days_to_delete) in
return @@ Some (`Delete, uuid, next_t, name, contact)
| `Tallied _ ->
let%lwt t = Web_persist.get_election_date `Tally uuid in
let t = option_get t default_tally_date in
let next_t = datetime_add t (day days_to_archive) in
return @@ Some (`Archive, uuid, next_t, name, contact)
| `Archived ->
let%lwt t = Web_persist.get_election_date `Archive uuid in
let t = option_get t default_archive_date in
let next_t = datetime_add t (day days_to_delete) in
return @@ Some (`Delete, uuid, next_t, name, contact)
let get_next_actions_validated () =
Lwt_unix.files_of_directory !spool_dir |>
Lwt_stream.filter_map_s
(fun x ->
if x = "." || x = ".." then
return None
else (
try%lwt
let uuid = uuid_of_raw_string x in
let%lwt dates = read_file ~uuid "dates.json" in
let%lwt state = Web_persist.get_election_state uuid in
match dates with
| Some [x] ->
let state = `Validated (state, election_dates_of_string x) in
return @@ Some (uuid, state)
| _ -> return None
with _ -> return None
)
) |>
Lwt_stream.to_list
if x = "." || x = ".." then return_none
else (try%lwt extract_automatic_data_validated x with _ -> return_none)
) |> Lwt_stream.to_list
let get_all_draft_election_dates () =
let get_next_actions_draft () =
Ocsipersist.fold_step (fun k v accu ->
let se = draft_election_of_string v in
let uuid = uuid_of_raw_string k in
return ((uuid, `Draft se) :: accu)
let se = draft_election_of_string v in
let name = se.se_questions.t_name in
let contact = se.se_metadata.e_contact in
let%lwt t = Web_persist.get_election_date `Creation uuid in
let t = option_get t default_creation_date in
let next_t = datetime_add t (day days_to_delete) in
return ((`Destroy se, uuid, next_t, name, contact) :: accu)
) election_stable []
let process_election_for_data_policy (uuid, state) =
let mail_automatic_warning : ('a, 'b, 'c, 'd, 'e, 'f) format6 =
"The election %s (%s) will be automatically %s after %s.
-- \nBelenios"
let process_election_for_data_policy (action, uuid, next_t, name, contact) =
let uuid_s = raw_string_of_uuid uuid in
let now = now () in
let delete_t = datetime_add now (day (-days_to_delete)) in
let archive_t = datetime_add now (day (-days_to_archive)) in
let perform t ref_t comment action x =
if datetime_compare t ref_t < 0 then (
action x >>
let action, comment = match action with
| `Destroy se -> (fun uuid -> destroy_election uuid se), "destroyed"
| `Delete -> delete_election, "deleted"
| `Archive -> archive_election, "archived"
in
if datetime_compare now next_t > 0 then (
action uuid >>
return (
Printf.ksprintf Ocsigen_messages.warning
"Election %s was automatically %s"
(raw_string_of_uuid uuid) comment
"Election %s has been automatically %s" uuid_s comment
)
) else (
let mail_t = datetime_add next_t (day (-days_to_mail)) in
if datetime_compare now mail_t > 0 then (
let%lwt last_t = Web_persist.get_election_date `LastMail uuid in
let send = match last_t with
| None -> true
| Some t ->
let next_mail_t = datetime_add t (day days_between_mails) in
datetime_compare now next_mail_t > 0
in
if send then (
match contact with
| None -> return_unit
| Some contact ->
match extract_email contact with
| None -> return_unit
| Some email ->
let subject =
Printf.sprintf "Election %s will be automatically %s soon"
name comment
in
let body =
Printf.sprintf mail_automatic_warning
name uuid_s comment (format_datetime next_t)
in
send_email email subject body >>
Web_persist.set_election_date `LastMail uuid now
) else return_unit
) else return_unit
in
match state with
| `Draft se ->
let t = option_get se.se_creation_date default_creation_date in
perform t delete_t "destroyed" (destroy_election uuid) se
| `Validated ((`Open | `Closed | `EncryptedTally _), dates) ->
let t = option_get dates.e_finalization default_validation_date in
perform t delete_t "deleted" delete_election uuid
| `Validated (`Archived, dates) ->
let t = option_get dates.e_archive default_archive_date in
perform t delete_t "deleted" delete_election uuid
| `Validated (`Tallied _, dates) ->
let t = option_get dates.e_tally default_tally_date in
perform t archive_t "archived" archive_election uuid
)
let _ =
let open Ocsigen_messages in
let rec loop () =
let () = console (fun () -> "Data policy process started") in
let%lwt draft = get_all_draft_election_dates () in
let%lwt validated = get_all_validated_election_dates () in
let%lwt draft = get_next_actions_draft () in
let%lwt validated = get_next_actions_validated () in
let elections = draft @ validated in
Lwt_list.iter_p process_election_for_data_policy elections >>
let () = console (fun () -> "Data policy process completed") 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