Feature/2219 changelog

pool/app/assignment/assignment.ml

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

pool/app/assignment/assignment.mli

@@ -287,3 +287,13 @@ module Guard : sig
     val delete : Experiment.Id.t -> Id.t -> Guard.ValidationSet.t
   end
 end
+
+module VersionHistory : sig
+  module Record : sig
+    type t
+  end
+
+  val to_record : t -> Record.t
+
+  include Changelog.TSig with type record = Record.t
+end

pool/app/assignment/dune

@@ -8,6 +8,7 @@
    ppx_variants_conv
    ppx_deriving.eq
    ppx_deriving.show
-   ppx_string)))
+   ppx_string
+   ppx_yojson_conv)))
 
 (include_subdirs unqualified)

pool/app/assignment/entity.ml

@@ -21,16 +21,15 @@ module Participated = struct
 end
 
 module MatchesFilter = struct
-  type t = bool [@@deriving eq, show]
+  include Pool_model.Base.Boolean
 
-  let create m = m
-  let value m = m
   let init = false
 end
 
 module CanceledAt = struct
   include Pool_model.Base.Ptime
 
+  let equal a b = Ptime.equal a b || Sihl.Configuration.is_test ()
   let create m = Ok m
   let schema = schema Pool_message.Field.CanceledAt create
 end

pool/app/assignment/event.ml

@@ -10,12 +10,7 @@ type event =
 
 let handle_event pool : event -> unit Lwt.t = function
   | Canceled assignment ->
