IH-747 - database: Add an internal get_by_uuid_opt method

Instead of raising an exception in case of an error like get_by_uuid,
return None to be handled gracefully later.

Do not expose it in the datamodel.

This will later be used when an object is checked to exist before its creation
(during migration, for example), and so its absence is expected - no need to
raise a backtrace and pollute the logs with errors.

Signed-off-by: Andrii Sultanov <[email protected]>

ocaml/database/db_cache_impl.ml

@@ -240,6 +240,21 @@ let db_get_by_uuid t tbl uuid_val =
   | _ ->
       raise (Too_many_values (tbl, "", uuid_val))
 
+let db_get_by_uuid_opt t tbl uuid_val =
+  match
+    read_field_where t
+      {
+        table= tbl
+      ; return= Db_names.ref
+      ; where_field= Db_names.uuid
+      ; where_value= uuid_val
+      }
+  with
+  | [r] ->
+      Some r
+  | _ ->
+      None
+
 (** Return reference fields from tbl that matches specified name_label field *)
 let db_get_by_name_label t tbl label =
   read_field_where t

ocaml/database/db_interface.ml

@@ -56,6 +56,11 @@ module type DB_ACCESS = sig
   (** [db_get_by_uuid tbl uuid] returns the single object reference
       		associated with [uuid] *)
 
+  val db_get_by_uuid_opt : Db_ref.t -> string -> string -> string option
+  (** [db_get_by_uuid_opt tbl uuid] returns [Some obj] with the single object
+          reference associated with [uuid] if one exists and [None] otherwise,
+          instead of raising an exception like [get_by_uuid] *)
+
   val db_get_by_name_label : Db_ref.t -> string -> string -> string list
   (** [db_get_by_name_label tbl label] returns the list of object references
       		associated with [label] *)

ocaml/database/db_rpc_client_v1.ml

@@ -88,6 +88,10 @@ functor
       do_remote_call marshall_db_get_by_uuid_args
         unmarshall_db_get_by_uuid_response "db_get_by_uuid" (t, u)
 
+    let db_get_by_uuid_opt _ t u =
+      do_remote_call marshall_db_get_by_uuid_args
+        unmarshall_db_get_by_uuid_opt_response "db_get_by_uuid_opt" (t, u)
+
     let db_get_by_name_label _ t l =
       do_remote_call marshall_db_get_by_name_label_args
         unmarshall_db_get_by_name_label_response "db_get_by_name_label" (t, l)

ocaml/database/db_rpc_client_v2.ml

@@ -77,6 +77,13 @@ functor
       | _ ->
           raise Remote_db_server_returned_bad_message
 
+    let db_get_by_uuid_opt _ t u =
+      match process (Request.Db_get_by_uuid (t, u)) with
+      | Response.Db_get_by_uuid_opt y ->
+          y
+      | _ ->
+          raise Remote_db_server_returned_bad_message
+
     let db_get_by_name_label _ t l =
       match process (Request.Db_get_by_name_label (t, l)) with
       | Response.Db_get_by_name_label y ->

ocaml/database/db_rpc_common_v1.ml

@@ -194,6 +194,8 @@ let marshall_db_get_by_uuid_response s = XMLRPC.To.string s
 
 let unmarshall_db_get_by_uuid_response xml = XMLRPC.From.string xml
 
+let unmarshall_db_get_by_uuid_opt_response xml = unmarshall_stringopt xml
+
 (* db_get_by_name_label *)
 let marshall_db_get_by_name_label_args (s1, s2) = marshall_2strings (s1, s2)
 

ocaml/database/db_rpc_common_v2.ml

@@ -59,6 +59,7 @@ module Response = struct
     | Find_refs_with_filter of string list
     | Read_field_where of string list
     | Db_get_by_uuid of string
+    | Db_get_by_uuid_opt of string option
     | Db_get_by_name_label of string list
     | Create_row of unit
     | Delete_row of unit

ocaml/idl/datamodel_types.ml

@@ -577,7 +577,7 @@ type tag = FromField of field_op * field | FromObject of obj_op | Custom
 
 and field_op = Getter | Setter | Add | Remove
 
-and private_op = GetDBRecord | GetDBAll | Copy
+and private_op = GetDBRecord | GetDBAll | Copy | GetByUuidOpt
 
 and obj_op =
   | Make

ocaml/idl/datamodel_types.mli

@@ -201,7 +201,7 @@ type tag = FromField of field_op * field | FromObject of obj_op | Custom
 
 and field_op = Getter | Setter | Add | Remove
 
