Revision 45d4f8972ba48b3f89f8d14d707fa532358c70ef authored by Nic Volanschi on 03 January 2024, 14:23:24 UTC, committed by Marge Bot on 04 January 2024, 09:23:35 UTC
1 parent 26c74a7
error_monad.ml
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2020-2021 Nomadic Labs <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
(* Tezos Protocol Implementation - Error Monad *)
(*-- Error classification ----------------------------------------------------*)
type error_category = [`Branch | `Temporary | `Permanent]
include (
TzCore : module type of TzCore with type error_category := error_category)
module TzTrace = TzTrace
type 'error trace = 'error TzTrace.trace
include TzMonad
type error += Exn of exn
let () =
register_error_kind
`Temporary
~id:"failure"
~title:"Exception"
~description:"Exception safely wrapped in an error"
~pp:(fun ppf s -> Format.fprintf ppf "@[<h 0>%a@]" Format.pp_print_text s)
Data_encoding.(obj1 (req "msg" string))
(function
| Exn (Failure msg) -> Some msg
| Exn exn -> Some (Printexc.to_string exn)
| _ -> None)
(fun msg -> Exn (Failure msg))
let error_with fmt =
Format.kasprintf (fun s -> Result_syntax.tzfail (Exn (Failure s))) fmt
let failwith fmt =
Format.kasprintf (fun s -> Lwt_result_syntax.tzfail (Exn (Failure s))) fmt
let error_of_exn e = Exn e
let trace_of_exn e = TzTrace.make @@ error_of_exn e
let error_with_exn e = Error (trace_of_exn e)
let fail_with_exn e = Lwt.return (error_with_exn e)
let error_of_fmt fmt = Format.kasprintf (fun str -> Exn (Failure str)) fmt
type error += Canceled
let () =
register_error_kind
`Temporary
~id:"canceled"
~title:"Canceled"
~description:"A promise was unexpectedly canceled"
~pp:(fun f () ->
Format.pp_print_string f "The promise was unexpectedly canceled")
Data_encoding.unit
(function Canceled -> Some () | _ -> None)
(fun () -> Canceled)
let protect_no_canceler ?on_error t =
let open Lwt_result_syntax in
let res = Lwt.catch t (fun exn -> tzfail (Exn exn)) in
let*! r = res in
match r with
| Ok _ -> res
| Error trace -> (
match on_error with
| None -> res
| Some on_error ->
Lwt.catch (fun () -> on_error trace) (fun exn -> tzfail (Exn exn)))
let protect_canceler ?on_error canceler t =
let open Lwt_result_syntax in
let cancellation =
let*! () = Lwt_canceler.when_canceling canceler in
tzfail Canceled
in
let res =
Lwt.pick [cancellation; Lwt.catch t (fun exn -> tzfail (Exn exn))]
in
let*! r = res in
match r with
| Ok _ -> res
| Error trace -> (
let trace =
if Lwt_canceler.canceled canceler then TzTrace.make Canceled else trace
in
match on_error with
| None -> Lwt.return_error trace
| Some on_error ->
Lwt.catch (fun () -> on_error trace) (fun exn -> tzfail (Exn exn)))
let protect ?on_error ?canceler t =
match canceler with
| None -> protect_no_canceler ?on_error t
| Some canceler -> protect_canceler ?on_error canceler t
type error += Timeout
let () =
register_error_kind
`Temporary
~id:"utils.Timeout"
~title:"Timeout"
~description:"Timeout"
~pp:(fun f () -> Format.pp_print_string f "The request has timed out")
Data_encoding.unit
(function Timeout -> Some () | _ -> None)
(fun () -> Timeout)
let with_timeout ?(canceler = Lwt_canceler.create ()) timeout f =
let open Lwt_result_syntax in
let target = f canceler in
let*! () =
Lwt.choose
[
timeout;
(let*! _ = target in
Lwt.return_unit);
]
in
if Lwt.state target <> Lwt.Sleep then (
Lwt.cancel timeout ;
target)
else
let*! r = Lwt_canceler.cancel canceler in
match r with
| Ok () | Error [] -> tzfail Timeout
| Error (h :: _) -> raise h
let errs_tag = Tag.def ~doc:"Errors" "errs" pp_print_trace
let cancel_with_exceptions canceler =
let open Lwt_syntax in
let* r = Lwt_canceler.cancel canceler in
match r with Ok () | Error [] -> Lwt.return_unit | Error (h :: _) -> raise h
let catch ?catch_only f = TzLwtreslib.Result.catch_f ?catch_only f trace_of_exn
let catch_e ?catch_only f =
TzLwtreslib.Result.catch_f ?catch_only f trace_of_exn |> Result.join
let catch_f ?catch_only f exc_mapper =
TzLwtreslib.Result.catch_f ?catch_only f (fun exc ->
TzTrace.make (exc_mapper exc))
let catch_s ?catch_only f =
let open Lwt_syntax in
let+ r = TzLwtreslib.Result.catch_s ?catch_only f in
Result.map_error trace_of_exn r
let catch_es ?catch_only f =
let open Lwt_syntax in
let+ r = TzLwtreslib.Result.catch_s ?catch_only f in
let r = Result.map_error trace_of_exn r in
Result.join r
let either_f (left : 'a tzresult Lwt.t) (right : unit -> 'a tzresult Lwt.t) =
let open Lwt_syntax in
let* l = left in
match l with
| Ok x -> return_ok x
| Error tr -> (
let* r = right () in
match r with Ok x -> return_ok x | Error e -> return_error (tr @ e))
let protect_result_canceler canceler t =
let open Lwt_syntax in
TzLwtreslib.Result.catch_s @@ fun () ->
let cancellation =
let* () = Lwt_canceler.when_canceling canceler in
raise Lwt.Canceled
in
Lwt.pick [cancellation; t ()]
let protect_result ?canceler t =
match canceler with
| None -> TzLwtreslib.Result.catch_s t
| Some canceler -> protect_result_canceler canceler t
Computing file changes ...