initial commit
This commit is contained in:
commit
3ad64d6ab9
|
@ -0,0 +1 @@
|
||||||
|
/_build
|
|
@ -0,0 +1,5 @@
|
||||||
|
(executable
|
||||||
|
(public_name ocaml-systemd)
|
||||||
|
(name main)
|
||||||
|
(modes byte exe)
|
||||||
|
(libraries systemd systemd.xlog eio_main fmt xlog))
|
|
@ -0,0 +1,24 @@
|
||||||
|
include (val Xlog.logs __FUNCTION__)
|
||||||
|
|
||||||
|
open Eio.Std
|
||||||
|
|
||||||
|
let () = Eio_main.run @@ fun env ->
|
||||||
|
let clock = Eio.Stdenv.clock env in
|
||||||
|
Switch.run ~name:"main" @@ fun sw ->
|
||||||
|
if Systemd.is_journald_attached () then
|
||||||
|
Xlog.add_writer (Systemd_xlog.make_writer ~sw ~env) ~min_level:Xlog.DEBUG
|
||||||
|
else
|
||||||
|
Xlog.init_pretty_writer stdout ~min_level:Xlog.DEBUG;
|
||||||
|
|
||||||
|
info (fun m -> m "meow meow meow");
|
||||||
|
|
||||||
|
let fds = Systemd.Fdstore.listen_fds ~sw in
|
||||||
|
List.iter (fun (name, fd) -> Stdlib.Format.printf "got fd %a=%a\n%!" (Fmt.option ~none:(Fmt.any "<none>") Fmt.string) name Eio_unix.Fd.pp fd; Eio_linux.Low_level.writev fd [Cstruct.of_string "meow"]) fds;
|
||||||
|
|
||||||
|
let ctx = Systemd.Notify.make ~sw ~env in
|
||||||
|
info (fun m -> m "notifying!");
|
||||||
|
Systemd.Notify.ready ctx;
|
||||||
|
info (fun m -> m "performing barrier");
|
||||||
|
Systemd.Notify.barrier ctx;
|
||||||
|
info (fun m -> m "done");
|
||||||
|
Eio.Time.sleep clock 2.0
|
|
@ -0,0 +1,27 @@
|
||||||
|
(lang dune 3.15)
|
||||||
|
|
||||||
|
(name systemd)
|
||||||
|
(version 0.0.1)
|
||||||
|
|
||||||
|
(generate_opam_files true)
|
||||||
|
|
||||||
|
(package
|
||||||
|
(name systemd)
|
||||||
|
(synopsis "libsystemd-like functionality for native ocaml")
|
||||||
|
(description "utilities for interacting with systemd when running as a service")
|
||||||
|
(license "unfree")
|
||||||
|
(homepage "https://git.lain.faith/haskal/ocaml-systemd")
|
||||||
|
(authors "xenia <xenia@awoo.systems>")
|
||||||
|
(source (uri "https://git.lain.faith/haskal/ocaml-systemd.git"))
|
||||||
|
(tags
|
||||||
|
(meow))
|
||||||
|
|
||||||
|
(depends ocaml dune
|
||||||
|
(cstruct (>= 6.2.0))
|
||||||
|
(dune-configurator (>= 3.15.2))
|
||||||
|
(eio (>= 1.1))
|
||||||
|
(eio_linux (>= 1.1))
|
||||||
|
(eio_main (>= 1.1))
|
||||||
|
(ppx_unicode (>= 0.0.1))
|
||||||
|
(ptime (>= 1.1))
|
||||||
|
(xlog (>= 0.1.0))))
|
|
@ -0,0 +1,8 @@
|
||||||
|
module C = Configurator.V1
|
||||||
|
|
||||||
|
let () = C.main ~name:"ocaml-systemd" (fun c ->
|
||||||
|
let has_malloc_trim = C.c_test c ~c_flags:["-Werror"]
|
||||||
|
"#include <malloc.h>\nint main(){malloc_trim(0);}" in
|
||||||
|
let cflags = if has_malloc_trim then [ "-DOCAML_SYSTEMD_USE_MALLOC_TRIM" ] else [] in
|
||||||
|
C.Flags.write_sexp "c_flags.sexp" cflags
|
||||||
|
)
|
|
@ -0,0 +1,3 @@
|
||||||
|
(executable
|
||||||
|
(name discover)
|
||||||
|
(libraries dune-configurator))
|
|
@ -0,0 +1,13 @@
|
||||||
|
(library
|
||||||
|
(name systemd)
|
||||||
|
(public_name systemd)
|
||||||
|
(preprocess (pps ppx_unicode))
|
||||||
|
(libraries cstruct eio eio_linux unix)
|
||||||
|
(foreign_stubs
|
||||||
|
(language c)
|
||||||
|
(names "systemd_stubs")
|
||||||
|
(flags (:include c_flags.sexp))))
|
||||||
|
|
||||||
|
(rule
|
||||||
|
(targets c_flags.sexp)
|
||||||
|
(action (run ./config/discover.exe)))
|
|
@ -0,0 +1,233 @@
|
||||||
|
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
|
|
@ -0,0 +1,192 @@
|
||||||
|
(** [Systemd] is a module for interacting with the {{:https://systemd.io/}systemd} service manager.
|
||||||
|
It provides functions for most common systemd functionality, such as the protocols for
|
||||||
|
detecting systemd/journald presence, startup/status notifications, the file descriptor store,
|
||||||
|
and the watchdog. See also {!Systemd_xlog} for integration with {!Xlog} to log via journald *)
|
||||||
|
|
||||||
|
(** [is_systemd_booted env] checks if the current system is running on systemd. [env] is the Eio
|
||||||
|
environment from [Eio_main.run] *)
|
||||||
|
val is_systemd_booted : Eio_unix.Stdenv.base -> bool
|
||||||
|
|
||||||
|
(** [is_in_systemd ()] checks if the program was started as a systemd service *)
|
||||||
|
val is_in_systemd : unit -> bool
|
||||||
|
|
||||||
|
(** [invocation_id ()] returns the systemd invocation ID if the program was started using systemd,
|
||||||
|
or if it is the child of a systemd service that has not unset the environment variable *)
|
||||||
|
val invocation_id : unit -> string
|
||||||
|
|
||||||
|
(** [is_journald_attached ()] checks if the program is currently connected to a journald stream.
|
||||||
|
This can indicate the ability to upgrade to rich log messages, eg with {!Systemd_xlog}. *)
|
||||||
|
val is_journald_attached : unit -> bool
|
||||||
|
|
||||||
|
(** [Systemd.Dirs] provides convenience functions for various directories passed in by systemd *)
|
||||||
|
module Dirs : sig
|
||||||
|
|
||||||
|
(** When started with a [RuntimeDirectory=] option, provides the runtime directory given by
|
||||||
|
systemd *)
|
||||||
|
val runtime_dir : unit -> string
|
||||||
|
|
||||||
|
(** When started with a [StateDirectory=] option, provides the state directory given by systemd *)
|
||||||
|
val state_dir : unit -> string
|
||||||
|
|
||||||
|
(** When started with a [CacheDirectory=] option, provides the cache directory given by systemd *)
|
||||||
|
val cache_dir : unit -> string
|
||||||
|
|
||||||
|
(** When started with a [LogsDirectory=] option, provides the logs directory given by systemd *)
|
||||||
|
val logs_dir : unit -> string
|
||||||
|
|
||||||
|
(** When started with a [ConfigurationDirectory=] option, provides the configuration directory
|
||||||
|
given by systemd *)
|
||||||
|
val configuration_dir : unit -> string
|
||||||
|
|
||||||
|
(** When started with a [LoadCredential=] or [LoadCredentialEncrypted=] option, provides the
|
||||||
|
directory with the credentials given by systemd *)
|
||||||
|
val credentials_dir : unit -> string
|
||||||
|
end
|
||||||
|
|
||||||
|
(** [Systemd.Notify] implements the notification protocol to inform systemd of service readiness
|
||||||
|
and other state changes *)
|
||||||
|
module Notify : sig
|
||||||
|
|
||||||
|
(** Holds context for using this module *)
|
||||||
|
type t
|
||||||
|
|
||||||
|
(** [Notify.make ~sw ~env] creates a new notify context, which must be passed to the other
|
||||||
|
functions in this module. [sw] is a [Eio.Switch] which will register the resources associated
|
||||||
|
with the context, and [env] is the Eio environment from [Eio_main.run] *)
|
||||||
|
val make :
|
||||||
|
sw:Eio.Switch.t ->
|
||||||
|
env:Eio_unix.Stdenv.base -> t
|
||||||
|
|
||||||
|
(** [Notify.notify t ~fds msg] sends [msg] and optionally file descriptors in [fds] to systemd.
|
||||||
|
This is a low-level function and should only be used if the convenience functions in this
|
||||||
|
module do not provide the functionality you need. In particular, [fds] should only be set
|
||||||
|
if [msg] corresponds to a command that accepts file descriptors. *)
|
||||||
|
val notify :
|
||||||
|
t ->
|
||||||
|
?fds:Eio_unix.Fd.t list ->
|
||||||
|
string -> unit
|
||||||
|
|
||||||
|
(** [Notify.ready t] tells systemd that this program has finished initialization and can be
|
||||||
|
considered fully operational. An optional [status] can be sent containing a status message.
|
||||||
|
Status messages should not contain any newlines.
|
||||||
|
[mainpid] corresponds to the [MAINPID=] field of the underlying notification command and is
|
||||||
|
typically not needed. *)
|
||||||
|
val ready :
|
||||||
|
?status:string option ->
|
||||||
|
?mainpid:int ->
|
||||||
|
t -> unit
|
||||||
|
|
||||||
|
(** [Notify.send_status t status] updates the status message of this program as reported by
|
||||||
|
systemd to the given text. Note that status messages should not contain any newlines. *)
|
||||||
|
val send_status :
|
||||||
|
t ->
|
||||||
|
string -> unit
|
||||||
|
|
||||||
|
(** [Notify.send_status_errno t status errno] is like [Notify.send_status t status] but contains
|
||||||
|
an additional [Unix.error] corresponding to some error condition encountered by the program. *)
|
||||||
|
val send_status_errno :
|
||||||
|
t ->
|
||||||
|
string ->
|
||||||
|
Unix.error -> unit
|
||||||
|
|
||||||
|
(** [Notify.reloading t] reports that the program is currently reloading its configuration.
|
||||||
|
If used, [Notify.ready t] must be called at some point to report completion. *)
|
||||||
|
val reloading : t -> unit
|
||||||
|
|
||||||
|
(** [Notify.stopping t] reports that the program is stopping. The program should exit soon after
|
||||||
|
calling this function. *)
|
||||||
|
val stopping : t -> unit
|
||||||
|
|
||||||
|
(** Represents the different values of the systemd [NotifyAccess=] setting. *)
|
||||||
|
module NotifyAccess : sig
|
||||||
|
|
||||||
|
(** Possible values for systemd [NotifyAccess=] *)
|
||||||
|
type t =
|
||||||
|
| None (** ["none"] *)
|
||||||
|
| Main (** ["main"] *)
|
||||||
|
| Exec (** ["exec"] *)
|
||||||
|
| All (** ["all"] *)
|
||||||
|
|
||||||
|
(** [to_string t] returns the systemd-compatible string representation of [t] *)
|
||||||
|
val to_string : t -> string
|
||||||
|
end
|
||||||
|
|
||||||
|
(** [Notify.update_access t acc] changes the access setting for the notification socket,
|
||||||
|
overriding the systemd [NotifyAccess=] setting *)
|
||||||
|
val update_access :
|
||||||
|
t ->
|
||||||
|
NotifyAccess.t -> unit
|
||||||
|
|
||||||
|
(** [Notify.extend_timeout t span] attempts to add a duration [span] to the
|
||||||
|
current startup, runtime or shutdown service timeout. A further notification message must be
|
||||||
|
sent within the duration specified by [span]. *)
|
||||||
|
val extend_timeout :
|
||||||
|
t ->
|
||||||
|
Mtime.Span.t -> unit
|
||||||
|
|
||||||
|
(** [Notify.barrier t] performs a barrier protocol to synchronize systemd with the program. Once
|
||||||
|
this function returns, systemd is guaranteed to have processed all notification messages sent
|
||||||
|
before this function was called. *)
|
||||||
|
val barrier : t -> unit
|
||||||
|
end
|
||||||
|
|
||||||
|
(** [Systemd.Watchdog] implements the systemd watchdog protocol, when the program is used with eg
|
||||||
|
[WatchdogSec=] *)
|
||||||
|
module Watchdog : sig
|
||||||
|
|
||||||
|
(** [Watchdog.get_interval_opt ()] returns either the interval on which the program must send
|
||||||
|
watchdog notifications, or [None] if the watchdog is not enabled *)
|
||||||
|
val get_interval_opt : unit -> Mtime.Span.t option
|
||||||
|
|
||||||
|
(** [Watchdog.pet t] sends a keep-alive notification to systemd *)
|
||||||
|
val pet : Notify.t -> unit
|
||||||
|
|
||||||
|
(** [Watchdog.trigger t] tells systemd to trigger the watchdog action, as if a failure has
|
||||||
|
occurred *)
|
||||||
|
val trigger : Notify.t -> unit
|
||||||
|
|
||||||
|
(** [Watchdog.set_watchdog_time t span] updates the watchdog interval to [span] *)
|
||||||
|
val set_watchdog_time :
|
||||||
|
Notify.t ->
|
||||||
|
Mtime.Span.t -> unit
|
||||||
|
end
|
||||||
|
|
||||||
|
(** [Systemd.Fdstore] implements the systemd
|
||||||
|
{{:https://systemd.io/FILE_DESCRIPTOR_STORE/}file descriptor store} and socket-passing protocol,
|
||||||
|
when relevent options are enabled *)
|
||||||
|
module Fdstore : sig
|
||||||
|
|
||||||
|
(** [Fdstore.is_valid_fdname s] checks if [s] is a valid fdstore name according to systemd *)
|
||||||
|
val is_valid_fdname : string -> bool
|
||||||
|
|
||||||
|
(** [Fdstore.get_fd_limit ()] retrieves the maximum number of file descriptors that can be stored
|
||||||
|
with systemd. Returns 0 if fdstore is not enabled *)
|
||||||
|
val get_fd_limit : unit -> int
|
||||||
|
|
||||||
|
(** [Fdstore.store t name fd] registers [fd] with [name] in the systemd fdstore. If
|
||||||
|
[poll=false] then systemd will not automatically remove the fd when it's closed, so it must
|
||||||
|
be manually unregistered. *)
|
||||||
|
val store :
|
||||||
|
Notify.t ->
|
||||||
|
string ->
|
||||||
|
?poll:bool ->
|
||||||
|
Eio_unix.Fd.t -> unit
|
||||||
|
|
||||||
|
(** [Fdstore.remove t name] removes any file descriptor previously registered with [name] from
|
||||||
|
systemd *)
|
||||||
|
val remove :
|
||||||
|
Notify.t ->
|
||||||
|
string -> unit
|
||||||
|
|
||||||
|
(** [Fdstore.listen_fds ~sw] returns a list of file descriptors passed into this process by
|
||||||
|
systemd. This can be fds previously registered with [Fdstore.store], or fds associatd with
|
||||||
|
systemd socket activation (or both). The fds get registered with Eio Switch [sw]. Environment
|
||||||
|
variables corresponding to this fd-passing protocol get unset when this function completes. *)
|
||||||
|
val listen_fds :
|
||||||
|
sw:Eio.Switch.t ->
|
||||||
|
(string option * Eio_unix.Fd.t) list
|
||||||
|
end
|
||||||
|
|
||||||
|
module MemPressure : sig
|
||||||
|
val memory_trim : unit -> unit
|
||||||
|
end
|
|
@ -0,0 +1,30 @@
|
||||||
|
#include <malloc.h>
|
||||||
|
|
||||||
|
#include <caml/mlvalues.h>
|
||||||
|
#include <caml/memory.h>
|
||||||
|
#include <caml/alloc.h>
|
||||||
|
#include <caml/custom.h>
|
||||||
|
#include <caml/unixsupport.h>
|
||||||
|
|
||||||
|
/**
|
||||||
|
* Wrapper for caml_unix_code_of_unix_error that returns a real OCaml int value
|
||||||
|
*/
|
||||||
|
CAMLprim value ocaml_systemd_unix_code_of_unix_error(value code) {
|
||||||
|
CAMLparam1(code);
|
||||||
|
CAMLlocal1(result);
|
||||||
|
|
||||||
|
int raw_code = caml_unix_code_of_unix_error(code);
|
||||||
|
result = Val_int(raw_code);
|
||||||
|
|
||||||
|
CAMLreturn(result);
|
||||||
|
}
|
||||||
|
|
||||||
|
CAMLprim value ocaml_systemd_memory_trim(value unit) {
|
||||||
|
CAMLparam1(unit);
|
||||||
|
|
||||||
|
#ifdef OCAML_SYSTEMD_USE_MALLOC_TRIM
|
||||||
|
malloc_trim(0);
|
||||||
|
#endif
|
||||||
|
|
||||||
|
CAMLreturn(Val_unit);
|
||||||
|
}
|
|
@ -0,0 +1,5 @@
|
||||||
|
(library
|
||||||
|
(name systemd_xlog)
|
||||||
|
(public_name systemd.xlog)
|
||||||
|
(preprocess (pps ppx_unicode))
|
||||||
|
(libraries cstruct eio eio_linux unix xlog ptime))
|
|
@ -0,0 +1,83 @@
|
||||||
|
open Xlog
|
||||||
|
|
||||||
|
let default_socket_path = "/run/systemd/journal/socket"
|
||||||
|
|
||||||
|
type t = {
|
||||||
|
mutex : Mutex.t;
|
||||||
|
sock_fd : Eio_unix.Fd.t;
|
||||||
|
buf : Buffer.t;
|
||||||
|
}
|
||||||
|
|
||||||
|
let add_field dgram key value =
|
||||||
|
if String.contains value '\n' then
|
||||||
|
begin
|
||||||
|
Buffer.add_string dgram key;
|
||||||
|
Buffer.add_char dgram '\n';
|
||||||
|
Buffer.add_int64_le dgram (Int64.of_int (String.length value));
|
||||||
|
Buffer.add_string dgram value;
|
||||||
|
Buffer.add_char dgram '\n';
|
||||||
|
end
|
||||||
|
else
|
||||||
|
Printf.bprintf dgram "%s=%s\n" key value
|
||||||
|
|
||||||
|
let syslog_priority = function
|
||||||
|
| TRACE
|
||||||
|
| DEBUG -> "7" (* LOG_DEBUG *)
|
||||||
|
| INFO -> "6" (* LOG_INFO *)
|
||||||
|
| WARN -> "4" (* LOG_WARNING *)
|
||||||
|
| ERROR -> "3" (* LOG_ERR *)
|
||||||
|
|
||||||
|
external unix_code_of_unix_error : Unix.error -> int = "ocaml_systemd_unix_code_of_unix_error"
|
||||||
|
|
||||||
|
let get_errno errno exn =
|
||||||
|
if errno != 0 then
|
||||||
|
errno
|
||||||
|
else
|
||||||
|
match exn with
|
||||||
|
| Some ((Unix.Unix_error (err, _, _)), _) -> unix_code_of_unix_error err
|
||||||
|
| _ -> 0
|
||||||
|
|
||||||
|
let writer t ~ts ~ns ~filename ~lineno ~func ~errno ~exn ~lvl msg =
|
||||||
|
Mutex.lock t.mutex;
|
||||||
|
let dgram =
|
||||||
|
Buffer.clear t.buf;
|
||||||
|
ignore ts;
|
||||||
|
let maybe_exn = match exn with
|
||||||
|
| Some (exn, bt) ->
|
||||||
|
Printf.sprintf "\nException: %s\n%s" (Printexc.to_string exn)
|
||||||
|
(Printexc.raw_backtrace_to_string bt)
|
||||||
|
| None -> ""
|
||||||
|
in
|
||||||
|
add_field t.buf "MESSAGE" (Printf.sprintf "%s: %s%s" ns msg maybe_exn);
|
||||||
|
add_field t.buf "PRIORITY" (syslog_priority lvl);
|
||||||
|
begin if not (filename = "") then
|
||||||
|
add_field t.buf "CODE_FILE" filename;
|
||||||
|
add_field t.buf "CODE_LINE" (Printf.sprintf "%d" lineno)
|
||||||
|
end;
|
||||||
|
begin if not (func = "") then
|
||||||
|
add_field t.buf "CODE_FUNC" func
|
||||||
|
end;
|
||||||
|
let errno = get_errno errno exn in
|
||||||
|
begin if errno != 0 then
|
||||||
|
add_field t.buf "ERRNO" (Printf.sprintf "%d" errno)
|
||||||
|
end;
|
||||||
|
Buffer.to_bytes t.buf
|
||||||
|
in
|
||||||
|
Mutex.unlock t.mutex;
|
||||||
|
let buf = [(Cstruct.of_bytes dgram)] in
|
||||||
|
let sent = Eio_linux.Low_level.send_msg t.sock_fd buf in
|
||||||
|
assert (sent = Cstruct.lenv buf)
|
||||||
|
|
||||||
|
let make_writer ~sw ~env =
|
||||||
|
if (Eio.Stdenv.backend_id env <> "linux") then failwith "Backend must be Eio_linux";
|
||||||
|
let sock = 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 in
|
||||||
|
(* this path isn't configurable in libsystemd, so i don't see a reason to take an argument for
|
||||||
|
it here *)
|
||||||
|
Eio_linux.Low_level.connect sock (Unix.ADDR_UNIX default_socket_path);
|
||||||
|
writer {
|
||||||
|
mutex = Mutex.create ();
|
||||||
|
sock_fd = sock;
|
||||||
|
buf = Buffer.create 256;
|
||||||
|
}
|
||||||
|
|
|
@ -0,0 +1,43 @@
|
||||||
|
{
|
||||||
|
lib,
|
||||||
|
gitSource,
|
||||||
|
|
||||||
|
buildDunePackage,
|
||||||
|
cstruct,
|
||||||
|
dune-configurator,
|
||||||
|
eio,
|
||||||
|
eio_linux,
|
||||||
|
eio_main,
|
||||||
|
ppx_unicode,
|
||||||
|
ptime,
|
||||||
|
xlog,
|
||||||
|
|
||||||
|
ocaml,
|
||||||
|
dune_3,
|
||||||
|
odoc,
|
||||||
|
utop,
|
||||||
|
|
||||||
|
withShell ? false
|
||||||
|
}:
|
||||||
|
buildDunePackage rec {
|
||||||
|
pname = "systemd";
|
||||||
|
version = "0.0.1";
|
||||||
|
src = gitSource { root = ./.; };
|
||||||
|
|
||||||
|
minimalOCamlVersion = "5.1";
|
||||||
|
dontStrip = true;
|
||||||
|
|
||||||
|
buildInputs = [
|
||||||
|
ppx_unicode
|
||||||
|
xlog
|
||||||
|
ptime
|
||||||
|
dune-configurator
|
||||||
|
cstruct
|
||||||
|
eio
|
||||||
|
eio_main
|
||||||
|
eio_linux
|
||||||
|
] ++ lib.optionals withShell [ utop ];
|
||||||
|
nativeBuildInputs = [ ppx_unicode dune-configurator ] ++ lib.optionals withShell [
|
||||||
|
ocaml dune_3 odoc utop
|
||||||
|
];
|
||||||
|
}
|
|
@ -0,0 +1 @@
|
||||||
|
(import <nixpkgs> {}).ocamlPackages.callPackage ./package.nix { withShell = true; }
|
|
@ -0,0 +1,38 @@
|
||||||
|
# This file is generated by dune, edit dune-project instead
|
||||||
|
opam-version: "2.0"
|
||||||
|
version: "0.0.1"
|
||||||
|
synopsis: "libsystemd-like functionality for native ocaml"
|
||||||
|
description:
|
||||||
|
"utilities for interacting with systemd when running as a service"
|
||||||
|
authors: ["xenia <xenia@awoo.systems>"]
|
||||||
|
license: "unfree"
|
||||||
|
tags: ["meow"]
|
||||||
|
homepage: "https://git.lain.faith/haskal/ocaml-systemd"
|
||||||
|
depends: [
|
||||||
|
"ocaml"
|
||||||
|
"dune" {>= "3.15"}
|
||||||
|
"cstruct" {>= "6.2.0"}
|
||||||
|
"dune-configurator" {>= "3.15.2"}
|
||||||
|
"eio" {>= "1.1"}
|
||||||
|
"eio_linux" {>= "1.1"}
|
||||||
|
"eio_main" {>= "1.1"}
|
||||||
|
"ppx_unicode" {>= "0.0.1"}
|
||||||
|
"ptime" {>= "1.1"}
|
||||||
|
"xlog" {>= "0.1.0"}
|
||||||
|
"odoc" {with-doc}
|
||||||
|
]
|
||||||
|
build: [
|
||||||
|
["dune" "subst"] {dev}
|
||||||
|
[
|
||||||
|
"dune"
|
||||||
|
"build"
|
||||||
|
"-p"
|
||||||
|
name
|
||||||
|
"-j"
|
||||||
|
jobs
|
||||||
|
"@install"
|
||||||
|
"@runtest" {with-test}
|
||||||
|
"@doc" {with-doc}
|
||||||
|
]
|
||||||
|
]
|
||||||
|
dev-repo: "https://git.lain.faith/haskal/ocaml-systemd.git"
|
Loading…
Reference in New Issue