autofill public title if left empty

pool/app/experiment/entity.ml

@@ -18,6 +18,7 @@ module PublicTitle = struct
 
   let field = Common.Message.Field.PublicTitle
   let schema () = schema field ()
+  let placeholder = "###"
 end
 
 module Description = struct

pool/app/experiment/experiment.mli

@@ -10,6 +10,8 @@ end
 
 module PublicTitle : sig
   include Pool_common.Model.StringSig
+
+  val placeholder : t
 end
 
 module Description : sig

pool/app/experiment/repo/repo.ml

@@ -54,8 +54,37 @@ module Sql = struct
     insert_sql |> Repo_entity.Write.t ->. Caqti_type.unit
   ;;
 
-  let insert pool =
-    Utils.Database.exec (Database.Label.value pool) insert_request
+  let insert pool experiment =
+    let open Entity in
+    let autofill_public_title_request =
+      {sql|
+        UPDATE pool_experiments
+        SET
+          public_title = CONCAT('#', id)
+        WHERE
+          uuid = UNHEX(REPLACE($1, '-', ''))
+        AND
+          public_title = $2
+      |sql}
+    in
+    let autofill_public_title =
+      let open Caqti_request.Infix in
+      autofill_public_title_request
+      |> Caqti_type.(tup2 Repo_entity.Id.t Repo_entity.PublicTitle.t ->. unit)
+    in
+    let with_connection request input connection =
+      let (module Connection : Caqti_lwt.CONNECTION) = connection in
+      Connection.exec request input
+    in
+    let insert = with_connection insert_request experiment in
+    let set_title =
+      with_connection
+        autofill_public_title
+        (experiment.id, PublicTitle.placeholder)
+    in
+    Utils.Database.exec_as_transaction
+      (Pool_database.Label.value pool)
+      [ insert; set_title ]
   ;;
 
   let select_from_experiments_sql where_fragment =

pool/cqrs_command/experiment_command.ml

@@ -10,31 +10,6 @@ let to_role (admin, role, target_uuid) =
   BaseGuard.ActorRole.create ?target_uuid admin role
 ;;
 
-let default_schema command =
-  let open Pool_common in
-  Utils.PoolConformist.(
-    make
-      Field.
-        [ Title.schema ()
-        ; PublicTitle.schema ()
-        ; Conformist.optional @@ Description.schema ()
-        ; Conformist.optional @@ CostCenter.schema ()
-        ; DirectRegistrationDisabled.schema ()
-        ; RegistrationDisabled.schema ()
-        ; AllowUninvitedSignup.schema ()
-        ; ExternalDataRequired.schema ()
-        ; ShowExternalDataIdLinks.schema ()
-        ; Conformist.optional @@ ExperimentType.schema ()
-        ; Conformist.optional
-          @@ Reminder.LeadTime.schema ~field:Message.Field.EmailLeadTime ()
-        ; Conformist.optional
-          @@ Reminder.LeadTime.schema
-               ~field:Message.Field.TextMessageLeadTime
-               ()
-        ]
-      command)
-;;
-
 let default_command
   title
   public_title
@@ -64,6 +39,85 @@ let default_command
   }
 ;;
 