-and private_op = GetDBRecord | GetDBAll | Copy
+and private_op = GetDBRecord | GetDBAll | Copy | GetByUuidOpt
 
 and obj_op =
   | Make

ocaml/idl/datamodel_utils.ml

@@ -199,6 +199,14 @@ let default_doccomments =
         sprintf "Get a reference to the %s instance with the specified UUID."
           x.name
     )
+  ; ( "get_by_uuid_opt"
+    , fun x ->
+        sprintf
+          "Get a reference to the %s instance with the specified UUID. Returns \
+           an Option with the value inside of it instead ofraising an \
+           exception"
+          x.name
+    )
   ; ( "get_by_name_label"
     , fun x -> sprintf "Get all the %s instances with the given label." x.name
     )
@@ -579,6 +587,34 @@ let messages_of_obj (x : obj) document_order : message list =
     ; msg_tag= FromObject GetByUuid
     }
   in
+  (* Get by UUID - Doesn't raise an exception, returns an option instead *)
+  let uuid_opt =
+    let name = "get_by_uuid_opt" in
+    {
+      common with
+      msg_name= name
+    ; msg_params=
+        [
+          {
+            param_type= String
+          ; param_name= "uuid"
+          ; param_doc= "UUID of object to return"
+          ; param_release= x.obj_release
+          ; param_default= None
+          }
+        ]
+    ; msg_result=
+        Some (Option (Ref x.name), "Option containing reference to the object")
+    ; msg_doc= doccomment x name
+    ; msg_async= false
+    ; msg_session= true
+    ; msg_db_only= true
+    ; msg_has_effect= false
+    ; msg_allowed_roles= x.obj_implicit_msg_allowed_roles
+    ; msg_tag= FromObject (Private GetByUuidOpt)
+    ; msg_hide_from_docs= true
+    }
+  in
   (* Get by label *)
   let get_by_name_label =
     let name = "get_by_name_label" in
@@ -783,11 +819,11 @@ let messages_of_obj (x : obj) document_order : message list =
     @ [get_all]
     @ List.concat_map (all_new_messages_of_field x) all_fields
     @ constructor_destructor
-    @ [uuid; get_record]
+    @ [uuid; uuid_opt; get_record]
     @ name_label
     @ [get_record_internal]
   else
-    [get_record; get_record_internal; get_all; uuid]
+    [get_record; get_record_internal; get_all; uuid; uuid_opt]
     @ constructor_destructor
     @ name_label
     @ List.concat_map (new_messages_of_field x 0) all_fields

ocaml/idl/ocaml_backend/gen_db_actions.ml

@@ -93,6 +93,8 @@ let dm_to_string tys : O.Module.t =
           "fun x -> x |> SecretString.rpc_of_t |> Rpc.string_of_rpc"
       | DT.Record _ ->
           failwith "record types never stored in the database"
+      | DT.Option (DT.Ref _ as ty) ->
+          "fun s -> set " ^ OU.alias_of_ty ty ^ "(Option.to_list s)"
       | DT.Option _ ->
           failwith "option types never stored in the database"
     in
@@ -148,6 +150,10 @@ let string_to_dm tys : O.Module.t =
           "SecretString.of_string"
       | DT.Record _ ->
           failwith "record types never stored in the database"
+      | DT.Option (DT.Ref _ as ty) ->
+          "fun s -> match set "
+          ^ OU.alias_of_ty ty
+          ^ " s with [] -> None | x::_ -> Some x"
       | DT.Option _ ->
           failwith "option types never stored in the database"
     in
@@ -520,6 +526,20 @@ let db_action api : O.Module.t =
             failwith
               "GetByUuid call should have only one parameter and a result!"
       )
+      | FromObject (Private GetByUuidOpt) -> (
+        match (x.msg_params, x.msg_result) with
+        | [{param_name= name; _}], Some (Option result_ty, _) ->
+            let query =
+              Printf.sprintf "DB.db_get_by_uuid_opt __t \"%s\" %s"
+                (Escaping.escape_obj obj.DT.name)
+                (OU.escape name)
+            in
+            Printf.sprintf "Option.map %s.%s (%s)" _string_to_dm
+              (OU.alias_of_ty result_ty) query
+        | _ ->
+            failwith
+              "GetByUuidOpt call should have only one parameter and a result!"
+      )
       | FromObject GetByLabel -> (
         match (x.msg_params, x.msg_result) with
         | [{param_name= name; _}], Some (Set result_ty, _) ->