Commits

seanmcl  committed b2b573a

cleanup server

  • Participants
  • Parent commits 59e3a37

Comments (0)

Files changed (2)

 type path = string
 type elisp = string
 type 'a result = ('a, exn) Result.t
-type 'a deferred = 'a Deferred.t
 
 val debug : bool ref
 

File omake_server.ml

 module Ashell = struct
   let run cmd args = In_thread.run (fun () -> Shell.run cmd args)
   let run_lines cmd args = In_thread.run (fun () -> Shell.run_lines cmd args)
+  let touch file = run "touch" [file]
+  let rm file = Asys.file_exists file >>= function
+  | `Yes -> Aunix.unlink file
+  | `No | `Unknown -> Deferred.unit
+end
+
+module Exn = struct
+  include Exn
+  (* Exn.to_string is useless for debugging in Async.  We need the
+     exception extracted from the monitor. *)
+  let to_string exn = Exn.to_string (Monitor.extract_exn exn)
+end
+
+module String = struct
+  include String
+  let paren s = sprintf "(%s)" s
+end
+
+module Elisp : sig
+  val list : 'a list -> f:('a -> string) -> string
+end = struct
+  let list l ~f = String.concat ~sep:" " ("(list" :: List.map ~f l @ [")"])
 end
 
 (* -------------------------------------------------------------------------- *)
 type elisp = string
 type 'a deferred = 'a Deferred.t
 type ('a, 'b) result = ('a, 'b) Result.t
-let paren s = sprintf "(%s)" s
-let rm file = Asys.file_exists file >>= function
-  | `Yes -> Aunix.unlink file
-  | `No | `Unknown -> Deferred.unit
-let touch file = Ashell.run "touch" [file]
-let user = Shell.whoami ()
-let time_prefix () = sprintf "[%s]" (Time.to_string (Time.now ()))
-let log_msg s = sprintf "%s %s\n" (time_prefix()) s
-let ( ** ) f g x = f (g x)
-let dprintf fmt = Printf.printf (fmt ^^ "\n%!")
-let exn_to_string exn = Exn.to_string (Monitor.extract_exn exn)
-(* CR sweeks: Disabling [Exn] is perverse. *)
-module Exn = struct end
 
 (* -------------------------------------------------------------------------- *)
 (*  Ids                                                                       *)
 (* We get the ids from emacs and assume they are correct. *)
 module Id : sig
   type t with sexp
-  val of_string : string -> t
-  val to_string : t -> string
+  include Hashable.S with type t := t
+  include Stringable.S with type t := t
 end = struct
-  type t = string with sexp
-  let of_string s = s
-  let to_string s = s
+  include String
 end
 
 (* -------------------------------------------------------------------------- *)
      opposite of what we want. *)
   let shared_root = "/tmp/omake-server"
   let _ = Shell.mkdir ~p:() ~perm:0o777 shared_root
+  let user = Shell.whoami ()
   let root = sprintf "%s/%s" shared_root user
   let _ = Shell.mkdir ~p:() root
 
 (* -------------------------------------------------------------------------- *)
 
 (* Write to the server log *)
