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
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
| `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
| `Corrupted_control_file
| `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
| `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_mapping_read of string
| `Invalid_read_of_gced_object of string
| `Inconsistent_store
| `Split_forbidden_during_batch
| `Multiple_empty_chunks
| `Forbidden_during_gc ]
[@@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)