Merge branch 'toplevel-ppx' of https://github.com/stephanieyou/dune i…

…nto toplevel-ppx

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

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 )

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