package octez-internal-libs

  1. Overview
  2. Docs
package octez-internal-libs
Legend:
Page
Library
Module
Module type
Parameter
Class
Class type
Source

Source file errors.ml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
(*
 * Copyright (c) 2022-2022 Tarides <contact@tarides.com>
 *
 * Permission to use, copy, modify, and distribute this software for any
 * purpose with or without fee is hereby granted, provided that the above
 * copyright notice and this permission notice appear in all copies.
 *
 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
 *)

open Import

(** Finaliser for a function that returns a result and doesn't raise exceptions.

    If the finaliser fails, it is recommended to log the error. *)
let finalise finaliser f =
  let res = f () in
  finaliser res;
  res

(** Finaliser for a function that might raise exceptions. *)
let finalise_exn finaliser f =
  try
    let res = f () in
    finaliser (Some res);
    res
  with exn ->
    finaliser None;
    raise exn

type base_error =
  [ `Double_close
  | `File_exists of string
  | `Invalid_parent_directory
  | `No_such_file_or_directory of string
  | `Not_a_file
  | `Read_out_of_bounds
  | `Invalid_argument
  | `Decoding_error
  | `Not_a_directory of string
  | `Index_failure of string
  | `Invalid_layout
  | `Corrupted_legacy_file
  | `Corrupted_mapping_file of string
  | `Pending_flush
  | `Rw_not_allowed
  | `Migration_needed
  | `Migration_to_lower_not_allowed
  | `Corrupted_control_file of string
  | `Sys_error of string
  | `V3_store_from_the_future
  | `Gc_forbidden_during_batch
  | `Unknown_major_pack_version of string
  | `Only_minimal_indexing_strategy_allowed
  | `Commit_key_is_dangling of string
  | `Dangling_key of string
  | `Gc_disallowed of string
  | `Node_or_contents_key_is_indexed of string
  | `Gc_process_error of string
  | `Corrupted_gc_result_file of string
  | `Gc_process_died_without_result_file of string
  | `Gc_forbidden_on_32bit_platforms
  | `Invalid_prefix_read of string
  | `Invalid_sparse_read of [ `After | `Before | `Hole ] * int63
  | `Invalid_volume_read of [ `Empty | `Closed ] * int63
  | `Inconsistent_store
  | `Split_forbidden_during_batch
  | `Split_disallowed
  | `Multiple_empty_chunks
  | `Forbidden_during_gc
  | `Multiple_empty_volumes
  | `Volume_missing of string
  | `Add_volume_forbidden_during_gc
  | `Add_volume_requires_lower
  | `Volume_history_newer_than_archived_data of int63 * int63
  | `Lower_has_no_volume
  | `Volume_not_found of string
  | `No_tmp_path_provided ]
[@@deriving irmin ~pp]
(** [base_error] is the type of most errors that can occur in a [result], except
    for errors that have associated exceptions (see below) and backend-specific
    errors (see {!Io_errors}). *)

type closed_error = [ `Closed ] [@@deriving irmin ~pp]
type read_only_error = [ `Ro_not_allowed ] [@@deriving irmin ~pp]
type error = [ base_error | closed_error | read_only_error ]

exception Pack_error of base_error
exception Closed = Irmin.Closed
exception RO_not_allowed = Irmin_pack.RO_not_allowed

(** Error manager *)
module type S = sig
  type t = error

  val pp : Format.formatter -> [< t ] -> unit
  val raise_error : [< t ] -> 'a
  val log_error : string -> [< t ] -> unit
  val catch : (unit -> 'a) -> ('a, [> t ]) result
  val raise_if_error : ('a, [< t ]) result -> 'a
  val log_if_error : string -> (unit, [< t ]) result -> unit
  val to_json_string : (int63, [< t ]) result -> string
  val of_json_string : string -> (int63, [> t ]) result
end

module Base : S with type t = error = struct
  type t = error

  let pp ppf = function
    | #read_only_error as e -> pp_read_only_error ppf e
    | #closed_error as e -> pp_closed_error ppf e
    | #base_error as e -> pp_base_error ppf e

  let raise_error = function
    | #read_only_error -> raise RO_not_allowed
    | #closed_error -> raise Closed
    | #base_error as e -> raise (Pack_error e)

  let log_error context e = [%log.err "%s failed: %a" context pp e]

  let catch f =
    try Ok (f ()) with
    | Pack_error e -> Error (e : base_error :> [> t ])
    | RO_not_allowed -> Error `Ro_not_allowed
    | Closed -> Error `Closed

  let raise_if_error = function Ok x -> x | Error e -> raise_error e

  let log_if_error context = function
    | Ok _ -> ()
    | Error e -> log_error context e

  type err = Pack_error of base_error | Ro_not_allowed | Closed
  [@@deriving irmin]

  let t_to_err = function
    | #read_only_error -> Ro_not_allowed
    | #closed_error -> Closed
    | #base_error as e -> Pack_error e

  let err_to_t = function
    | Closed -> `Closed
    | Ro_not_allowed -> `Ro_not_allowed
    | Pack_error e -> (e : base_error :> [> t ])

  let err_result = Irmin.Type.(result int63 err_t)

  let to_json_string result =
    let convert = Result.map_error t_to_err in
    convert result |> Irmin.Type.to_json_string err_result

  let of_json_string string =
    match (Irmin.Type.of_json_string err_result) string with
    | Error (`Msg _) -> Error `Decoding_error
    | Ok result -> Result.map_error err_to_t result
end

let () =
  Printexc.register_printer (function
    | Pack_error e -> Some (Fmt.str "Pack_error: %a" pp_base_error e)
    | RO_not_allowed -> Some "RO_not_allowed"
    | Closed -> Some "Closed"
    | _ -> None)
OCaml

Innovation. Community. Security.

GitHub Discord Twitter Peertube RSS
About
Changelog Releases Industrial Users Academic Users Why OCaml
Ecosystem
Packages Community Events OCaml Planet Jobs
Resources
Install OCaml Get Started Platform Tools Language Manual Standard Library API Books Exercises Papers OCaml Playground Logo
Policies
Carbon Footprint Governance Privacy Code of Conduct