Feature/2219 2 changelog (#467)

* add assignment changelog

* add mailing changelog

* add message template changelog

* tag changelog

* store current user in database to fix integration tests

* system settings changelog

* remove logs

* add waiting list changelog

* remove comments and signatures

* fix test cases

pool/app/assignment/assignment.mli

@@ -242,14 +242,16 @@ type event =
   | Canceled of t
   | Created of (t * Session.Id.t)
   | MarkedAsDeleted of t
+  | MatchesFilterUpdated of (t * MatchesFilter.t)
   | ExternalDataIdUpdated of t * ExternalDataId.t option
-  | Updated of t
+  | Updated of t * t
 
 val canceled : t -> event
 val created : t * Session.Id.t -> event
 val markedasdeleted : t -> event
-val updated : t -> event
-val handle_event : Database.Label.t -> event -> unit Lwt.t
+val matchesfilterupdated : t * MatchesFilter.t -> event
+val updated : t -> t -> event
+val handle_event : ?user_uuid:Pool_common.Id.t -> Database.Label.t -> event -> unit Lwt.t
 val equal_event : event -> event -> bool
 val pp_event : Format.formatter -> event -> unit
 val show_event : event -> string

pool/app/assignment/event.ml

@@ -4,27 +4,49 @@ type event =
   | Canceled of t
   | Created of (t * Session.Id.t)
   | MarkedAsDeleted of t
+  | MatchesFilterUpdated of (t * MatchesFilter.t)
   | ExternalDataIdUpdated of t * ExternalDataId.t option
-  | Updated of t
+  | Updated of t * t
 [@@deriving eq, show, variants]
 
-let handle_event pool : event -> unit Lwt.t = function
+let handle_event ?user_uuid pool : event -> unit Lwt.t =
+  let create_changelog before after =
+    let open Version_history in
+    let before = to_record before in
+    let after = to_record after in
+    insert pool ?user_uuid ~entity_uuid:before.Record.id ~before ~after ()
+  in
+  function
   | Canceled assignment ->
-    let%lwt () =
+    let canceleled =
       (* TODO: Check timestamps? Issue #126 *)
       (* TODO: Notification to user? *)
       { assignment with canceled_at = Some (CanceledAt.create_now ()) }
-      |> Repo.update pool
     in
-    Lwt.return_unit
+    let%lwt () = create_changelog assignment canceleled in
+    Repo.update pool canceleled
   | Created (assignment, session_id) ->
     let open Utils.Lwt_result.Infix in
     let%lwt () = Repo.insert pool session_id assignment in
     Entity_guard.Target.to_authorizable ~ctx:(Database.to_ctx pool) assignment
     ||> Pool_common.Utils.get_or_failwith
     ||> fun (_ : Guard.Target.t) -> ()
-  | MarkedAsDeleted assignment -> assignment.id |> Repo.marked_as_deleted pool
+  | MarkedAsDeleted assignment ->
+    let%lwt () =
+      create_changelog
+        assignment
+        { assignment with marked_as_deleted = MarkedAsDeleted.(create true) }
+    in
+    assignment.id |> Repo.marked_as_deleted pool
+  | MatchesFilterUpdated (assignment, matches_filter) ->
+    let updated = { assignment with matches_filter } in
+    let%lwt () = create_changelog assignment updated in
+    Repo.update pool updated
   | ExternalDataIdUpdated (assignment, external_data_id) ->
-    { assignment with external_data_id } |> Repo.update pool
-  | Updated t -> Repo.update pool t
+    let updated = { assignment with external_data_id } in
+    let%lwt () = create_changelog assignment updated in
+    Repo.update pool updated
+  | Updated (before, after) ->
+    let%lwt () = create_changelog before after in
+    Repo.update pool after
 ;;

pool/app/changelog/changelog.mli

@@ -18,7 +18,7 @@ end
 
 type user =
   { uuid : Pool_common.Id.t
-  ; email : Pool_user.EmailAddress.t
+  ; email : string
   }
 
 type t =

pool/app/changelog/dune

@@ -1,6 +1,6 @@
 (library
  (name changelog)
- (libraries pool_common pool_user pool_message ptime sihl utils query)
+ (libraries pool_common pool_message ptime sihl utils query)
  (preprocess
   (pps
    lwt_ppx

pool/app/changelog/entity.ml

@@ -32,7 +32,7 @@ end
 
 type user =
   { uuid : Pool_common.Id.t
-  ; email : Pool_user.EmailAddress.t
+  ; email : string
   }
 [@@deriving eq, show]
 

pool/app/changelog/repo/repo_entity.ml

@@ -41,7 +41,7 @@ let t =
       ; Field.t
       ; RepoId.t
       ; option RepoId.t
-      ; option Pool_user.Repo.EmailAddress.t
+      ; option Caqti_type.string
       ; Changes.t
       ; Pool_common.Repo.CreatedAt.t
       ]

pool/app/job/assignment_job/handler.ml

@@ -23,6 +23,15 @@ let make_messages
   =
   let* tenant = Pool_tenant.find_by_label database_label in
   let make_mail assignments admin =
+    let assignments =
+      let open CCList in
+      assignments
+      >|= fun (session, assignments) ->
+      ( session
+      , assignments
+        >|= fun (assignment, matches_filter) ->
+        Assignment.{ assignment with matches_filter } )
+    in
     let trigger = trigger_text context in
     Notification.create tenant trigger admin experiment assignments
   in
@@ -31,7 +40,7 @@ let make_messages
     let open CCList in
     filter_map (fun (session, assignments) ->
       assignments
-      |> filter (fun { matches_filter; _ } -> MatchesFilter.value matches_filter |> not)
+      |> filter (fun (_, matches_filter) -> MatchesFilter.value matches_filter |> not)
       |> function
       | [] -> None
       | assignments -> Some (session, assignments))
@@ -55,7 +64,7 @@ let make_events ?current_user context database_label experiment sessions =
   let filter_and_apply (assignment, matches_filter) =
     match MatchesFilter.equal assignment.matches_filter matches_filter with
     | true -> None
-    | false -> Some { assignment with matches_filter }
+    | false -> Some (assignment, matches_filter)
   in
   let sessions =
     sessions
@@ -69,9 +78,7 @@ let make_events ?current_user context database_label experiment sessions =
   let* messages =
     make_messages context ?current_user database_label experiment sessions
   in
-  let assignments =
-    sessions |> flat_map snd >|= fun assignment -> assignment |> Assignment.updated
-  in
+  let assignments = sessions |> flat_map snd >|= Assignment.matchesfilterupdated in
   Lwt_result.return (assignments, messages)
 ;;
 

pool/app/mailing/entity.ml

@@ -1,5 +1,9 @@
 open Ppx_yojson_conv_lib.Yojson_conv
 
+let model = Pool_message.Field.Mailing
+
+include Changelog.DefaultSettings
+
 module Id = struct
   include Pool_common.Id
 
@@ -204,7 +208,7 @@ type t =
   ; created_at : Pool_common.CreatedAt.t
   ; updated_at : Pool_common.UpdatedAt.t
   }
-[@@deriving eq, show]
+[@@deriving eq, show, yojson]
 
 let create ?allow_start_in_past ?(id = Id.create ()) start end_at limit distribution =
   let open CCResult in

pool/app/mailing/event.ml

@@ -15,16 +15,25 @@ type event =
   | Stopped of t
 [@@deriving eq, show, variants]
 
-let handle_event pool =
+let handle_event ?user_uuid pool =
   let open Utils.Lwt_result.Infix in
+  let create_changelog before after =
+    let open Version_history in
+    insert pool ?user_uuid ~entity_uuid:before.id ~before ~after ()
+  in
   function
   | Created (mailing, experiment_id) ->
     let%lwt () = Repo.insert pool experiment_id mailing in
     Entity_guard.Target.to_authorizable ~ctx:(Database.to_ctx pool) mailing
     ||> Pool_common.Utils.get_or_failwith
     ||> fun (_ : Guard.Target.t) -> ()
   | Updated ({ start_at; end_at; limit; distribution }, mailing) ->
-    { mailing with start_at; end_at; limit; distribution } |> Repo.update pool
+    let updated = { mailing with start_at; end_at; limit; distribution } in
+    let%lwt () = create_changelog mailing updated in
+    updated |> Repo.update pool
   | Deleted { id; _ } -> Repo.delete pool id
-  | Stopped mailing -> { mailing with end_at = Ptime_clock.now () } |> Repo.update pool
+  | Stopped mailing ->
+    let stopped = { mailing with end_at = Ptime_clock.now () } in
+    let%lwt () = create_changelog mailing stopped in
+    stopped |> Repo.update pool
 ;;

pool/app/mailing/mailing.ml

@@ -1,6 +1,7 @@
 include Entity
 include Event
 module Guard = Entity_guard
+module VersionHistory = Version_history
 
 let find = Repo.find
 let find_with_detail = Repo.find_with_detail

pool/app/mailing/mailing.mli

@@ -169,7 +169,7 @@ val created : t * Experiment.Id.t -> event
 val updated : update * t -> event
 val deleted : t -> event
 val stopped : t -> event
-val handle_event : Database.Label.t -> event -> unit Lwt.t
+val handle_event : ?user_uuid:Pool_common.Id.t -> Database.Label.t -> event -> unit Lwt.t
 val find : Database.Label.t -> Id.t -> (t, Pool_message.Error.t) Lwt_result.t
 
 val find_with_detail
@@ -245,6 +245,8 @@ module Guard : sig
   end
 end
 
+module VersionHistory : Changelog.TSig with type record = t
+
 val column_start : Query.Column.t
 val column_end : Query.Column.t
 val column_limit : Query.Column.t

pool/app/mailing/version_history.ml

@@ -0,0 +1 @@
+include Changelog.T (Entity)

pool/app/message_template/entity.ml

@@ -1,5 +1,10 @@
+open Ppx_yojson_conv_lib.Yojson_conv
 module Field = Pool_message.Field
 
+let model = Pool_message.Field.MessageTemplate
+
+include Changelog.DefaultSettings
+
 module Id = struct
   include Pool_common.Id
 end
@@ -118,7 +123,7 @@ type t =
   ; plain_text : PlainText.t
   ; sms_text : SmsText.t
   }
-[@@deriving eq, show]
+[@@deriving eq, show, yojson]
 
 module ManualMessage = struct
   type t =

pool/app/message_template/event.ml

@@ -24,9 +24,16 @@ let insert_template ?(default = true) db_label t =
   ||> fun (_ : Guard.Target.t) -> ()
 ;;
 
-let handle_event pool : event -> unit Lwt.t = function
+let handle_event ?user_uuid pool : event -> unit Lwt.t =
+  let create_changelog before after =
+    let open Version_history in
+    insert pool ?user_uuid ~entity_uuid:before.id ~before ~after ()
+  in
+  function
   | Created template -> insert_template pool ~default:false template
   | Updated (template, { email_subject; email_text; plain_text; sms_text }) ->
-    { template with email_subject; email_text; plain_text; sms_text } |> Repo.update pool
+    let updated = { template with email_subject; email_text; plain_text; sms_text } in
+    let%lwt () = create_changelog template updated in
+    updated |> Repo.update pool
   | Deleted { id; _ } -> Repo.delete pool id
 ;;

pool/app/message_template/message_template.ml

@@ -3,6 +3,7 @@ include Event
 include Default
 include Message_utils
 module Guard = Entity_guard
+module VersionHistory = Version_history
 
 let src = Logs.Src.create "message_template"
 

pool/app/message_template/message_template.mli

@@ -1,5 +1,7 @@
 module Id : sig
   include module type of Pool_common.Id
+
+  val to_common : t -> Pool_common.Id.t
 end
 
 module Label : sig
@@ -107,7 +109,7 @@ val show_event : event -> string
 val created : t -> event
 val updated : t -> update -> event
 val deleted : t -> event
-val handle_event : Database.Label.t -> event -> unit Lwt.t
+val handle_event : ?user_uuid:Pool_common.Id.t -> Database.Label.t -> event -> unit Lwt.t
 val find : Database.Label.t -> Id.t -> (t, Pool_message.Error.t) Lwt_result.t
 
 val find_default_by_label_and_language
@@ -189,6 +191,8 @@ module Guard : sig
   end
 end
 
+module VersionHistory : Changelog.TSig with type record = t
+
 val create_public_url_with_params
   :  Pool_tenant.Url.t
   -> string

pool/app/message_template/version_history.ml

@@ -0,0 +1 @@
+include Changelog.T (Entity)

pool/app/settings/dune

@@ -1,6 +1,7 @@
 (library
  (name settings)
  (libraries
+  changelog
   conformist
   guard
   letters
@@ -13,6 +14,7 @@
    lwt_ppx
    ppx_deriving.eq
    ppx_deriving.show
+   ppx_string
    ppx_variants_conv
    ppx_yojson_conv)))
 

pool/app/settings/event.ml

@@ -13,37 +13,37 @@ type event =
   | UserImportSecondReminderAfterUpdated of UserImportReminder.SecondReminderAfter.t
 [@@deriving eq, show]
 
-let handle_event pool : event -> unit Lwt.t = function
-  | LanguagesUpdated languages ->
-    let%lwt () = Repo.update pool (Value.TenantLanguages languages) in
-    Lwt.return_unit
+let handle_event ?user_uuid pool : event -> unit Lwt.t =
+  let open Utils.Lwt_result.Infix in
+  let create_changelog after =
+    let open Version_history in
+    let key = key_of_setting after in
+    let%lwt before = Repo.find_by_key pool key ||> fun { value; _ } -> value in
+    let%lwt entity_uuid = Repo.find_setting_id pool key in
+    insert pool ?user_uuid ~entity_uuid ~before ~after ()
+  in
+  let handle_update setting =
+    let%lwt () = create_changelog setting in
+    Repo.update pool setting
+  in
+  function
+  | LanguagesUpdated languages -> handle_update (Value.TenantLanguages languages)
   | EmailSuffixesUpdated email_suffixes ->
-    let%lwt () = Repo.update pool (Value.TenantEmailSuffixes email_suffixes) in
-    Lwt.return_unit
+    handle_update (Value.TenantEmailSuffixes email_suffixes)
   | DefaultReminderLeadTimeUpdated lead_time ->
-    let%lwt () = Repo.update pool (Value.DefaultReminderLeadTime lead_time) in
-    Lwt.return_unit
+    handle_update (Value.DefaultReminderLeadTime lead_time)
   | DefaultTextMsgReminderLeadTimeUpdated lead_time ->
-    let%lwt () = Repo.update pool (Value.DefaultTextMsgReminderLeadTime lead_time) in
-    Lwt.return_unit
+    handle_update (Value.DefaultTextMsgReminderLeadTime lead_time)
   | ContactEmailUpdated contact_email ->
-    let%lwt () = Repo.update pool (Value.TenantContactEmail contact_email) in
-    Lwt.return_unit
+    handle_update (Value.TenantContactEmail contact_email)
   | InactiveUserDisableAfterUpdated inactive_user_disable_after ->
-    let%lwt () =
-      Repo.update pool (Value.InactiveUserDisableAfter inactive_user_disable_after)
-    in
-    Lwt.return_unit
+    handle_update (Value.InactiveUserDisableAfter inactive_user_disable_after)
   | InactiveUserWarningUpdated inactive_user_warning ->
-    let%lwt () = Repo.update pool (Value.InactiveUserWarning inactive_user_warning) in
-    Lwt.return_unit
+    handle_update (Value.InactiveUserWarning inactive_user_warning)
   | TriggerProfileUpdateAfterUpdated trigger_update_after ->
-    let%lwt () =
-      Repo.update pool (Value.TriggerProfileUpdateAfter trigger_update_after)
-    in
-    Lwt.return_unit
+    handle_update (Value.TriggerProfileUpdateAfter trigger_update_after)
   | UserImportFirstReminderAfterUpdated first_reminder_after ->
-    Repo.update pool (Value.UserImportFirstReminder first_reminder_after)
+    handle_update (Value.UserImportFirstReminder first_reminder_after)
   | UserImportSecondReminderAfterUpdated second_reminder_after ->
-    Repo.update pool (Value.UserImportSecondReminder second_reminder_after)
+    handle_update (Value.UserImportSecondReminder second_reminder_after)
 ;;