assignment 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,10 +21,8 @@ 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
 

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

@@ -103,3 +103,36 @@ module T (R : RecordSig) = struct
 
   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/entity.ml

@@ -4,6 +4,8 @@ exception Exception of string
 
 module Id = struct
   include Pool_common.Id
+
+  let equal a b = equal a b || Sihl.Configuration.is_test ()
 end
 
 module Change = struct

pool/app/filter/entity.ml

@@ -581,7 +581,10 @@ module Predicate = struct
     ; operator : Operator.t
     ; value : value
     }
-  [@@deriving eq]
+  [@@deriving eq, show]
+
+  (* WORKAROUND: Check why equality is not working *)
+  let equal a b = CCString.equal (show a) (show b)
 
   type human =
     { key : Key.human option

pool/app/filter/filter.mli

@@ -134,6 +134,8 @@ module Predicate : sig
     }
 
   val create : Key.t -> Operator.t -> value -> t
+  val show : t -> string
+  val pp : Format.formatter -> t -> unit
 end
 
 type query =

pool/cqrs_command/assignment_command.ml

@@ -138,6 +138,7 @@ module Cancel : sig
 
   val handle
     :  ?tags:Logs.Tag.set
+    -> Admin.t
     -> Email.dispatch
     -> t
     -> (Pool_event.t list, Pool_message.Error.t) result
@@ -146,24 +147,42 @@ module Cancel : sig
 end = struct
   type t = Assignment.t list * Session.t
 
-  let handle ?(tags = Logs.Tag.empty) notification_email (assignments, session)
+  let handle
+    ?(tags = Logs.Tag.empty)
+    admin
+    notification_email
+    (assignments, session)
     : (Pool_event.t list, Pool_message.Error.t) result
     =
     let open CCResult in
+    let open Assignment in
     Logs.info ~src (fun m -> m "Handle command Cancel" ~tags);
     let contact =
-      assignments
-      |> CCList.hd
-      |> fun ({ Assignment.contact; _ } : Assignment.t) -> contact
+      assignments |> CCList.hd |> fun ({ contact; _ } : t) -> contact
     in
     let* (_ : unit list) =
       let* () = Session.assignments_cancelable session in
-      CCList.map Assignment.is_cancellable assignments |> CCList.all_ok
+      CCList.map is_cancellable assignments |> CCList.all_ok
     in
     let cancel_events =
-      CCList.map
-        (fun assignment ->
-          Assignment.Canceled assignment |> Pool_event.assignment)
+      CCList.fold_left
+        (fun acc assignment ->
+          let changelog =
+            let open VersionHistory in
+            create
+              ~entity_uuid:(Id.to_common assignment.id)
+              ~user_uuid:(Admin.id admin |> Admin.Id.to_common)
+              ~before:(assignment |> to_record)
+              ~after:
+                ({ assignment with
+                   canceled_at = Some (CanceledAt.create_now ())
+                 }
+                 |> to_record)
+              ()
+            |> Common.changelog_event
+          in
+          acc @ [ Canceled assignment |> Pool_event.assignment ] @ changelog)
+        []
         assignments
     in
     let decrease_assignment_count =
@@ -172,7 +191,8 @@ end = struct
       |> Pool_event.contact
     in
     Ok
-      ((cancel_events @ [ decrease_assignment_count ])
+      (cancel_events
+       @ [ decrease_assignment_count ]
        @ [ Email.sent notification_email |> Pool_event.email ])
   ;;
 
@@ -248,13 +268,20 @@ module MarkAsDeleted : sig
     with type t =
       Contact.t * Assignment.t list * Assignment.IncrementParticipationCount.t
 
+  val handle
+    :  ?tags:Logs.Tag.set
+    -> Admin.t
+    -> t
+    -> (Pool_event.t list, Pool_message.Error.t) result
+
   val effects : Experiment.Id.t -> Assignment.Id.t -> Guard.ValidationSet.t
 end = struct
   type t =
     Contact.t * Assignment.t list * Assignment.IncrementParticipationCount.t
 
   let handle
     ?(tags = Logs.Tag.empty)
+    admin
     (contact, assignments, decrement_participation_count)
     : (Pool_event.t list, Pool_message.Error.t) result
     =
@@ -265,7 +292,27 @@ end = struct
       CCList.map is_deletable assignments |> CCList.all_ok
     in
     let mark_as_deleted =
-      CCList.map (markedasdeleted %> Pool_event.assignment) assignments
+      CCList.fold_left
+        (fun acc assignment ->
+          let changelog =
+            let open VersionHistory in
+            create
+              ~entity_uuid:(Id.to_common assignment.id)
+              ~user_uuid:(Admin.id admin |> Admin.Id.to_common)
+              ~before:(assignment |> to_record)
+              ~after:
+                ({ assignment with
+                   marked_as_deleted = MarkedAsDeleted.create true
+                 }
+                 |> to_record)
+              ()
+            |> Common.changelog_event
+          in
+          acc
+          @ [ assignment |> markedasdeleted |> Pool_event.assignment ]
+          @ changelog)
+        []
+        assignments
     in
     let contact_updated =
       Contact_counter.update_on_assignment_deletion
@@ -286,6 +333,7 @@ module Update : sig
 
   val handle
     :  ?tags:Logs.Tag.set
+    -> Admin.t
     -> Experiment.t
     -> [ `Session of Session.t | `TimeWindow of Time_window.t ]
     -> Assignment.t
@@ -299,6 +347,7 @@ end = struct
 
   let handle
     ?(tags = Logs.Tag.empty)
+    admin
     (experiment : Experiment.t)
     session
     ({ Assignment.no_show; participated; _ } as assignment)
@@ -340,22 +389,33 @@ end = struct
         |> CCList.return
       | _ -> []
     in
-    let updated_assignment =
+    let updated =
       { assignment with
         no_show = Some command.no_show
       ; participated = Some command.participated
       ; external_data_id = command.external_data_id
       }
     in
+    let changelog =
+      let open VersionHistory in
+      create
+        ~entity_uuid:(Id.to_common assignment.id)
+        ~user_uuid:(Admin.id admin |> Admin.Id.to_common)
+        ~before:(assignment |> to_record)
+        ~after:(updated |> to_record)
+        ()
+      |> Common.changelog_event
+    in
     let* () =
-      validate experiment updated_assignment
+      validate experiment updated
       |> function
       | Ok () | Error [] -> Ok ()
       | Error (hd :: _) -> Error hd
     in
     Ok
-      ((Assignment.Updated updated_assignment |> Pool_event.assignment)
-       :: contact_counters)
+      (((Assignment.Updated updated |> Pool_event.assignment)
+        :: contact_counters)
+       @ changelog)
   ;;
 
   let decode data =

pool/routes/routes.ml

@@ -413,6 +413,7 @@ module Admin = struct
               ; post "/close" ~middlewares:[ Session.Access.close ] Close.update
               ; get "/edit" ~middlewares:[ Access.update ] edit
               ; post "" ~middlewares:[ Access.update ] update
+              ; get "/changelog" ~middlewares:[ Access.update ] changelog
               ; post "/remind" ~middlewares:[ Access.update ] remind
               ; post
                   "/mark-as-deleted"