+let create_command
+  title
+  public_title
+  description
+  cost_center
+  direct_registration_disabled
+  registration_disabled
+  allow_uninvited_signup
+  external_data_required
+  show_external_data_id_links
+  experiment_type
+  email_session_reminder_lead_time
+  text_message_session_reminder_lead_time
+  =
+  default_command
+    title
+    (CCOption.value ~default:PublicTitle.placeholder public_title)
+    description
+    cost_center
+    direct_registration_disabled
+    registration_disabled
+    allow_uninvited_signup
+    external_data_required
+    show_external_data_id_links
+    experiment_type
+    email_session_reminder_lead_time
+    text_message_session_reminder_lead_time
+;;
+
+let update_schema command =
+  let open Pool_common in
+  Utils.PoolConformist.(
+    make
+      Field.
+        [ Title.schema ()
+        ; PublicTitle.schema ()
+        ; Conformist.optional @@ Description.schema ()
+        ; Conformist.optional @@ CostCenter.schema ()
+        ; DirectRegistrationDisabled.schema ()
+        ; RegistrationDisabled.schema ()
+        ; AllowUninvitedSignup.schema ()
+        ; ExternalDataRequired.schema ()
+        ; ShowExternalDataIdLinks.schema ()
+        ; Conformist.optional @@ ExperimentType.schema ()
+        ; Conformist.optional
+          @@ Reminder.LeadTime.schema ~field:Message.Field.EmailLeadTime ()
+        ; Conformist.optional
+          @@ Reminder.LeadTime.schema
+               ~field:Message.Field.TextMessageLeadTime
+               ()
+        ]
+      command)
+;;
+
+let create_schema command =
+  let open Pool_common in
+  Utils.PoolConformist.(
+    make
+      Field.
+        [ Title.schema ()
+        ; Conformist.optional @@ PublicTitle.schema ()
+        ; Conformist.optional @@ Description.schema ()
+        ; Conformist.optional @@ CostCenter.schema ()
+        ; DirectRegistrationDisabled.schema ()
+        ; RegistrationDisabled.schema ()
+        ; AllowUninvitedSignup.schema ()
+        ; ExternalDataRequired.schema ()
+        ; ShowExternalDataIdLinks.schema ()
+        ; Conformist.optional @@ ExperimentType.schema ()
+        ; Conformist.optional
+          @@ Reminder.LeadTime.schema ~field:Message.Field.EmailLeadTime ()
+        ; Conformist.optional
+          @@ Reminder.LeadTime.schema
+               ~field:Message.Field.TextMessageLeadTime
+               ()
+        ]
+      command)
+;;
+
 type update_role =
   { admin : Admin.t
   ; experiment : Experiment.t
@@ -117,7 +171,7 @@ end = struct
   ;;
 
   let decode data =
-    Conformist.decode_and_validate (default_schema default_command) data
+    Conformist.decode_and_validate (create_schema create_command) data
     |> CCResult.map_err Pool_common.Message.to_conformist_error
   ;;
 
@@ -181,7 +235,7 @@ end = struct
   ;;
 
   let decode data =
-    Conformist.decode_and_validate (default_schema default_command) data
+    Conformist.decode_and_validate (update_schema default_command) data
     |> CCResult.map_err Pool_common.Message.to_conformist_error
   ;;
 

pool/test/experiment_test.ml

@@ -286,6 +286,42 @@ let delete_with_filter () =
 
 (* Integration *)
 
+let autofill_public_title _ () =
+  let open Utils.Lwt_result.Infix in
+  let open Experiment in
+  let without_title =
+    let experiment = Model.create_experiment () in
+    { experiment with public_title = PublicTitle.placeholder }
+  in
+  let with_title = Model.create_experiment () in
+  let%lwt () =
+    [ without_title; with_title ]
+    |> CCList.map CCFun.(created %> Pool_event.experiment)
+    |> Pool_event.handle_events database_label
+  in
+  let find id = Experiment.find database_label id ||> get_exn in
+  let%lwt without_title_persisted = find without_title.id in
+  let%lwt with_title_persisted = find with_title.id in
+  let () =
+    Alcotest.(
+      check
+        bool
+        "succeeds"
+        false
+        PublicTitle.(equal without_title_persisted.public_title placeholder))
+  in
+  let () =
+    Alcotest.(
+      check
+        bool
+        "succeeds"
+        true
+        PublicTitle.(
+          equal with_title_persisted.public_title with_title.public_title))
+  in
+  Lwt.return_unit
+;;
+
 module AvailableExperiments = struct
   let contact_id = Pool_common.Id.create ()
   let experiment_id = Experiment.Id.create ()

pool/test/integration.ml

@@ -202,7 +202,8 @@ let suite =
           ] )
     ; ( "experiment"
       , Experiment_test.
-          [ test_case
+          [ test_case "autofill public title" `Slow autofill_public_title
+          ; test_case
               "list available experiments"
               `Slow
               AvailableExperiments.list_available_experiments

pool/web/view/page/page_admin_experiments.ml

@@ -195,7 +195,7 @@ let experiment_form
                 `Text
                 Field.PublicTitle
                 ~value:(value public_title_value)
-                ~required:true
+                ~required:(CCOption.is_some experiment)
                 ~flash_fetcher
             ; textarea_element
                 language