Commit dee2d2fc authored by Stephane Glondu's avatar Stephane Glondu

Implement a data retention (and deletion) policy

parent 82980ca4
......@@ -149,6 +149,10 @@ let rec list_join sep = function
| [x] -> [x]
| x :: xs -> x :: sep :: list_join sep xs
let option_get x default_value = match x with
| None -> default_value
| Some x -> x
let option_map f = function
| Some x -> Some (f x)
| None -> None
......
......@@ -50,6 +50,7 @@ end
val list_join : 'a -> 'a list -> 'a list
val option_get : 'a option -> 'a -> 'a
val option_map : ('a -> 'b) -> 'a option -> 'b option
val save_to : string -> (Bi_outbuf.t -> 'a -> unit) -> 'a -> unit
......
......@@ -273,4 +273,7 @@ let write_file ?uuid x lines =
let default_contact = "Name <user@example.org>"
let default_creation_date = datetime_of_string "\"2018-06-06 00:00:00.000000\""
let default_finalization_date = datetime_of_string "\"2015-10-01 00:00:00.000000\""
let default_tally_date = datetime_of_string "\"2018-06-06 00:00:00.000000\""
let default_archive_date = datetime_of_string "\"2018-06-06 00:00:00.000000\""
......@@ -109,4 +109,8 @@ val read_file : ?uuid:uuid -> string -> string list option Lwt.t
val write_file : ?uuid:uuid -> string -> string list -> unit Lwt.t
val default_contact : string
val default_creation_date : datetime
val default_finalization_date : datetime
val default_tally_date : datetime
val default_archive_date : datetime
......@@ -49,3 +49,10 @@ let datetime_compare (a, _) (b, _) =
let format_datetime fmt (a, _) =
CalendarLib.Printer.Precise_Fcalendar.sprint fmt a
type period = CalendarLib.Fcalendar.Precise.Period.t
let day = CalendarLib.Fcalendar.Precise.Period.day
let datetime_add (a, _) x =
CalendarLib.Fcalendar.Precise.add a x, None
......@@ -25,3 +25,7 @@ val raw_string_of_datetime : datetime -> string
val raw_datetime_of_string : string -> datetime
val datetime_compare : datetime -> datetime -> int
val format_datetime : string -> datetime -> string
type period
val day : int -> period
val datetime_add : datetime -> period -> datetime
......@@ -2032,3 +2032,65 @@ let () =
redir_preapply election_setup_threshold_trustee token ()
)
)
let get_all_finalized_election_dates () =
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 = `Finalized (state, election_dates_of_string x) in
return @@ Some (uuid, state)
| _ -> return None
with _ -> return None
)
) |>
Lwt_stream.to_list
let get_all_setup_election_dates () =
Ocsipersist.fold_step (fun k v accu ->
let se = setup_election_of_string v in
let uuid = uuid_of_raw_string k in
return ((uuid, `Setup se) :: accu)
) election_stable []
let process_election_for_data_policy (uuid, state) =
let now = now () in
let one_year_ago = datetime_add now (day (-365)) in
let one_week_ago = datetime_add now (day (-7)) in
match state with
| `Setup se ->
let t = option_get se.se_creation_date default_creation_date in
if datetime_compare t one_year_ago < 0 then destroy_election uuid se
else return_unit
| `Finalized ((`Open | `Closed | `EncryptedTally _), dates) ->
let t = option_get dates.e_finalization default_finalization_date in
if datetime_compare t one_year_ago < 0 then delete_election uuid
else return_unit
| `Finalized (`Archived, dates) ->
let t = option_get dates.e_archive default_archive_date in
if datetime_compare t one_year_ago < 0 then delete_election uuid
else return_unit
| `Finalized (`Tallied _, dates) ->
let t = option_get dates.e_tally default_tally_date in
if datetime_compare t one_week_ago < 0 then archive_election uuid
else return_unit
let _ =
let open Ocsigen_messages in
let rec loop () =
let () = console (fun () -> "Data policy process started") in
let%lwt setup = get_all_setup_election_dates () in
let%lwt finalized = get_all_finalized_election_dates () in
let elections = setup @ finalized in
Lwt_list.iter_p process_election_for_data_policy elections >>
let () = console (fun () -> "Data policy process completed") in
Lwt_unix.sleep 3600. >> loop ()
in loop ()
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