unikernel/duniverse/ocaml-caqti/caqti/lib/caqti_error.ml

@@ -0,0 +1,281 @@
+(* Copyright (C) 2017--2022  Petter A. Urkedal <paurkedal@gmail.com>
+ *
+ * This library is free software; you can redistribute it and/or modify it
+ * under the terms of the GNU Lesser General Public License as published by
+ * the Free Software Foundation, either version 3 of the License, or (at your
+ * option) any later version, with the LGPL-3.0 Linking Exception.
+ *
+ * This library is distributed in the hope that it will be useful, but WITHOUT
+ * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ * FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser General Public
+ * License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public License
+ * and the LGPL-3.0 Linking Exception along with this library.  If not, see
+ * <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
+ *)
+
+(* Error Cause *)
+
+type integrity_constraint_violation = [
+  | `Restrict_violation
+  | `Not_null_violation
+  | `Foreign_key_violation
+  | `Unique_violation
+  | `Check_violation
+  | `Exclusion_violation
+  | `Integrity_constraint_violation__don't_match
+]
+
+type insufficient_resources = [
+  | `Disk_full
+  | `Out_of_memory
+  | `Too_many_connections
+  | `Configuration_limit_exceeded
+  | `Insufficient_resources__don't_match
+]
+
+type cause = [
+  | integrity_constraint_violation
+  | insufficient_resources
+  | `Unspecified__don't_match
+]
+
+let show_cause = function
+ | `Restrict_violation -> "RESTRICT violation"
+ | `Not_null_violation -> "NOT NULL constraint violation"
+ | `Foreign_key_violation -> "FOREIGN KEY constraint violation"
+ | `Unique_violation -> "UNIQUE constraint violation"
+ | `Check_violation -> "CHECK constraint violation"
+ | `Exclusion_violation -> "exclusion violation"
+ | `Integrity_constraint_violation__don't_match ->
+    "integrity constraint violation"
+ | `Disk_full -> "disk full"
+ | `Out_of_memory -> "out of memory"
+ | `Too_many_connections -> "too many connections"
+ | `Configuration_limit_exceeded -> "configuration limit exceeded"
+ | `Insufficient_resources__don't_match -> "insufficient resources"
+ | `Unspecified__don't_match -> "unknown cause"
+
+(* Driver *)
+
+type msg = ..
+
+type msg_impl = {
+  msg_pp: Format.formatter -> msg -> unit;
+  msg_cause: msg -> cause;
+}
+let msg_impl = Hashtbl.create 7
+
+let default_cause _ = `Unspecified__don't_match
+
+let define_msg ~pp ?(cause = default_cause) ec =
+  Hashtbl.add msg_impl ec {msg_pp = pp; msg_cause = cause}
+
+let find_impl msg =
+  let c = Obj.Extension_constructor.of_val msg in
+  try
+    Hashtbl.find msg_impl c
+  with Not_found ->
+    Printf.ksprintf failwith
+      "Missing call to Caqti_error.define_msg for (%s _ : Caqti_error.msg)]"
+      (Obj.Extension_constructor.name c)
+
+type msg += Msg : string -> msg
+
+let is_punct = function
+ | '.' | '!' | '?' -> true
+ | _ -> false
+
+let () =
+  let pp ppf = function
+   | Msg s ->
+      Format.pp_print_string ppf s;
+      if s <> "" && not (is_punct s.[String.length s - 1]) then
+        Format.pp_print_char ppf '.'
+   | _ -> assert false
+  in
+  define_msg ~pp ~cause:default_cause [%extension_constructor Msg]
+
+let pp_msg ppf msg =
+  (find_impl msg).msg_pp ppf msg
+
+(* We don't want to expose any DB password in error messages. *)
+let pp_uri ppf uri =
+  (match Uri.password uri with
+   | None -> Uri.pp_hum ppf uri
+   | Some _ -> Uri.pp_hum ppf (Uri.with_password uri (Some "_")))
+
+(* Records *)
+
+type load_error = {
+  uri: Uri.t;
+  msg: msg;
+}
+let pp_load_msg ppf fmt err =
+  Format.fprintf ppf fmt pp_uri err.uri;
+  Format.pp_print_string ppf ": ";
+  pp_msg ppf err.msg
+
+type connection_error = {
+  uri: Uri.t;
+  msg: msg;
+}
+let pp_connection_msg ppf fmt err =
+  Format.fprintf ppf fmt pp_uri err.uri;
+  Format.pp_print_string ppf ": ";
+  pp_msg ppf err.msg
+
+type query_error = {
+  uri: Uri.t;
+  query: string;
+  msg: msg;
+}
+
+let pp_query_msg ppf fmt err =
+  Format.fprintf ppf fmt pp_uri err.uri;
+  Format.pp_print_string ppf ": ";
+  pp_msg ppf err.msg;
+  Format.fprintf ppf " Query: %S." err.query
+
+type coding_error = {
+  uri: Uri.t;
+  typ: Caqti_type.any;
+  msg: msg;
+}
+let pp_coding_error ppf fmt err =
+  Format.fprintf ppf fmt Caqti_type.pp_any err.typ pp_uri err.uri;
+  Format.pp_print_string ppf ": ";
+  pp_msg ppf err.msg
+
+(* Load *)
+
+let load_rejected ~uri msg = `Load_rejected ({uri; msg} : load_error)
+let load_failed ~uri msg = `Load_failed ({uri; msg} : load_error)
+
+(* Connect *)
+
+let connect_rejected ~uri msg =
+  `Connect_rejected ({uri; msg} : connection_error)
+
+let connect_failed ~uri msg =
+  `Connect_failed ({uri; msg} : connection_error)
+
+(* Call *)
+
+let encode_missing ~uri ~field_type () =
+  let typ = Caqti_type.Any (Caqti_type.field field_type) in
+  let msg = Msg "Field type not supported and no fallback provided." in
+  `Encode_rejected ({uri; typ; msg} : coding_error)
+let encode_rejected ~uri ~typ msg =
+  let typ = Caqti_type.Any typ in
+  `Encode_rejected ({uri; typ; msg} : coding_error)
+let encode_failed ~uri ~typ msg =
+  let typ = Caqti_type.Any typ in
+  `Encode_failed ({uri; typ; msg} : coding_error)
+let request_failed ~uri ~query msg =
+  `Request_failed ({uri; query; msg} : query_error)
+
+(* Retrieve *)
+
+let decode_missing ~uri ~field_type () =
+  let typ = Caqti_type.Any (Caqti_type.field field_type) in
+  let msg = Msg "Field type not supported and no fallback provided." in
+  `Decode_rejected ({uri; typ; msg} : coding_error)
+let decode_rejected ~uri ~typ msg =
+  let typ = Caqti_type.Any typ in
+  `Decode_rejected ({uri; typ; msg} : coding_error)
+let response_failed ~uri ~query msg =
+  `Response_failed ({uri; query; msg} : query_error)
+let response_rejected ~uri ~query msg =
+  `Response_rejected ({uri; query; msg} : query_error)
+
+(* Common *)
+
+type call =
+  [ `Encode_rejected of coding_error
+  | `Encode_failed of coding_error
+  | `Request_failed of query_error
+  | `Response_rejected of query_error ]
+
+type retrieve =
+  [ `Decode_rejected of coding_error
+  | `Request_failed of query_error
+  | `Response_failed of query_error
+  | `Response_rejected of query_error ]
+
+type call_or_retrieve = [call | retrieve]
+
+type transact = call_or_retrieve
+
+type load =
+  [ `Load_rejected of load_error
+  | `Load_failed of load_error ]
+
+type connect =
+  [ `Connect_rejected of connection_error
+  | `Connect_failed of connection_error
+  | `Post_connect of call_or_retrieve ]
+
+type load_or_connect = [load | connect]
+
+type t = [load | connect | call | retrieve]
+
+let rec uri : 'a. ([< t] as 'a) -> Uri.t = function
+ | `Load_rejected ({uri; _} : load_error) -> uri
+ | `Load_failed ({uri; _} : load_error) -> uri
+ | `Connect_rejected ({uri; _} : connection_error) -> uri
+ | `Connect_failed ({uri; _} : connection_error) -> uri
+ | `Post_connect err -> uri err
+ | `Encode_rejected ({uri; _} : coding_error) -> uri
+ | `Encode_failed ({uri; _} : coding_error) -> uri
+ | `Request_failed ({uri; _} : query_error) -> uri
+ | `Decode_rejected ({uri; _} : coding_error) -> uri
+ | `Response_failed ({uri; _} : query_error) -> uri
+ | `Response_rejected ({uri; _} : query_error) -> uri
+
+let rec pp : 'a. _ -> ([< t] as 'a) -> unit = fun ppf -> function
+ | `Load_rejected err -> pp_load_msg ppf "Cannot load driver for <%a>" err
+ | `Load_failed err -> pp_load_msg ppf "Failed to load driver for <%a>" err
+ | `Connect_rejected err -> pp_connection_msg ppf "Cannot connect to <%a>" err
+ | `Connect_failed err -> pp_connection_msg ppf "Failed to connect to <%a>" err
+ | `Post_connect err ->
+    Format.pp_print_string ppf "During post-connect: ";
+    pp ppf err
+ | `Encode_rejected err -> pp_coding_error ppf "Cannot encode %a for <%a>" err
+ | `Encode_failed err -> pp_coding_error ppf "Failed to bind %a for <%a>" err
+ | `Decode_rejected err -> pp_coding_error ppf "Cannot decode %a from <%a>" err
+ | `Request_failed err -> pp_query_msg ppf "Request to <%a> failed" err
+ | `Response_failed err -> pp_query_msg ppf "Response from <%a> failed" err
+ | `Response_rejected err -> pp_query_msg ppf "Unexpected result from <%a>" err
+
+let show_of_pp pp err =
+  let buf = Buffer.create 128 in
+  let ppf = Format.formatter_of_buffer buf in
+  pp ppf err;
+  Format.pp_print_flush ppf ();
+  Buffer.contents buf
+
+let show err = show_of_pp pp err
+
+let cause = function
+ | `Request_failed err | `Response_failed err ->
+    (find_impl (err : query_error).msg).msg_cause err.msg
+
+type counit = |
+
+[@@@warning "-56"]
+let uncongested = function
+ | Error #t | Ok _ as x -> x
+ | Error (`Congested (nothingness : counit)) -> (match nothingness with _ -> .)
+[@@@warning "+56"]
+
+exception Exn of t
+
+let () = Printexc.register_printer @@ function
+ | Exn err ->
+    Some (show err)
+ | Caqti_query.Expand_error err ->
+    Some (show_of_pp Caqti_query.pp_expand_error err)
+ | _ ->
+    None