-module Server : sig
-  val logf : ('a, unit, string, unit) format4 -> 'a
-  val wait_for_log : unit -> unit deferred
-  val log_exn : ?msg:string -> exn -> unit
+module Log : sig
+  val printf : ('a, unit, string, unit) format4 -> 'a
+  val wait : unit -> unit deferred
+  val exn : ?msg:string -> exn -> unit
+  val msg : string -> string
 end = struct
   let log_writer = lazy (Writer.open_file ~append:true File.server_log)
-  let wait_for_log () = Lazy.force log_writer >>| fun _ -> ()
-  let logf fmt =
+  let wait () = Lazy.force log_writer >>| fun _ -> ()
+  let time_prefix () = sprintf "[%s]" (Time.to_string (Time.now ()))
+  let msg s = sprintf "%s %s\n" (time_prefix()) s
+  let printf fmt =
     match Deferred.peek (Lazy.force log_writer) with
     | None ->
       eprintf "WARNING: no log writer.  Writing to stderr.\n";
-      ksprintf (fun s -> eprintf "%s" (log_msg s)) fmt
+      ksprintf (fun s -> eprintf "%s" (msg s)) fmt
     | Some writer ->
-      ksprintf (fun s -> Writer.writef writer "%s" (log_msg s)) fmt
-  let log_exn ?(msg = "Caught exception") e =
-    logf "%s: %s" msg (exn_to_string e)
+      ksprintf (fun s -> Writer.writef writer "%s" (msg s)) fmt
+  let exn ?(msg = "Caught exception") e =
+    printf "%s: %s" msg (Exn.to_string e)
 end
 
 (* -------------------------------------------------------------------------- *)
 module To_emacs : sig
   val pid : unit -> Pid.t
   val set_pid : Pid.t -> unit
-  val send : Writer.t -> ('a, unit, string, unit deferred) format4 -> 'a
+  val send : Writer.t -> ('a, unit, string, unit) format4 -> 'a
   val send_async : ('a, unit, string, unit) format4 -> 'a
   val load_file : Id.t -> unit
-  val message : Writer.t -> ('a, unit, string, unit deferred) format4 -> 'a
+  val message : Writer.t -> ('a, unit, string, unit) format4 -> 'a
 end = struct
   let get_set name =
     let x = ref None in
   (* The pid of the emacs that started the server *)
   let (pid, set_pid) = get_set "pid"
 
-  (* CR sweeks: [send_str] should not return a deferred. *)
   let send_str writer msg =
     let esc_msg = String.escaped msg in
     let header = sprintf "(Omake.Server.logf \"Server  : %s\")" esc_msg in
     let full = sprintf "(progn %s %s)" header msg in
-    Server.logf "Writing: %s" (String.escaped full);
-    Writer.writef writer "%s" full;
-    Deferred.unit
+    Log.printf "Writing: %s" (String.escaped full);
+    Writer.writef writer "%s" full
 
   let send writer fmt = ksprintf (send_str writer) fmt
 
   let send_str_async msg =
-    (* newline is very important here.  It designates an end of input. *)
+    (* newline is important here.  It designates an end of input. *)
     printf "%s\n" msg
 
   let send_async fmt = ksprintf send_str_async fmt
 
   let message writer fmt =
     ksprintf (fun s -> send_str writer (sprintf "(message \"%s\")" s)) fmt
-  ;;
 end
 
 (* -------------------------------------------------------------------------- *)
     mutable limit_subdirs_for_speed : bool;
   } with sexp, fields
 
-  let var_to_string = Sexp.to_string ** sexp_of_var
+  let var_to_string x = Sexp.to_string (sexp_of_var x)
 
   let var_to_get = function
   | X_LIBRARY_INLINING -> x_library_inlining
         Reader.load_sexp file t_of_sexp >>= function
         | Ok t -> return t
         | Error error ->
-          Server.logf
+          Log.printf
             "Can't read env file for %s (%s).  Writing new file from bash env."
             (Id.to_string id)
-            (exn_to_string error);
+            (Exn.to_string error);
             (* (Error.to_string_hum error); *)
           create id
       end
     save id t
 
   let setenv_all id =
-    env id >>| fun t -> (
+    env id >>| fun t ->
+    begin
       setenv ~key:(var_to_string X_LIBRARY_INLINING) ~data:(string_of_bool t.x_library_inlining);
       setenv ~key:(var_to_string LINK_EXECUTABLES) ~data:(string_of_bool t.link_executables);
       setenv ~key:(var_to_string VERSION_UTIL_SUPPORT) ~data:(string_of_bool t.version_util_support);
       setenv ~key:(var_to_string LIMIT_SUBDIRS_FOR_SPEED) ~data:(string_of_bool t.limit_subdirs_for_speed);
-    )
+    end
 
   let set_emacs_env writer id =
-    env id >>= fun t ->
+    env id >>| fun t ->
     To_emacs.send writer " \
 (setq Omake.Env.x-library-inlining '%b \
       Omake.Env.link-executables '%b \
       t.alert_when_omake_dies
 
   let logf t fmt =
-    ksprintf (fun s -> Writer.write t.log_writer (log_msg s)) fmt
+    ksprintf (fun s -> Writer.write t.log_writer (Log.msg s)) fmt
 
   let handle_dead_omake_process t =
     let ids = Id.to_string t.id in
     t.omake_process_status >>> (fun res ->
       if t.alert_when_omake_dies then begin
-        Server.logf "Process died for model: %s" ids;
+        Log.printf "Process died for model: %s" ids;
         To_emacs.send_async
           "(Omake.Ocaml.update-model-dead :id \"%s\" :msg \"The omake process is dead: %s.\")"
           ids
       in
       let omake_file = File.omake id in
       let log_file = File.log id in
-      rm omake_file >>= fun () ->
-      rm (File.elisp id) >>= fun () ->
-      rm (File.log id) >>= fun () ->
+      Ashell.rm omake_file >>= fun () ->
+      Ashell.rm (File.elisp id) >>= fun () ->
+      Ashell.rm (File.log id) >>= fun () ->
       Writer.open_file ~append:true log_file >>= fun log_writer ->
-      touch omake_file >>= fun () ->
+      Ashell.touch omake_file >>= fun () ->
       Aunix.with_file omake_file ~mode:[`Rdwr] ~perm:0o777 ~f:(fun fd ->
         (* cd to the directory where omake should run *)
         Asys.chdir compilation_dir >>= fun () ->
         | `Error exn -> raise exn)) >>= function
     | Ok t -> return t
     | Error exn ->
-      Server.logf "ERROR: %s" (exn_to_string exn);
+      Log.printf "ERROR: %s" (Exn.to_string exn);
       raise exn
 
   let start ?file t =
     let elisp_pipe = Omake.parse_omake_output ~omakeroot_dir reader in
     Pipe.iter elisp_pipe ~f:(function
     | Error exn ->
-      logf t "ERROR: %s" (exn_to_string exn);
+      logf t "ERROR: %s" (Exn.to_string exn);
       Deferred.unit
     | Ok elisp ->
       logf t "New output";
       Ashell.run "kill" [pid]) >>| function
     | Ok () -> ()
     | Error exn ->
-      Server.log_exn ~msg:"Error killing processes" exn
+      Log.exn ~msg:"Error killing processes" exn
 end
 
 (* -------------------------------------------------------------------------- *)
   let module Q = Query in
   let module C = Model.Create in
   let model_exists id =
-    Server.logf "A model for %s already exists" (Id.to_string id)
+    Log.printf "A model for %s already exists" (Id.to_string id)
   in
   let no_model id =
-    Server.logf "There is no model for %s" (Id.to_string id)
+    Log.printf "There is no model for %s" (Id.to_string id)
   in
-
   try
     match Query.t_of_sexp s with
     | Q.List ->
       let ids =
         String.concat ~sep:" " (List.map (Models.list ()) ~f:Id.to_string)
-        |! paren
+        |! String.paren
       in
-      To_emacs.message writer "ids: %s" ids
+      To_emacs.message writer "ids: %s" ids;
+      Deferred.unit
     | Q.Ping { Query.version; uid } ->
-      if version = omake_server_version then To_emacs.send_async "(Omake.Ping.ack %d)" uid
+      begin
+      if version = omake_server_version then
+        To_emacs.send_async "(Omake.Ping.ack %d)" uid
       else
         To_emacs.send_async
           "(Omake.Ping.version-mismatch :server-received %d :server-version %d)"
-          version omake_server_version;
+          version omake_server_version
+      end;
       Deferred.unit
     | Q.Set_emacs_env id -> Env.set_emacs_env writer id
     | Q.Create create ->
       begin
         Env.setenv_all id >>= fun () ->
         Models.create create >>| function
-        | Ok () -> Server.logf "Model created: %s" ids
+        | Ok () -> Log.printf "Model created: %s" ids
         | Error `Already_exists -> model_exists id
       end
     | Q.Kill id ->
       let ids = Id.to_string id in
       begin Models.kill id >>| function
-        | Ok () -> Server.logf "Model killed: %s" ids
+        | Ok () -> Log.printf "Model killed: %s" ids
         | Error `No_model -> no_model id
       end
     | Q.Get_project_env (id, x) ->
-      begin
-        Env.get id x
-        >>= fun b ->
-        To_emacs.message writer "%s = %b" (Env.var_to_string x) b;
-      end;
+      Env.get id x
+      >>| fun b ->
+      To_emacs.message writer "%s = %b" (Env.var_to_string x) b
     | Q.Set_project_env (id, x, b) ->
       Env.set id x b >>| fun () ->
-      Server.logf "Server: %s set to %b" (Env.var_to_string x) b
+      Log.printf "Server: %s set to %b" (Env.var_to_string x) b
     | Q.Show_model id ->
       let msg = match Models.get id with
       | None -> sprintf "No model for id: %s" (Id.to_string id)
       | Some m -> sprintf "Model:\n%s" (Model.to_string_hum m)
       in
-      Server.logf "%s" msg;
+      Log.printf "%s" msg;
       Deferred.unit
   with exn ->
-    Server.logf "Bad input: %s" (Sexp.to_string s);
+    Log.printf "Bad input: %s" (Sexp.to_string s);
     raise exn
 
 (* Die if emacs dies *)
     match Result.try_with (fun () -> Signal.send_exn Signal.zero (`Pid pid)) with
     | Ok () -> ()
     | Error exn ->
-      Server.logf "Sending signal 0 to pid %s returned %s"
+      Log.printf "Sending signal 0 to pid %s returned %s"
         (Pid.to_string pid) (Core.Std.Exn.to_string exn);
       shutdown 1)
-;;
 
 let serve () =
   (* Ignore SIGTERM due to a bug where emacsclient mysteriously
      kills the server. (Issue #56) *)
   Signal.handle [Signal.term] ~f:ignore;
-  rm File.socket >>= fun () ->
+  Ashell.rm File.socket >>= fun () ->
   (* Wait for the log to open *)
-  Server.wait_for_log ()
+  Log.wait ()
   >>= fun () ->
-  Server.logf "starting server on %s" File.socket;
-  (* Server.logf "%s" Version_util.version;
-   * Server.logf "%s" Version_util.build_info; *)
+  Log.printf "starting server on %s" File.socket;
+  (* Log.printf "%s" Version_util.version;
+   * Log.printf "%s" Version_util.build_info; *)
   watch_for_dead_emacs ();
   Tcp.serve_unix ~file:File.socket ~on_handler_error:`Raise (fun _ reader writer ->
     try_with (fun () ->
         Writer.close writer >>= fun () ->
         failwith "Read error"
       | `Ok s ->
-        Server.logf "omake server received: %s" (Sexp.to_string s);
+        Log.printf "omake server received: %s" (Sexp.to_string s);
         handle_query writer s >>= fun () ->
         Writer.close writer) >>= function
     | Ok () -> Deferred.unit
     | Error exn ->
-      Server.log_exn (Monitor.extract_exn exn);
+      Log.exn (Monitor.extract_exn exn);
       Deferred.unit)
-;;
 
 let connect msg =
   (* Make sure the message ends with a space so the sexp parser knows
 (*  Command                                                                   *)
 (* -------------------------------------------------------------------------- *)
 
+module Flags = struct
+  open Command.Spec
+  let unit = const ()
+  let pid = flag
+    "-emacs-pid" (required int) ~doc:"INT pid of the associated emacs process"
+  let msg = anon ("message" %: string)
+  let debug = flag
+    "-debug" no_arg ~doc:" Print debugging info into [omake-server-log]"
+end
+
 let schedule ~f ?quit () =
   begin
     f () >>> (fun () -> if is_some quit then shutdown 0)
   ~summary:"Start the omake server"
   Command.Spec.(
     flag "-emacs-pid" (required int) ~doc:"INT pid of the associated emacs process"
-    ++ flag "-debug" no_arg ~doc:" Print debugging info into [omake-server-log]"
+    ++ Flags.debug
   )
   (fun pid debug ->
     let pid = Pid.of_int pid in
         To_emacs.set_pid pid;
         serve ()) >>| function
       | Ok () -> ()
-      | Error exn -> Server.log_exn exn)
+      | Error exn -> Log.exn exn)
     ())
 
 let send_cmd =
   Command.basic
     ~summary:"Send a message to the server."
-    Command.Spec.(
-      anon ("message" %: string)
-    )
+    Command.Spec.( Flags.msg )
     (fun msg ->
       schedule
         ~f:(fun () ->
-          Server.wait_for_log ()
+          Log.wait ()
           >>= fun () ->
           try_with (fun () -> connect msg)
           >>| function
           | Ok () -> ()
           | Error exn ->
-            Server.log_exn exn;
+            Log.exn exn;
             To_emacs.send_async "(message \"Omake server error.  Do M-x Omake.show-server-log\")")
         ~quit:()
         ())
-;;
 
 let in_use_cmd =
   Command.basic
         ~f:(fun () -> try_with (fun () -> connect msg) >>| function
         | Ok () -> shutdown 0
         | Error exn ->
-          printf "Omake server error: %s\n" (exn_to_string exn);
+          printf "Omake server error: %s\n" (Exn.to_string exn);
           shutdown 1)
         ~quit:()
         ())
         let elisp = Omake.parse_omake_output ~omakeroot_dir:"/a/b/c" lines in
         Pipe.iter elisp ~f:(function
         | Error exn ->
-          printf "%s\n" (exn_to_string exn);
+          printf "%s\n" (Exn.to_string exn);
           shutdown 1;
           Deferred.unit
         | Ok e ->
 let cmd = Command.group ~summary:"Omake server"
   [ ( "start", start_cmd )
   ; ( "send", send_cmd )
+  ; ( "version", version_cmd )
+  ; ( "in-use", in_use_cmd )
+    (* Debug *)
   ; ( "debug", debug_cmd )
-  ; ( "server-version", version_cmd )
-  ; ( "in-use", in_use_cmd )
   ; ( "show-model", show_model_cmd )
   ]