Merge 81c2a6a into 0472024

Author: last-genius

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/ocaml_backend/gen_db_actions.ml

@@ -93,6 +93,9 @@ 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) ->
+          String.concat ""
+            ["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 +151,13 @@ 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) ->
+          String.concat ""
+            [
+              "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
@@ -515,7 +525,32 @@ let db_action api : O.Module.t =
                 (Escaping.escape_obj obj.DT.name)
                 (OU.escape name)
             in
-            _string_to_dm ^ "." ^ OU.alias_of_ty result_ty ^ " (" ^ query ^ ")"
+            let func =
+              _string_to_dm
+              ^ "."
+              ^ OU.alias_of_ty result_ty
+              ^ " ("
+              ^ query
+              ^ ")"
+            in
+            let query_opt =
+              Printf.sprintf "DB.db_get_by_uuid_opt __t \"%s\" %s"
+                (Escaping.escape_obj obj.DT.name)
+                (OU.escape name)
+            in
+            String.concat "\n\t\t"
+              ([func]
+              @ [
+                  String.concat "\n\t\t  "
+                    (["and get_by_uuid_opt ~__context ~uuid ="]
+                    @ open_db_module
+                    @ [
+                        Printf.sprintf "Option.map %s.%s (%s)" _string_to_dm
+                          (OU.alias_of_ty result_ty) query_opt
+                      ]
+                    )
+                ]
+              )
         | _ ->
             failwith
               "GetByUuid call should have only one parameter and a result!"