systemd-ml/lib/systemd.ml

234 lines
7.4 KiB
OCaml

let is_systemd_booted env =
let fs = Eio.Stdenv.fs env in
Eio.Path.( / ) fs "/run/systemd/system/" |> Eio.Path.is_directory
let is_in_systemd () =
begin match Option.bind (Sys.getenv_opt "SYSTEMD_EXEC_PID") int_of_string_opt with
| None -> false
| Some(pid) ->
pid = Unix.getpid ()
end
let invocation_id () =
Sys.getenv "INVOCATION_ID"
let is_journald_attached () =
let stderr = Unix.fstat Unix.stderr in
let dev_ino = Format.sprintf "%d:%d" stderr.st_dev stderr.st_ino in
Sys.getenv_opt "JOURNAL_STREAM" = Some dev_ino
module Dirs = struct
let runtime_dir () =
Sys.getenv "RUNTIME_DIRECTORY"
let state_dir () =
Sys.getenv "STATE_DIRECTORY"
let cache_dir () =
Sys.getenv "CACHE_DIRECTORY"
let logs_dir () =
Sys.getenv "LOGS_DIRECTORY"
let configuration_dir () =
Sys.getenv "CONFIGURATION_DIRECTORY"
let credentials_dir () =
Sys.getenv "CREDENTIALS_DIRECTORY"
end
module Notify = struct
type t = {
sock : Eio_unix.Fd.t;
mono_clock : Eio.Time.Mono.ty Eio.Time.Mono.t;
}
module Private = struct
external unix_code_of_unix_error : Unix.error -> int = "ocaml_systemd_unix_code_of_unix_error"
end
let make ~sw ~env =
(* debatable whether we need a whole fd for this - reference code just opens and closes the socket
each time, and this avoids keeping the fds open the whole time. however, this also means that
if we run out of fds, notify will fail. currently, we just keep the fd open forever *)
if (Eio.Stdenv.backend_id env <> "linux") then failwith "Backend must be Eio_linux";
let orig_addr = Sys.getenv "NOTIFY_SOCKET" in
let addr = Bytes.of_string orig_addr in
begin if Bytes.starts_with ~prefix:("@"[@bytes]) addr then
Bytes.set addr 0 '\x00'
else if not (Bytes.starts_with ~prefix:("/"[@bytes]) addr) then
failwith "Invalid address family"
end;
let sock_unix = Unix.socket ~cloexec:true Unix.PF_UNIX Unix.SOCK_DGRAM 0 in
let sock = Eio_unix.Fd.of_unix ~sw ~seekable:false ~close_unix:true sock_unix in
Eio_linux.Low_level.connect sock (Unix.ADDR_UNIX (String.of_bytes addr));
{ sock = sock; mono_clock = Eio.Stdenv.mono_clock env; }
let notify t ?(fds=[]) msg =
let buf = [(Cstruct.of_string msg)] in
let sent = Eio_linux.Low_level.send_msg ~fds:fds t.sock buf in
assert (sent = Cstruct.lenv buf)
let ready ?(status=None) ?(mainpid=(-1)) t =
let buf = Buffer.create 32 in
Buffer.add_string buf "READY=1\n";
begin match status with
| Some status -> Printf.bprintf buf "STATUS=%s\n" status
| None -> ()
end;
if mainpid > -1 then Printf.bprintf buf "MAINPID=%u\n" mainpid;
notify t (Buffer.contents buf)
let send_status t status =
notify t ("STATUS=" ^ status ^ "\n")
let send_status_errno t status errno =
let errno = Private.unix_code_of_unix_error errno in
let msg = Format.sprintf "STATUS=%s\nERRNO=%d\n" status errno in
notify t msg
let reloading t =
(* this happens to use CLOCK_MONOTONIC on Eio_linux *)
let now = Eio.Time.Mono.now t.mono_clock in
let now_ns = Mtime.to_uint64_ns now in
let now = Int64.div now_ns 1000L in
let msg = Format.sprintf "RELOADING=1\nMONOTONIC_USEC=%Lu\n" now in
notify t msg
let stopping t =
notify t "STOPPING=1\n"
module NotifyAccess = struct
type t =
| None
| Main
| Exec
| All
let to_string = function
| None -> "none"
| Main -> "main"
| Exec -> "exec"
| All -> "all"
end
let update_access t acc =
notify t ("NOTIFYACCESS=" ^ (NotifyAccess.to_string acc) ^ "\n")
let extend_timeout t span =
let nsec = Mtime.Span.to_uint64_ns span in
let usec = Int64.div nsec 1000L in
let msg = Format.sprintf "EXTEND_TIMEOUT_USEC=%Lu\n" usec in
notify t msg
let barrier t =
Eio.Switch.run @@ fun sw ->
let (p0, p1) = Unix.pipe ~cloexec:true () in
let p0 = Eio_unix.Fd.of_unix ~sw ~seekable:false ~close_unix:true p0 in
let p1 = Eio_unix.Fd.of_unix ~sw ~seekable:false ~close_unix:true p1 in
notify t ~fds:[p1] "BARRIER=1\n";
Eio_unix.Fd.close p1;
(* the libsystemd source uses POLLHUP, which isn't exposed via Eio_linux at all, but POLLIN
works to the same end here - it won't return until the pipe is closed (and no one should
be writing anything to it) *)
Eio_linux.Low_level.await_readable p0;
Eio_unix.Fd.close p0
end
module Watchdog = struct
let get_interval_opt () =
match Option.bind (Sys.getenv_opt "WATCHDOG_USEC") Int64.of_string_opt with
| None -> None
| Some usec ->
begin match Option.bind (Sys.getenv_opt "WATCHDOG_PID") int_of_string_opt with
| None -> None
| Some pid ->
if pid = Unix.getpid () then
let nsec = Int64.mul usec 1000L in
Some (Mtime.Span.of_uint64_ns nsec)
else
None
end
let pet t =
Notify.notify t "WATCHDOG=1\n"
let trigger t =
Notify.notify t "WATCHDOG=trigger\n"
let set_watchdog_time t span =
let nsec = Mtime.Span.to_uint64_ns span in
let usec = Int64.div nsec 1000L in
let msg = Format.sprintf "WATCHDOG_USEC=%Lu\n" usec in
Notify.notify t msg
end
module Fdstore = struct
module Private = struct
let sd_listen_fds_start = 3
external unsafe_make_fd : int -> Unix.file_descr = "%identity"
end
let is_valid_fdname s =
let rec iter_chars i = begin
if i = String.length s then
true
else
let dec = String.get_utf_8_uchar s i in
let chr = Uchar.utf_decode_uchar dec |> Uchar.to_int in
let len = Uchar.utf_decode_length dec in
if chr >= 32 && chr <= 126 && chr != 58 then
iter_chars (i + len)
else
false
end in
iter_chars 0
let get_fd_limit () =
match Sys.getenv_opt "FDSTORE" with
| None -> 0
| Some limit -> int_of_string limit
let store t name ?(poll=true) fd =
if not (is_valid_fdname name) then failwith "Invalid fdstore name";
let msg = Format.sprintf ("FDSTORE=1\nFDNAME=%s\n" ^^ (if poll then "" else "FDPOLL=0\n")) name in
Notify.notify t ~fds:[fd] msg
let remove t name =
if not (is_valid_fdname name) then failwith "Invalid fdstore name";
Notify.notify t (Format.sprintf "FDSTOREREMOVE=1\nFDNAME=%s\n" name)
let listen_fds ~sw =
match Option.bind (Sys.getenv_opt "LISTEN_PID") int_of_string_opt with
| None -> []
| Some(pid) ->
if pid = Unix.getpid () then begin
let fd_count = Sys.getenv "LISTEN_FDS" |> int_of_string in
let fd_names = match Sys.getenv_opt "LISTEN_FDNAMES" with
| None -> List.init fd_count (fun _ -> None)
| Some names -> String.split_on_char ':' names |> List.map (fun a -> Some a) in
assert (fd_count = List.length fd_names);
Unix.putenv "LISTEN_FDS" "";
Unix.putenv "LISTEN_FDNAMES" "";
List.mapi (fun i name ->
let fd_num = Private.sd_listen_fds_start + i in
let fd = Private.unsafe_make_fd fd_num in
Unix.set_close_on_exec fd;
let fd = Eio_unix.Fd.of_unix ~sw ~seekable:false ~close_unix:true fd in
(name, fd)
) fd_names
end else []
end
(* we can't do memory pressure because of a lack of exposed pollpri :( *)
module MemPressure = struct
module Private = struct
external ext_memory_trim : unit -> unit = "ocaml_systemd_memory_trim"
end
let memory_trim () =
Gc.compact ();
Private.ext_memory_trim ()
end