diff --git a/bin/caching.ml b/bin/caching.ml index 1b6fd2faba5f..fac9c0661c77 100644 --- a/bin/caching.ml +++ b/bin/caching.ml @@ -10,14 +10,14 @@ let man = $(b,dune cache-daemon) is a daemon that runs in the background and manages this shared cache. For instance, it makes sure that it does not grow too big and try to maximise sharing between the various - workspace that are using the shared cache.|} + workspaces that are using the shared cache.|} ; `P {|The daemon is automatically started by Dune when the shared cache is enabled. You do not need to run this command manually.|} ; `S "ACTIONS" ; `P {|$(b,start) starts the daemon if not already running.|} ; `P {|$(b,stop) stops the daemon.|} - ; `P {|$(b,trim) remove oldest files from the cache to free space.|} + ; `P {|$(b,trim) removes oldest files from the cache to free space.|} ; `Blocks Common.help_secs ] @@ -30,19 +30,21 @@ let start ~config ~foreground ~port_path ~root ~display = if display <> Some Config.Display.Quiet then Printf.printf "%s\n%!" ep in let f started = - let started content = - if foreground then show_endpoint content; - started content + let started daemon_info = + if foreground then show_endpoint daemon_info; + started ~daemon_info in Log.verbose := foreground; Cache_daemon.daemon ~root ~config started in match Daemonize.daemonize ~workdir:root ~foreground port_path f with | Result.Ok Finished -> () - | Result.Ok (Daemonize.Started (endpoint, _)) -> show_endpoint endpoint - | Result.Ok (Daemonize.Already_running (endpoint, _)) when not foreground -> + | Result.Ok (Daemonize.Started { daemon_info = endpoint; _ }) -> show_endpoint endpoint - | Result.Ok (Daemonize.Already_running (endpoint, pid)) -> + | Result.Ok (Daemonize.Already_running { daemon_info = endpoint; _ }) + when not foreground -> + show_endpoint endpoint + | Result.Ok (Daemonize.Already_running { daemon_info = endpoint; pid }) -> User_error.raise [ Pp.textf "already running on %s (PID %i)" endpoint (Pid.to_int pid) ] | Result.Error reason -> User_error.raise [ Pp.text reason ] @@ -64,7 +66,7 @@ let trim ~trimmed_size ~size = match (trimmed_size, size) with | Some trimmed_size, None -> Result.Ok trimmed_size | None, Some size -> Result.Ok (Cache.Local.size cache - size) - | _ -> Result.Error "specify either --size either --trimmed-size" + | _ -> Result.Error "specify either --size or --trimmed-size" in Cache.Local.trim cache trimmed_size with @@ -98,7 +100,7 @@ let term = Arg.( value & flag & info [ "foreground"; "f" ] - ~doc:"Whether to start in the foreground or as a daeon") + ~doc:"Whether to start in the foreground or as a daemon") and+ exit_no_client = let doc = "Whether to exit once all clients have disconnected" in Arg.( @@ -110,7 +112,7 @@ let term = value & opt path_conv (Cache_daemon.default_port_file ()) & info ~docv:"PATH" [ "port-file" ] - ~doc:"The file to read/write the daemon port to/from.") + ~doc:"The file to read/write the daemon port from/to.") and+ root = Arg.( value diff --git a/src/stdune/daemonize.ml b/src/stdune/daemonize.ml index 5516314c1444..c12b7b8dc31e 100644 --- a/src/stdune/daemonize.ml +++ b/src/stdune/daemonize.ml @@ -1,6 +1,12 @@ type status = - | Started of string * Pid.t - | Already_running of string * Pid.t + | Started of + { daemon_info : string + ; pid : Pid.t + } + | Already_running of + { daemon_info : string + ; pid : Pid.t + } | Finished let retry ?message ?(count = 100) f = @@ -63,9 +69,10 @@ let check_beacon ?(close = true) p = | Result.Error _ -> Result.Error (Printf.sprintf "unable to open %s" p) let daemonize ?workdir ?(foreground = false) beacon - (f : (string -> unit) -> unit) = + (f : (daemon_info:string -> unit) -> unit) = let f fd = - let f () = f (fun content -> ignore (seal_beacon beacon fd content)) + let f () = + f (fun ~daemon_info -> ignore (seal_beacon beacon fd daemon_info)) and finally () = Unix.truncate (Path.to_string beacon) 0 in Exn.protect ~f ~finally in @@ -124,7 +131,7 @@ let daemonize ?workdir ?(foreground = false) beacon try Some (Unix.openfile path [ Unix.O_RDONLY ] 0o600) with Unix.Unix_error (Unix.ENOENT, _, _) -> None) in - let+ content, pid = + let+ daemon_info, pid = retry ~message: (Printf.sprintf "waiting for beacon file \"%s\" to be locked" path) @@ -134,8 +141,9 @@ let daemonize ?workdir ?(foreground = false) beacon Some (Io.read_all (Unix.in_channel_of_descr fd), pid) | _ -> None) in - Started (content, Pid.of_int pid) - | Some (e, pid, _) -> Result.Ok (Already_running (e, Pid.of_int pid)) + Started { daemon_info; pid = Pid.of_int pid } + | Some (daemon_info, pid, _) -> + Result.Ok (Already_running { daemon_info; pid = Pid.of_int pid }) let stop beacon = let open Result.O in @@ -150,6 +158,6 @@ let stop beacon = match kill Sys.sigterm with | Error _ -> (* Unfortunately the logger may not be set. Print on stderr directly? *) - (* Log.infof "unable to terminate daemon with SIGTERM, using SIGKILL"; *) + (* Log.info "unable to terminate daemon with SIGTERM, using SIGKILL"; *) kill Sys.sigkill | ok -> ok ) diff --git a/src/stdune/daemonize.mli b/src/stdune/daemonize.mli index 7f491059df62..98326dd530ad 100644 --- a/src/stdune/daemonize.mli +++ b/src/stdune/daemonize.mli @@ -4,25 +4,31 @@ guaranteeing that at most one instance will run at any given time. The daemon has to call a given callback to indicate that it has successfully started, unlocking all other potential start attempts. This callback can be - given a payload that can be retrieved by the starting process and other - start attempts - e.g. the endpoint to contact the damon on. *) + given [daemon_info] that can be retrieved by the starting process and other + start attempts, e.g. the endpoint to contact the daemon on. *) (** Result of a daemonization *) type status = - | Started of string * Pid.t - (** The daemon was started in the background with the given payload and - pid *) - | Already_running of string * Pid.t - (** The daemon is already running in the background with the given payload - and pid *) + | Started of + { daemon_info : string + ; pid : Pid.t + } + (** The daemon was started in the background with the given [daemon_info] + and [pid]. *) + | Already_running of + { daemon_info : string + ; pid : Pid.t + } + (** The daemon is already running in the background with the given + [daemon_info] and [pid]. *) | Finished (** The daemon was run synchronously and exited. *) val daemonize : ?workdir:Path.t (** The path to chdir to *) -> ?foreground:bool - (** Whether to fork a daemon or run synchronously (defaults true) *) - -> Path.t (** The path of the beacon file *) - -> ((string -> unit) -> unit) (** The daemon main routine *) + (** Whether to fork a daemon or run synchronously (defaults to [true]) *) + -> Path.t (** The path to the beacon file *) + -> ((daemon_info:string -> unit) -> unit) (** The daemon main routine *) -> (status, string) Result.t val stop : Path.t -> (unit, string) Result.t