blob: 88f8b0cbf085a945c7e93ce6942bcce8d6058f0a (
plain)
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
|
(*
* A functor for 'internal' representation of Config_tree and Reference_tree.
* This is useful for avoiding re-parsing *_trees on cache and load.
*)
exception Read_error of string
exception Write_error of string
module type T =
sig
type t
val to_yojson : t -> Yojson.Safe.t
val of_yojson : Yojson.Safe.t -> t Ppx_deriving_yojson_runtime.error_or
val default : t
end
module type FI = functor (M: T) ->
sig
val write_string : M.t -> string
val read_string : string -> M.t
[@@alert exn "Internal.Read_error"]
val write_internal : M.t -> string -> unit
[@@alert exn "Internal.Write_error"]
val write_internal_atomic : M.t -> string -> unit
[@@alert exn "Internal.Write_error"]
val read_internal : string -> M.t
[@@alert exn "Internal.Read_error"]
val replace_internal : string -> string -> unit
[@@alert exn "Internal.Write_error"]
end
module Make : FI = functor (M: T) -> struct
let write_string x =
let yt = M.to_yojson x in
Yojson.Safe.to_string yt
let read_string s =
try
let yt = Yojson.Safe.from_string s in
let res = M.of_yojson yt in
match res with
| Error _ -> raise (Read_error "Corrupted string")
| Ok r -> r
with
| Read_error _ as e -> raise e
| Yojson.Json_error msg ->
raise (Read_error ("Corrupted string: " ^ msg))
| exn ->
raise (Read_error ("Corrupted string: " ^ Printexc.to_string exn))
let write_internal x file_name =
let yt = M.to_yojson x in
let ys = Yojson.Safe.to_string yt in
let fd =
try
Unix.openfile file_name [Unix.O_CREAT;Unix.O_WRONLY] 0o664
with Unix.Unix_error (e,f,p) ->
let out =
Printf.sprintf "%s %s: %s" (Unix.error_message e) f p
in raise (Write_error out)
in
let oc = Unix.out_channel_of_descr fd in
let () = Unix.ftruncate fd 0 in
let () = Printf.fprintf oc "%s" ys in
let () = Unix.fsync fd in
let () = Unix.chmod file_name 0o664 in
close_out_noerr oc
let read_internal file_name =
let fd =
try
Unix.openfile file_name [Unix.O_RDONLY] 0o664
with Unix.Unix_error (e,f,p) ->
let out =
Printf.sprintf "%s %s: %s" (Unix.error_message e) f p
in raise (Read_error out)
in
let ic = Unix.in_channel_of_descr fd in
let ys = really_input_string ic (in_channel_length ic) in
let yt = Yojson.Safe.from_string ys in
let ct_res = M.of_yojson yt in
let ct = Result.value ct_res ~default:M.default in
close_in_noerr ic; ct
let write_internal_atomic x file_name =
let file_name_tmp = file_name ^ ".tmp" in
let yt = M.to_yojson x in
let ys = Yojson.Safe.to_string yt in
let fd =
try
Unix.openfile file_name_tmp [Unix.O_CREAT;Unix.O_WRONLY] 0o664
with Unix.Unix_error (e,f,p) ->
let out =
Printf.sprintf "%s %s: %s" (Unix.error_message e) f p
in raise (Write_error out)
in
let oc = Unix.out_channel_of_descr fd in
let () = Unix.ftruncate fd 0 in
let () = Printf.fprintf oc "%s" ys in
let () = Unix.fsync fd in
let () = Unix.chmod file_name_tmp 0o664 in
let () = Unix.rename file_name_tmp file_name in
close_out_noerr oc
let replace_internal dst src =
let tmp = src ^ ".tmp" in
try
let () = FileUtil.cp ~force:Force [src] tmp in
let () = FileUtil.rm ~force:Force [dst] in
FileUtil.mv ~force:Force tmp dst
with _ -> raise (Write_error "replace error")
end
|
