From 53fbf397c284bee029a1c6f0bf00e4e6983c0cd2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Antonin=20D=C3=A9cimo?= Date: Fri, 30 Aug 2024 17:45:44 +0200 Subject: [PATCH] Raise and reraise exceptions with Stdlib rather than Lwt (#1079) * Re-raise exceptions to preserve backtraces * Use failwith instead of Lwt.fail_with Lwt's documentation reads: > In most cases, it is better to use `failwith s` from the standard > library. and > Whenever possible, it is recommended to use `raise exn` instead, as > raise captures a backtrace, while `Lwt.fail` does not. If you call > `raise exn` in a callback that is expected by Lwt to return a > promise, Lwt will automatically wrap `exn` in a rejected promise, > but the backtrace will have been recorded by the OCaml runtime. > > For example, `bind`'s second argument is a callback which returns a > promise. And so it is recommended to use `raise` in the body of that > callback. > > Use `Lwt.fail` only when you specifically want to create a rejected > promise, to pass to another function, or store in a data structure. Prefer to capture backtraces to improve debugability. * Use Stdlib.raise instead of Lwt.fail to capture backtraces --- README.md | 15 +++++++-------- cohttp-lwt-jsoo/src/cohttp_lwt_jsoo.ml | 4 ++-- cohttp-lwt-unix/bin/cohttp_server_lwt.ml | 4 ++-- cohttp-lwt-unix/examples/client_lwt_timeout.ml | 2 +- cohttp-lwt-unix/src/io.ml | 6 +++--- cohttp-lwt-unix/src/server.ml | 6 +++--- .../src/cohttp_lwt_unix_test.ml | 8 ++++---- cohttp-lwt-unix/test/test_client.ml | 10 +++++----- cohttp-lwt/src/connection.ml | 2 +- cohttp-lwt/src/connection_cache.ml | 6 +++--- cohttp-lwt/src/server.ml | 4 ++-- cohttp-mirage/src/input_channel.ml | 2 +- cohttp-mirage/src/io.ml | 6 +++--- cohttp-mirage/src/static.ml | 2 +- 14 files changed, 38 insertions(+), 39 deletions(-) diff --git a/README.md b/README.md index 87f16886dc..2a026f204f 100644 --- a/README.md +++ b/README.md @@ -154,7 +154,7 @@ let compute ~time ~f = let body = let get () = Client.get (Uri.of_string "https://www.reddit.com/") in compute ~time:0.1 ~f:get >>= function - | `Timeout -> Lwt.fail_with "Timeout expired" + | `Timeout -> failwith "Timeout expired" | `Done (resp, body) -> Lwt.return (resp, body) ``` @@ -174,7 +174,7 @@ For example, ```ocaml let get_body ~uri ~timeout = let%bind _, body = Cohttp_async.Client.get ~interrupt:(after (sec timeout)) uri in - Body.to_string body + Body.to_string body let body = let uri = Uri.of_string "https://www.reddit.com/" in @@ -275,19 +275,18 @@ and follow_redirect ~max_redirects request_uri (response, body) = handle_redirect ~permanent:true ~max_redirects request_uri response | `Found | `Temporary_redirect -> handle_redirect ~permanent:false ~max_redirects request_uri response - | `Not_found | `Gone -> Lwt.fail_with "Not found" + | `Not_found | `Gone -> failwith "Not found" | status -> - Lwt.fail_with - (Printf.sprintf "Unhandled status: %s" - (Cohttp.Code.string_of_status status)) + Printf.ksprintf failwith "Unhandled status: %s" + (Cohttp.Code.string_of_status status) and handle_redirect ~permanent ~max_redirects request_uri response = - if max_redirects <= 0 then Lwt.fail_with "Too many redirects" + if max_redirects <= 0 then failwith "Too many redirects" else let headers = Http.Response.headers response in let location = Http.Header.get headers "location" in match location with - | None -> Lwt.fail_with "Redirection without Location header" + | None -> failwith "Redirection without Location header" | Some url -> let open Lwt.Syntax in let uri = Uri.of_string url in diff --git a/cohttp-lwt-jsoo/src/cohttp_lwt_jsoo.ml b/cohttp-lwt-jsoo/src/cohttp_lwt_jsoo.ml index 59d41cc2a6..2d68024316 100644 --- a/cohttp-lwt-jsoo/src/cohttp_lwt_jsoo.ml +++ b/cohttp-lwt-jsoo/src/cohttp_lwt_jsoo.ml @@ -188,7 +188,7 @@ struct (* No implementation (can it be done?). What should the failure exception be? *) exception Cohttp_lwt_xhr_callv_not_implemented - let callv ?ctx:_ _uri _reqs = Lwt.fail Cohttp_lwt_xhr_callv_not_implemented + let callv ?ctx:_ _uri _reqs = raise Cohttp_lwt_xhr_callv_not_implemented (* ??? *) end @@ -269,7 +269,7 @@ module Make_client_async (P : Params) = Make_api (struct CLB.to_string body >>= fun body -> let bs = binary_string body in (*Js.Opt.case (File.CoerceTo.blob (Obj.magic blob)) - (fun () -> Lwt.fail_with "could not coerce to blob") + (fun () -> failwith "could not coerce to blob") (fun blob -> Lwt.return (xml##(send_blob blob)))*) (*Lwt.return (xml##send (Js.Opt.return bs)) *) Lwt.return (xml##send (Js.Opt.return (Obj.magic bs)))) diff --git a/cohttp-lwt-unix/bin/cohttp_server_lwt.ml b/cohttp-lwt-unix/bin/cohttp_server_lwt.ml index 57b0f6d268..72cadaf894 100644 --- a/cohttp-lwt-unix/bin/cohttp_server_lwt.ml +++ b/cohttp-lwt-unix/bin/cohttp_server_lwt.ml @@ -79,8 +79,8 @@ let serve ~info ~docroot ~index uri path = Server.respond_string ~status:`Not_found ~body:(html_of_not_found path info) () - else Lwt.fail e - | e -> Lwt.fail e) + else Lwt.reraise e + | e -> Lwt.reraise e) let handler ~info ~docroot ~index (ch, _conn) req _body = let uri = Cohttp.Request.uri req in diff --git a/cohttp-lwt-unix/examples/client_lwt_timeout.ml b/cohttp-lwt-unix/examples/client_lwt_timeout.ml index 399cc850f3..6c953f5953 100644 --- a/cohttp-lwt-unix/examples/client_lwt_timeout.ml +++ b/cohttp-lwt-unix/examples/client_lwt_timeout.ml @@ -11,7 +11,7 @@ let compute ~time ~f = let body = let get () = Client.get (Uri.of_string "https://www.reddit.com/") in compute ~time:0.1 ~f:get >>= function - | `Timeout -> Lwt.fail_with "Timeout expired" + | `Timeout -> failwith "Timeout expired" | `Done (resp, body) -> let code = resp |> Response.status |> Code.code_of_status in Printf.printf "Response code: %d\n" code; diff --git a/cohttp-lwt-unix/src/io.ml b/cohttp-lwt-unix/src/io.ml index be5cf85f1b..0fd496dd6a 100644 --- a/cohttp-lwt-unix/src/io.ml +++ b/cohttp-lwt-unix/src/io.ml @@ -40,12 +40,12 @@ let wrap_read f ~if_closed = https://github.com/ocsigen/lwt/pull/635 *) Lwt.catch f (function | Lwt_io.Channel_closed _ -> Lwt.return if_closed - | Unix.Unix_error _ as e -> Lwt.fail (IO_error e) + | Unix.Unix_error _ as e -> raise (IO_error e) | exn -> raise exn) let wrap_write f = Lwt.catch f (function - | Unix.Unix_error _ as e -> Lwt.fail (IO_error e) + | Unix.Unix_error _ as e -> raise (IO_error e) | exn -> raise exn) let read_line ic = @@ -80,6 +80,6 @@ type error = exn let catch f = Lwt.try_bind f Lwt.return_ok (function | IO_error e -> Lwt.return_error e - | ex -> Lwt.fail ex) + | ex -> Lwt.reraise ex) let pp_error = Fmt.exn diff --git a/cohttp-lwt-unix/src/server.ml b/cohttp-lwt-unix/src/server.ml index abf24d59cb..6aa5ccd90c 100644 --- a/cohttp-lwt-unix/src/server.ml +++ b/cohttp-lwt-unix/src/server.ml @@ -16,8 +16,8 @@ let respond_file ?headers ~fname () = (fun () -> (* Check this isn't a directory first *) ( fname |> Lwt_unix.stat >>= fun s -> - if Unix.(s.st_kind <> S_REG) then Lwt.fail Isnt_a_file - else Lwt.return_unit ) + if Unix.(s.st_kind <> S_REG) then raise Isnt_a_file else Lwt.return_unit + ) >>= fun () -> let count = 16384 in Lwt_io.open_file ~buffer:(Lwt_bytes.create count) ~mode:Lwt_io.input fname @@ -55,7 +55,7 @@ let respond_file ?headers ~fname () = (function | Unix.Unix_error (Unix.ENOENT, _, _) | Isnt_a_file -> respond_not_found () - | exn -> Lwt.fail exn) + | exn -> Lwt.reraise exn) let log_on_exn = function | Unix.Unix_error (error, func, arg) -> diff --git a/cohttp-lwt-unix/test/cohttp_lwt_unix_test/src/cohttp_lwt_unix_test.ml b/cohttp-lwt-unix/test/cohttp_lwt_unix_test/src/cohttp_lwt_unix_test.ml index aa1770b2f7..d399ea1503 100644 --- a/cohttp-lwt-unix/test/cohttp_lwt_unix_test/src/cohttp_lwt_unix_test.ml +++ b/cohttp-lwt-unix/test/cohttp_lwt_unix_test/src/cohttp_lwt_unix_test.ml @@ -20,7 +20,7 @@ let expert ?(rsp = Http.Response.make ()) f _req _body = return (`Expert (rsp, f)) let const rsp _req _body = rsp >|= response -let response_sequence = Cohttp_test.response_sequence Lwt.fail_with +let response_sequence = Cohttp_test.response_sequence failwith let () = Debug.activate_debug () let () = Logs.set_level (Some Info) @@ -36,9 +36,9 @@ let temp_server ?port spec callback = (fun () -> Server.create ~backlog:40 ~mode:(`TCP (`Port port)) server) (function | Lwt.Canceled -> Lwt.return_unit - | x -> - Lwt.wakeup_exn server_failed_wake x; - Lwt.fail x) + | exn -> + Lwt.wakeup_exn server_failed_wake exn; + Lwt.reraise exn) in Lwt.pick [ Lwt_unix.with_timeout 5.0 (fun () -> callback uri); server_failed ] >|= fun res -> diff --git a/cohttp-lwt-unix/test/test_client.ml b/cohttp-lwt-unix/test/test_client.ml index c2f0997341..8ab5c34bd5 100644 --- a/cohttp-lwt-unix/test/test_client.ml +++ b/cohttp-lwt-unix/test/test_client.ml @@ -54,18 +54,18 @@ let methods (handler : Cohttp_lwt.S.call) uri = Body.drain_body body >>= fun () -> match Response.status res with | `Created | `No_content | `OK -> Lwt.return_unit - | _ -> Lwt.fail_with "put failed" + | _ -> failwith "put failed" and get k = handler `GET Uri.(with_path uri k) >>= fun (res, body) -> match Response.status res with | `OK | `No_content -> Body.to_string body - | _ -> Body.drain_body body >>= fun () -> Lwt.fail Not_found + | _ -> Body.drain_body body >>= fun () -> raise Not_found and delete k = handler `DELETE Uri.(with_path uri k) >>= fun (res, body) -> Body.drain_body body >>= fun () -> match Response.status res with | `OK | `No_content -> Lwt.return_unit - | _ -> Lwt.fail Not_found + | _ -> raise Not_found and mem k = handler `HEAD Uri.(with_path uri k) >>= fun (res, body) -> Body.drain_body body >|= fun () -> @@ -171,10 +171,10 @@ let test_unknown uri = connection := c; match body with (* Still, body may have been (partially) consumed and needs re-creation. *) - | Some (`Stream _) -> Lwt.fail Connection.Retry + | Some (`Stream _) -> raise Connection.Retry | None | Some (`Empty | `String _ | `Strings _) -> handler ?headers ?body meth uri) - | e -> Lwt.fail e) + | e -> Lwt.reraise e) in tests handler uri diff --git a/cohttp-lwt/src/connection.ml b/cohttp-lwt/src/connection.ml index a4b94916a3..879ed0810b 100644 --- a/cohttp-lwt/src/connection.ml +++ b/cohttp-lwt/src/connection.ml @@ -172,7 +172,7 @@ module Make (Net : S.Net) : S.Connection with module Net = Net = struct Queue.push { uri; meth; headers; body; res_r } connection.waiting; Lwt_condition.broadcast connection.condition (); res - | Closing _ | Half _ | Closed | Failed _ -> Lwt.fail Retry + | Closing _ | Half _ | Closed | Failed _ -> raise Retry let rec writer connection = match connection.state with diff --git a/cohttp-lwt/src/connection_cache.ml b/cohttp-lwt/src/connection_cache.ml index cb4eae8d5e..0dd46432d7 100644 --- a/cohttp-lwt/src/connection_cache.ml +++ b/cohttp-lwt/src/connection_cache.ml @@ -161,10 +161,10 @@ end = struct (function | Retry -> ( match body with - | Some (`Stream _) -> Lwt.fail Retry + | Some (`Stream _) -> raise Retry | None | Some `Empty | Some (`String _) | Some (`Strings _) -> - if retry <= 0 then Lwt.fail Retry else request (retry - 1)) - | e -> Lwt.fail e) + if retry <= 0 then raise Retry else request (retry - 1)) + | e -> Lwt.reraise e) in request self.retry end diff --git a/cohttp-lwt/src/server.ml b/cohttp-lwt/src/server.ml index 3b20575ee3..397b80ed90 100644 --- a/cohttp-lwt/src/server.ml +++ b/cohttp-lwt/src/server.ml @@ -105,7 +105,7 @@ module Make (IO : S.IO) = struct Lwt.catch (fun () -> callback conn req body) (function - | Out_of_memory -> Lwt.fail Out_of_memory + | Out_of_memory -> Lwt.reraise Out_of_memory | exn -> Log.err (fun f -> f "Error handling %a: %s" Request.pp_hum req @@ -177,5 +177,5 @@ module Make (IO : S.IO) = struct Lwt.return_unit) (fun e -> conn_closed (); - Lwt.fail e) + Lwt.reraise e) end diff --git a/cohttp-mirage/src/input_channel.ml b/cohttp-mirage/src/input_channel.ml index 96e2e62101..7b1b1f3b62 100644 --- a/cohttp-mirage/src/input_channel.ml +++ b/cohttp-mirage/src/input_channel.ml @@ -13,7 +13,7 @@ module Make (Channel : Mirage_channel.S) = struct Cstruct.blit_to_bytes v 0 buf pos len; Lwt.return (`Ok len) | Ok `Eof -> Lwt.return `Eof - | Error e -> Lwt.fail (Read_exn e) + | Error e -> raise (Read_exn e) let create ?(buf_len = 0x4000) chan = { buf = Bytebuffer.create buf_len; chan } diff --git a/cohttp-mirage/src/io.ml b/cohttp-mirage/src/io.ml index d603e20e1b..d8215037aa 100644 --- a/cohttp-mirage/src/io.ml +++ b/cohttp-mirage/src/io.ml @@ -54,8 +54,8 @@ module Make (Channel : Mirage_channel.S) = struct Channel.write_string oc buf 0 (String.length buf); Channel.flush oc >>= function | Ok () -> Lwt.return_unit - | Error `Closed -> Lwt.fail_with "Trying to write on closed channel" - | Error e -> Lwt.fail (Write_exn e) + | Error `Closed -> failwith "Trying to write on closed channel" + | Error e -> raise (Write_exn e) let flush _ = (* NOOP since we flush in the normal writer functions above *) @@ -68,5 +68,5 @@ module Make (Channel : Mirage_channel.S) = struct Lwt.try_bind f Lwt.return_ok (function | Input_channel.Read_exn e -> Lwt.return_error (Read_error e) | Write_exn e -> Lwt.return_error (Write_error e) - | ex -> Lwt.fail ex) + | ex -> Lwt.reraise ex) end diff --git a/cohttp-mirage/src/static.ml b/cohttp-mirage/src/static.ml index e45199bf5c..26b4c95094 100644 --- a/cohttp-mirage/src/static.ml +++ b/cohttp-mirage/src/static.ml @@ -24,7 +24,7 @@ module HTTP (FS : Mirage_kv.RO) (S : Cohttp_lwt.S.Server) = struct open Lwt.Infix open Astring - let failf fmt = Fmt.kstr Lwt.fail_with fmt + let failf fmt = Fmt.failwith fmt let read_fs t name = FS.get t (Key.v name) >>= function