diff --git a/ocaml/database/db_cache_impl.ml b/ocaml/database/db_cache_impl.ml index b4f23b0af0..4c4f33b728 100644 --- a/ocaml/database/db_cache_impl.ml +++ b/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 diff --git a/ocaml/database/db_interface.ml b/ocaml/database/db_interface.ml index 834c12cd8a..081abc687b 100644 --- a/ocaml/database/db_interface.ml +++ b/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] *) diff --git a/ocaml/database/db_rpc_client_v1.ml b/ocaml/database/db_rpc_client_v1.ml index ecde5c4060..7adbcd6bbe 100644 --- a/ocaml/database/db_rpc_client_v1.ml +++ b/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) diff --git a/ocaml/database/db_rpc_client_v2.ml b/ocaml/database/db_rpc_client_v2.ml index 3c85dd82fc..3a32b3149e 100644 --- a/ocaml/database/db_rpc_client_v2.ml +++ b/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 -> diff --git a/ocaml/database/db_rpc_common_v1.ml b/ocaml/database/db_rpc_common_v1.ml index 1966595938..cced73dd9c 100644 --- a/ocaml/database/db_rpc_common_v1.ml +++ b/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) diff --git a/ocaml/database/db_rpc_common_v2.ml b/ocaml/database/db_rpc_common_v2.ml index 5ecf1b3e79..4cd9d7541a 100644 --- a/ocaml/database/db_rpc_common_v2.ml +++ b/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 diff --git a/ocaml/idl/ocaml_backend/gen_db_actions.ml b/ocaml/idl/ocaml_backend/gen_db_actions.ml index 06f54f228b..bcaed8526a 100644 --- a/ocaml/idl/ocaml_backend/gen_db_actions.ml +++ b/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 @@ -515,7 +521,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!"