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
open Lwt.Infix
let ( >>!= ) = Lwt_result.bind
type unix_fd = {
raw : Unix.file_descr;
mutable needs_close : bool;
}
let close fd =
assert (fd.needs_close);
Unix.close fd.raw;
fd.needs_close <- false
let ensure_closed_unix fd =
if fd.needs_close then close fd
let ensure_closed_lwt fd =
if Lwt_unix.state fd = Lwt_unix.Closed then Lwt.return_unit
else Lwt_unix.close fd
let pp_signal f x =
let open Sys in
if x = sigkill then Fmt.string f "kill"
else if x = sigterm then Fmt.string f "term"
else Fmt.int f x
let pp_cmd = Fmt.box Fmt.(list ~sep:sp (quote string))
let redirection = function
| `FD_move_safely x -> `FD_copy x.raw
| `Dev_null -> `Dev_null
let close_redirection (x : [`FD_move_safely of unix_fd | `Dev_null]) =
match x with
| `FD_move_safely x -> ensure_closed_unix x
| `Dev_null -> ()
let default_exec ?cwd ?stdin ?stdout ?stderr ~pp argv =
let proc =
let stdin = Option.map redirection stdin in
let stdout = Option.map redirection stdout in
let stderr = Option.map redirection stderr in
Lwt_process.exec ?cwd ?stdin ?stdout ?stderr argv
in
Option.iter close_redirection stdin;
Option.iter close_redirection stdout;
Option.iter close_redirection stderr;
proc >|= function
| Unix.WEXITED n -> Ok n
| Unix.WSIGNALED x -> Fmt.error_msg "%t failed with signal %d" pp x
| Unix.WSTOPPED x -> Fmt.error_msg "%t stopped with signal %a" pp pp_signal x
let lwt_process_exec = ref default_exec
let exec_result ?cwd ?stdin ?stdout ?stderr ~pp argv =
Logs.info (fun f -> f "Exec %a" pp_cmd argv);
!lwt_process_exec ?cwd ?stdin ?stdout ?stderr ~pp ("", Array.of_list argv) >>= function
| Ok 0 -> Lwt_result.return ()
| Ok n -> Lwt.return @@ Fmt.error_msg "%t failed with exit status %d" pp n
| Error e -> Lwt_result.fail (e : [`Msg of string] :> [> `Msg of string])
let exec ?cwd ?stdin ?stdout ?stderr argv =
Logs.info (fun f -> f "Exec %a" pp_cmd argv);
let pp f = pp_cmd f argv in
!lwt_process_exec ?cwd ?stdin ?stdout ?stderr ~pp ("", Array.of_list argv) >>= function
| Ok 0 -> Lwt.return_unit
| Ok n -> Lwt.fail_with (Fmt.strf "%t failed with exit status %d" pp n)
| Error (`Msg m) -> Lwt.fail (Failure m)
let running_as_root = Unix.getuid () = 0
let sudo ?stdin args =
let args = if running_as_root then args else "sudo" :: args in
exec ?stdin args
let sudo_result ?cwd ?stdin ?stdout ?stderr ~pp args =
let args = if running_as_root then args else "sudo" :: args in
exec_result ?cwd ?stdin ?stdout ?stderr ~pp args
let rec write_all fd buf ofs len =
assert (len >= 0);
if len = 0 then Lwt.return_unit
else (
Lwt_unix.write fd buf ofs len >>= fun n ->
write_all fd buf (ofs + n) (len - n)
)
let write_file ~path contents =
Lwt_io.(with_file ~mode:output) path @@ fun ch ->
Lwt_io.write ch contents
let with_pipe_from_child fn =
let r, w = Lwt_unix.pipe_in () in
let w = { raw = w; needs_close = true } in
Lwt.finalize
(fun () ->
Lwt_unix.set_close_on_exec r;
fn ~r ~w
)
(fun () ->
ensure_closed_unix w;
ensure_closed_lwt r
)
let with_pipe_to_child fn =
let r, w = Lwt_unix.pipe_out () in
let r = { raw = r; needs_close = true } in
Lwt.finalize
(fun () ->
Lwt_unix.set_close_on_exec w;
fn ~r ~w
)
(fun () ->
ensure_closed_unix r;
ensure_closed_lwt w
)
let with_pipe_between_children fn =
let r, w = Unix.pipe ~cloexec:true () in
let r = { raw = r; needs_close = true } in
let w = { raw = w; needs_close = true } in
Lwt.finalize
(fun () -> fn ~r ~w)
(fun () ->
ensure_closed_unix r;
ensure_closed_unix w;
Lwt.return_unit
)
let pread ?stderr argv =
with_pipe_from_child @@ fun ~r ~w ->
let child = exec ~stdout:(`FD_move_safely w) ?stderr argv in
let r = Lwt_io.(of_fd ~mode:input) r in
Lwt.finalize
(fun () -> Lwt_io.read r)
(fun () -> Lwt_io.close r)
>>= fun data ->
child >>= fun () ->
Lwt.return data
let check_dir x =
match Unix.lstat x with
| Unix.{ st_kind = S_DIR; _ } -> `Present
| _ -> Fmt.failwith "Exists, but is not a directory: %S" x
| exception Unix.Unix_error(Unix.ENOENT, _, _) -> `Missing
let ensure_dir path =
match check_dir path with
| `Present -> ()
| `Missing -> Unix.mkdir path 0o777