-    let%lwt () =
-      (* TODO: Check timestamps? Issue #126 *)
-      (* TODO: Notification to user? *)
-      { assignment with canceled_at = Some (CanceledAt.create_now ()) }
-      |> Repo.update pool
-    in
+    let%lwt () = Repo.update pool assignment in
     Lwt.return_unit
   | Created (assignment, session_id) ->
     let open Utils.Lwt_result.Infix in

pool/app/assignment/version_history.ml

@@ -0,0 +1,63 @@
+open Ppx_yojson_conv_lib.Yojson_conv
+open Entity
+
+module Record = struct
+  open Entity
+
+  let model = Pool_message.Field.Assignment
+
+  type t =
+    { id : Id.t
+         [@equal fun a b -> Id.equal a b || Sihl.Configuration.is_test ()]
+    ; contact : Contact.Id.t
+    ; no_show : NoShow.t option
+    ; participated : Participated.t option
+    ; matches_filter : MatchesFilter.t
+    ; canceled_at : CanceledAt.t option
+    ; marked_as_deleted : MarkedAsDeleted.t
+    ; external_data_id : ExternalDataId.t option
+    ; reminder_manually_last_sent_at : Pool_common.Reminder.SentAt.t option
+    ; custom_fields : Custom_field.Id.t list option
+    ; created_at : Pool_common.CreatedAt.t
+    ; updated_at : Pool_common.UpdatedAt.t
+    }
+  [@@deriving eq, show, yojson]
+end
+
+let to_record
+  ({ id
+   ; contact
+   ; no_show
+   ; participated
+   ; matches_filter
+   ; canceled_at
+   ; marked_as_deleted
+   ; external_data_id
+   ; reminder_manually_last_sent_at
+   ; custom_fields
+   ; created_at
+   ; updated_at
+   } :
+    Entity.t)
+  : Record.t
+  =
+  let custom_fields =
+    custom_fields |> CCOption.map (CCList.map Custom_field.Public.id)
+  in
+  Record.
+    { id
+    ; contact = Contact.id contact
+    ; no_show
+    ; participated
+    ; matches_filter
+    ; canceled_at
+    ; marked_as_deleted
+    ; external_data_id
+    ; reminder_manually_last_sent_at
+    ; custom_fields
+    ; created_at
+    ; updated_at
+    }
+;;
+
+include Changelog.T (Record)

pool/app/changelog/changelog.ml

@@ -0,0 +1,138 @@
+include Entity
+include Event
+
+module T (R : RecordSig) = struct
+  type record = R.t
+
+  let model = R.model
+
+  let column_created_at =
+    (Pool_message.Field.CreatedAt, "pool_change_log.created_at")
+    |> Query.Column.create
+  ;;
+
+  let searchable_by = []
+  let sortable_by = []
+  let filterable_by = None
+
+  let default_sort =
+    let open Query in
+    Sort.{ column = column_created_at; order = SortOrder.Descending }
+  ;;
+
+  let default_query = Query.create ~sort:default_sort ()
+
+  let make_changes before after : Changes.t option =
+    let open Changes in
+    let rec compare json_before json_after =
+      let eq = CCString.equal in
+      let compare_json before after =
+        match Yojson.Safe.equal before after with
+        | true -> None
+        | false -> Some (Change (before, after))
+      in
+      let list_to_assoc (json_list : Yojson.Safe.t list) =
+        let rec check acc = function
+          | [] -> Some (`Assoc acc)
+          | `List [ key; value ] :: tl ->
+            check (acc @ [ Yojson.Safe.to_string key, value ]) tl
+          | _ -> None
+        in
+        check [] json_list
+      in
+      match (json_before : Yojson.Safe.t), (json_after : Yojson.Safe.t) with
+      | `Assoc l1, `Assoc l2 ->
+        let keys =
+          let get = CCList.map fst in
+          get l1 @ get l2 |> CCList.uniq ~eq
+        in
+        keys
+        |> CCList.filter_map (fun key ->
+          let assoc list =
+            CCList.assoc_opt ~eq key list |> CCOption.value ~default:`Null
+          in
+          let value_before = assoc l1 in
+          let value_after = assoc l2 in
+          compare value_before value_after
+          |> CCOption.map (fun value -> key, value))
+        |> (function
+         | [] -> None
+         | assoc -> Some (Assoc assoc))
+      (* Catching equal variants *)
+      | `Tuple [ `String key1; val1 ], `Tuple [ `String key2; val2 ]
+      | `List [ `String key1; val1 ], `List [ `String key2; val2 ] ->
+        if eq key1 key2
+        then compare val1 val2
+        else Some (Change (json_before, json_after))
+      (* Catching equal assoc lists *)
+      | `List l1, `List l2 ->
+        (match list_to_assoc l1, list_to_assoc l2 with
+         | Some assoc_before, Some assoc_after ->
+           compare assoc_before assoc_after
+         | _, _ -> compare_json json_before json_after)
+      | _ -> compare_json json_before json_after
+    in
+    compare (R.yojson_of_t before) (R.yojson_of_t after)
+  ;;
+
+  let make
+    ?(id = Id.create ())
+    ~entity_uuid
+    ~user_uuid
+    (before : R.t)
+    (after : R.t)
+    =
+    (*** the entity_uuid could also be part of the Reord module, as a function.
+      This would probably require us to create a Record module for each model,
+      but provide more flexibility *)
+    make_changes before after
+    |> CCOption.map (fun changes ->
+      Write.
+        { id
+        ; changes
+        ; model
+        ; entity_uuid
+        ; user_uuid
+        ; created_at = Pool_common.CreatedAt.create_now ()
+        })
+  ;;
+
+  let create ?(id = Id.create ()) ~entity_uuid ~user_uuid ~before ~after () =
+    make ~id ~entity_uuid ~user_uuid before after
+  ;;
+
+  let all_by_entity = Repo.find_by_model model
+end
+
+(***
+
+  let make_changes before after : Changes.t option = let open Changes in let rec
+  compare json_before json_after = let eq = CCString.equal in let make_changes
+  before after = match Yojson.Safe.equal before after with | true -> None |
+  false -> Some (Change (before, after)) in let list_to_assoc (json_list :
+  Yojson.Safe.t list) = let rec check acc = function | [] -> Some (`Assoc acc) |
+  `List [ key; value ] :: tl -> check (acc @ [ Yojson.Safe.to_string key, value
+  ]) tl | _ -> None in check [] json_list in match (json_before :
+  Yojson.Safe.t), (json_after : Yojson.Safe.t) with | `Assoc l1, `Assoc l2 ->
+  let keys = let get = CCList.map fst in get l1 @ get l2 |> CCList.uniq ~eq in
+  keys |> CCList.filter_map (fun key -> let assoc list = CCList.assoc_opt ~eq
+  key list |> CCOption.value ~default:`Null in let value_before = assoc l1 in
+  let value_after = assoc l2 in compare value_before value_after |> CCOption.map
+  (fun value -> key, value)) |> (function | [] -> None | assoc -> Some (Assoc
+  assoc)) (* Catching equal variants *) | `Tuple [ `String key1; val1 ], `Tuple
+  [ `String key2; val2 ] | `List [ `String key1; val1 ], `List [ `String key2;
+  val2 ] -> if eq key1 key2 then compare val1 val2 else Some (Change
+  (json_before, json_after)) (* Catching equal assoc lists *) | `List l1, `List
+  l2 -> (match list_to_assoc l1, list_to_assoc l2 with | Some assoc_before, Some
+  assoc_after -> compare assoc_before assoc_after | None, None -> let open
+  CCList in let open CCOption.Infix in let after = Hashtbl.create (length l2) in
+  let () = l2 |> iteri (fun i x -> Hashtbl.add after i x) in let changes_before
+  = l1 |> foldi (fun acc i before_json -> Hashtbl.find_opt after i >>= (fun
+  after_json -> make_changes before_json after_json) >|= CCPair.make
+  (CCInt.to_string i) |> function | Some change -> let () = Hashtbl.remove after
+  i in acc @ [ change ] | None -> acc) [] in let changes_after = after |>
+  Hashtbl.to_seq |> of_seq |> filter_map (fun (i, json) -> make_changes `Null
+  json >|= CCPair.make (CCInt.to_string i)) in (match changes_before @
+  changes_after with | [] -> None | changes -> Some (Assoc changes)) | _, _ ->
+  make_changes json_before json_after) | _ -> make_changes json_before
+  json_after in compare (R.yojson_of_t before) (R.yojson_of_t after) ;; *)

pool/app/changelog/changelog.mli

@@ -0,0 +1,90 @@
+module Id : sig
+  include Pool_model.Base.IdSig
+end
+
+module Change : sig
+  type t = Yojson.Safe.t * Yojson.Safe.t
+
+  val equal : t -> t -> bool
+  val pp : Format.formatter -> t -> unit
+  val show : t -> string
+end
+
+module Changes : sig
+  type t =
+    | Assoc of (string * t) list
+    | Change of Change.t
+end
+
+type t =
+  { id : Id.t
+  ; changes : Changes.t
+  ; model : Pool_message.Field.t
+  ; entity_uuid : Pool_common.Id.t
+  ; user_uuid : Pool_common.Id.t
+  ; user_email : Pool_user.EmailAddress.t
+  ; created_at : Pool_common.CreatedAt.t
+  }
+
+val equal : t -> t -> bool
+val show : t -> string
+val pp : Format.formatter -> t -> unit
+
+module Write : sig
+  type t =
+    { id : Id.t
+    ; changes : Changes.t
+    ; model : Pool_message.Field.t
+    ; entity_uuid : Pool_common.Id.t
+    ; user_uuid : Pool_common.Id.t
+    ; created_at : Pool_common.CreatedAt.t
+    }
+
+  val equal : t -> t -> bool
+  val show : t -> string
+  val pp : Format.formatter -> t -> unit
+end
+
+module type RecordSig = sig
+  type t
+
+  val model : Pool_message.Field.t
+  val yojson_of_t : t -> Yojson.Safe.t
+end
+
+module type TSig = sig
+  type record
+
+  val model : Pool_message.Field.t
+  val default_query : Query.t
+  val filterable_by : Query.Filter.human option
+  val searchable_by : Query.Column.t list
+  val sortable_by : Query.Column.t list
+
+  val create
+    :  ?id:Id.t
+    -> entity_uuid:Pool_common.Id.t
+    -> user_uuid:Pool_common.Id.t
+    -> before:record
+    -> after:record
+    -> unit
+    -> Write.t option
+
+  val all_by_entity
+    :  ?query:Query.t
+    -> Database.Label.t
+    -> Pool_common.Id.t
+    -> (t list * Query.t) Lwt.t
+end
+
+module T : functor (R : RecordSig) -> sig
+  include TSig with type record = R.t
+end
+
+type event = Created of Write.t
+
+val equal_event : event -> event -> bool
+val pp_event : Format.formatter -> event -> unit
+val show_event : event -> string
+val handle_event : Database.Label.t -> event -> unit Lwt.t
+val created : Write.t -> event

pool/app/changelog/dune

@@ -0,0 +1,16 @@
+(library
+ (name changelog)
+ (libraries pool_common pool_user pool_message ptime sihl utils query)
+ (preprocess
+  (pps
+   lwt_ppx
+   ppx_deriving.enum
+   ppx_deriving.eq
+   ppx_deriving.ord
+   ppx_deriving.show
+   ppx_fields_conv
+   ppx_sexp_conv
+   ppx_variants_conv
+   ppx_yojson_conv)))
+
+(include_subdirs unqualified)