js-elisp / omake_server.ml

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
open Core.Std
open Async.Std

module Command = Core_extended.Core_command
module Process = Process

module Unix = Core.Std.Unix
module Aunix = Async.Std.Unix

module Asys = Async.Std.Sys
module Sys = Core.Std.Sys

module Shell = Core_extended.Std.Shell

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

(* -------------------------------------------------------------------------- *)
(*  Version                                                                   *)
(* -------------------------------------------------------------------------- *)

(* Use a version number to synchronize with the elisp code. *)
let omake_server_version = 10

(* -------------------------------------------------------------------------- *)
(*  Util                                                                      *)
(* -------------------------------------------------------------------------- *)

type path = string with sexp
type elisp = string
type 'a deferred = 'a Deferred.t
type ('a, 'b) result = ('a, 'b) Result.t

(* -------------------------------------------------------------------------- *)
(*  Ids                                                                       *)
(* -------------------------------------------------------------------------- *)

(* We get the ids from emacs and assume they are correct. *)
module Id : sig
  type t with sexp
  include Hashable.S with type t := t
  include Stringable.S with type t := t
end = struct
  include String
end

(* -------------------------------------------------------------------------- *)
(*  Files                                                                     *)
(* -------------------------------------------------------------------------- *)

module File : sig
  val omake      : Id.t -> path
  val elisp      : Id.t -> path
  val log        : Id.t -> path
  val env        : Id.t -> path
  val server_log : path
  val socket     : path
end = struct
  (* The below code is not equivalent to

       Shell.mkdir ~p:() ~perm:0o777 root

     mkdir -p only sets the permissions of the deepest dir according to [perm].  Ancestor
     directories are set as per umask.  So, the below code sets /tmp/omake-server to
     777 and /tmp/omake-server/$user to the umask, while the above code would set
     /tmp/omake-server to the umask and /tmp/omake-server/$user to 777, exactly the
     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

  let project_dir id =
    let dir = sprintf "%s%s" root (Id.to_string id) in
    Shell.mkdir ~p:() dir;
    dir

  let project_file name id =
    sprintf "%s/%s" (project_dir id) name

  let omake = project_file "omake"
  let elisp = project_file "elisp"
  let log = project_file "log"
  let env = project_file "env"
  let server_log = sprintf "%s/server-log" root
  let socket = sprintf "%s/socket" root
end

(* -------------------------------------------------------------------------- *)
(*  Logging                                                                   *)
(* -------------------------------------------------------------------------- *)

(* Write to the server log *)
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 () = 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" (msg s)) fmt
    | Some writer ->
      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

(* -------------------------------------------------------------------------- *)
(*  Elisp                                                                     *)
(* -------------------------------------------------------------------------- *)

module To_emacs : sig
  val pid : unit -> Pid.t
  val set_pid : Pid.t -> unit
  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) format4 -> 'a
end = struct
  let get_set name =
    let x = ref None in
    let get () = match !x with
      | Some x -> x
      | None -> failwithf "Impossible: no %s" name ()
    in
    let set n = x := Some n in
    (get, set)

  (* The pid of the emacs that started the server *)
  let (pid, set_pid) = get_set "pid"

  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
    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 important here.  It designates an end of input. *)
    printf "%s\n" msg

  let send_async fmt = ksprintf send_str_async fmt

  let load_file id = send_async "(load \"%s\" t t t)" (File.elisp id)

  let message writer fmt =
    ksprintf (fun s -> send_str writer (sprintf "(message \"%s\")" s)) fmt
end

(* -------------------------------------------------------------------------- *)
(*  Env                                                                       *)
(* -------------------------------------------------------------------------- *)

(* The important environment variables for omake are

   VERSION_UTIL_SUPPORT
   LINK_EXECUTABLES
   X_LIBRARY_INLINING
   LIMIT_SUBDIRS_FOR_SPEED

   We make sure they're set when the server starts. *)
module Env : sig
  type var =
  | X_LIBRARY_INLINING
  | LINK_EXECUTABLES
  | VERSION_UTIL_SUPPORT
  | LIMIT_SUBDIRS_FOR_SPEED with sexp
  val var_to_string : var -> string
  val set : Id.t -> var -> bool -> unit deferred
  val get : Id.t -> var -> bool deferred
  val set_emacs_env : Writer.t -> Id.t -> unit deferred
  val setenv_all : Id.t -> unit deferred
end = struct
  type var =
  | X_LIBRARY_INLINING
  | LINK_EXECUTABLES
  | VERSION_UTIL_SUPPORT
  | LIMIT_SUBDIRS_FOR_SPEED with sexp

  type t = {
    mutable version_util_support : bool;
    mutable link_executables : bool;
    mutable x_library_inlining : bool;
    mutable limit_subdirs_for_speed : bool;
  } with sexp, fields

  let var_to_string x = Sexp.to_string (sexp_of_var x)

  let var_to_get = function
  | X_LIBRARY_INLINING -> x_library_inlining
  | LINK_EXECUTABLES -> link_executables
  | VERSION_UTIL_SUPPORT -> version_util_support
  | LIMIT_SUBDIRS_FOR_SPEED -> limit_subdirs_for_speed

  let var_to_set = function
  | X_LIBRARY_INLINING -> set_x_library_inlining
  | LINK_EXECUTABLES -> set_link_executables
  | VERSION_UTIL_SUPPORT -> set_version_util_support
  | LIMIT_SUBDIRS_FOR_SPEED -> set_limit_subdirs_for_speed

  (*** make sure all the env variables are set. ***)

  let get = Sys.getenv

  let setenv ~key ~data = Unix.putenv ~key ~data

  let get_exn key = match get key with
    | None -> failwithf "No env: %s" key ()
    | Some data -> data

  let get_bool_exn key = get_exn key |! Bool.of_string

  let assure_set ~default ~key =
    match get key with
    | None -> setenv ~key ~data:default
    | Some _ -> ()

  let () = begin
    assure_set ~default:"true"  ~key:"VERSION_UTIL_SUPPORT"   ;
    assure_set ~default:"true"  ~key:"LINK_EXECUTABLES"       ;
    assure_set ~default:"true"  ~key:"X_LIBRARY_INLINING"     ;
    assure_set ~default:"false" ~key:"LIMIT_SUBDIRS_FOR_SPEED";
  end

  let home = get_exn "HOME"

  let env_dir id = sprintf "%s/.omake-server/%s" home id

  let env_file id = sprintf "%s/%s" (env_dir id) "env.sexp"

  let save id t =
    let ids = Id.to_string id in
    Shell.mkdir ~p:() (env_dir ids);
    Writer.save_sexp (env_file ids) (sexp_of_t t)

  let create id =
    let t = {
      version_util_support = get_bool_exn "VERSION_UTIL_SUPPORT";
      link_executables = get_bool_exn "LINK_EXECUTABLES";
      x_library_inlining = get_bool_exn "X_LIBRARY_INLINING";
      limit_subdirs_for_speed = get_bool_exn "LIMIT_SUBDIRS_FOR_SPEED";
    }
    in
    save id t >>| fun () ->
    t

  let env id =
    let file = env_file (Id.to_string id) in
    Asys.file_exists_exn file >>= function
    | true ->
      begin
        Reader.load_sexp file t_of_sexp >>= function
        | Ok t -> return t
        | Error error ->
          Log.printf
            "Can't read env file for %s (%s).  Writing new file from bash env."
            (Id.to_string id)
            (Exn.to_string error);
            (* (Error.to_string_hum error); *)
          create id
      end
    | false -> create id

  let get id x =
    env id >>| fun t -> var_to_get x t

  let set id x b =
    env id >>= fun t ->
    var_to_set x t b;
    setenv ~key:(var_to_string x) ~data:(string_of_bool b);
    save id t

  let setenv_all id =
    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 ->
    To_emacs.send writer " \
(setq Omake.Env.x-library-inlining '%b \
      Omake.Env.link-executables '%b \
      Omake.Env.version-util-support '%b \
      Omake.Env.limit-subdirs-for-speed '%b)"
      t.x_library_inlining
      t.link_executables
      t.version_util_support
      t.limit_subdirs_for_speed

end

(* -------------------------------------------------------------------------- *)
(*  Jomake command                                                            *)
(* -------------------------------------------------------------------------- *)

(* Parse the omake command line from the user.  *)
module Omake_command : sig
  type t
  val parse : string -> t option
  val prog : t -> string
  val args : t -> string list
end = struct
  type t = {
    command : string;
    processes : int;
    user_options : string list;
  }

  let default_processes = 12

  let required_options = [
    "-P";
    "-w";
    "--output-postpone";
    "--verbose";
    "--progress";
  ]

  let parse s =
    try
      match String.split ~on:' ' s with
      | [] -> None
      | command :: words ->
        let user = List.filter words ~f:(fun w ->
          not (
            String.equal w "jomake"
            || String.equal w "omake"
            || List.mem required_options w))
        in
        let (user_options, processes) =
        (* ...; "-j"; "5"; ... *)
          match List.findi user ~f:(fun _ -> function | "-j" -> true | _ -> false) with
          | None ->
            (user, default_processes)
          | Some (i, _) ->
            if List.length user < i + 1 then failwith "length"
            else
              let ps = Int.of_string (List.nth_exn user (i + 1)) in
              let opts = List.take user (i - 1) @ List.drop user (i + 2) in
              (opts, ps)
        in
        Some { command; processes; user_options }
    with _ -> None

  let prog t = t.command
  let args t =
    required_options @ "-j" :: Int.to_string t.processes :: t.user_options
end

(* -------------------------------------------------------------------------- *)
(*  Model                                                                     *)
(* -------------------------------------------------------------------------- *)

(* Notes:
   - All paths must be fully expanded.  Sys.chdir can't handle shell
     variables like ~
   - Calling Process.create_fds creates a shell that calls omake.  We
     can't simply kill the pid of the shell, because the omake process
     just gets a new parent (init) but doesn't die.  We instead kill all
     children of the shell manually.
*)
module Model : sig
  module Create : sig
    type t = {
      id : Id.t;
      omakeroot_dir : path;
      compilation_dir : path;
      user_command : string;
    } with sexp
  end
  type t = {
    id : Id.t;
    (* Full path to directory where compilation started, so you
       can cd there to start omake *)
    compilation_dir : path;
    (* full path to Omakeroot dir, used for  *)
    omakeroot_dir : path;
    (* Writer to the log file for debugging *)
    log_writer : Writer.t;
    (* Pid of the shell managing the omake process *)
    pid : Pid.t;
    (* Exit status of the omake parent process. *)
    omake_process_status : Unix.Exit_or_signal.t deferred;
    (* Whether to alert emacs when the omake process is dead. *)
    mutable alert_when_omake_dies : bool;
  }
  val create : Create.t -> t deferred
  val start : ?file:path -> t -> unit deferred
  val kill : t -> unit deferred
  val logf : t -> ('a, unit, string, unit) format4 -> 'a
  val to_string_hum : t -> string
end = struct
  module Create = struct
    type t = {
      id : Id.t;
      omakeroot_dir : path;
      compilation_dir : path;
      user_command : string;
    } with sexp
  end
  type t = {
    id : Id.t;
    compilation_dir : path;
    omakeroot_dir : path;
    log_writer : Writer.t;
    pid : Pid.t;
    omake_process_status : Unix.Exit_or_signal.t deferred;
    mutable alert_when_omake_dies : bool;
  }

  let to_string_hum t =
    sprintf "{ id = %s; omakeroot = %s; compilation = %s; pid = %s; determined = %b; alert = %b; }"
      (Id.to_string t.id)
      t.omakeroot_dir
      t.compilation_dir
      (Pid.to_string t.pid)
      (Deferred.is_determined t.omake_process_status)
      t.alert_when_omake_dies

  let logf t 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
        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
          (Unix.Exit_or_signal.to_string_hum res)
      end)

  let create t =
    try_with (fun () ->
      let id = t.Create.id in
      let compilation_dir = t.Create.compilation_dir in
      let omakeroot_dir = t.Create.omakeroot_dir in
      let command = match Omake_command.parse t.Create.user_command with
        | None -> failwithf "Can't parse user command: %s" t.Create.user_command ()
        | Some command -> command
      in
      let omake_file = File.omake id in
      let log_file = File.log id in
      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 ->
      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 () ->
        (* start omake *)
        let t = Fd.with_file_descr fd (fun omake_writer_descr ->
        let pid = ref None in
        let omake_process_status = Process.create_fds
          ~kill:(Deferred.never ())
          ~prog:(Omake_command.prog command)
          ~args:(Omake_command.args command)
          ~stdin:Unix.stdin
          ~stdout:omake_writer_descr
          ~stderr:omake_writer_descr
          ~f:(fun pid' ->
            pid := Some pid';
            Writer.writef log_writer "Pid: %s\n" (Pid.to_string pid'))
        in
        let pid = match !pid with
          | None -> failwith "Impossible: f has returned"
          | Some pid -> pid
        in
        { id
        ; compilation_dir
        ; omakeroot_dir
        ; log_writer
        ; pid
        ; omake_process_status
        ; alert_when_omake_dies = true
        })
        in
        match t with
        | `Ok t ->
          handle_dead_omake_process t;
          return t
        | `Already_closed -> failwithf "Already closed: %s" (Id.to_string id) ()
        | `Error exn -> raise exn)) >>= function
    | Ok t -> return t
    | Error exn ->
      Log.printf "ERROR: %s" (Exn.to_string exn);
      raise exn

  let start ?file t =
    let module U = File_tail.Update in
    let module W = File_tail.Warning in
    let module E = File_tail.Error in
    let id = t.id in
    let file = Option.value file ~default:(File.omake id) in
    let omakeroot_dir = t.omakeroot_dir in
    logf t "Parsing omake output";
    let reader = File_tail.create ~break_on_lines:false file in
    let reader = Pipe.map reader ~f:(function
      | U.Data s -> s
      | U.Warning (s, w) ->
        logf t "File_tail warning: %s %s" s (W.to_string_hum w);
        ""
      | U.Error (s, e) -> logf t "File_tail ERROR: %s %s" s (E.to_string_hum e);
        "")
    in
    (* Split lines on \n and \r *)
    let reader =
      let partial = ref "" in
      let (r, w) = Pipe.create () in
      let iter () = Pipe.iter reader ~f:(fun s ->
        let lines = String.split_on_chars s ~on:['\n'; '\r'] in
        let n = List.length lines in
        match lines with
        | [] -> Deferred.unit
        | [m] ->
          partial := !partial ^ m;
          Deferred.unit
        | m :: ms ->
          let first = !partial ^ m in
          let middle = List.take ms (n - 2) in
          let last = List.last_exn ms in
          let complete = first :: middle in
          partial := last;
          Deferred.List.iter ~f:(Pipe.write w) complete)
      in
      whenever (iter ());
      r
    in
    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);
      Deferred.unit
    | Ok elisp ->
      logf t "New output";
      let file = File.elisp id in
      Writer.save file ~contents:elisp >>| fun () ->
      To_emacs.load_file id)

  let kill t =
    let pid = Pid.to_string t.pid in
    let kids = try_with (fun () ->
      Ashell.run_lines "pgrep" ["-P"; pid]) >>| function
        | Ok kids -> kids
        | Error _ -> []
    in
    kids >>= fun kids ->
    try_with (fun () ->
      t.alert_when_omake_dies <- false;
      Deferred.List.iter kids ~f:(fun k -> Ashell.run "kill" [k]) >>= fun () ->
      Ashell.run "kill" [pid]) >>| function
    | Ok () -> ()
    | Error exn ->
      Log.exn ~msg:"Error killing processes" exn
end

(* -------------------------------------------------------------------------- *)
(*  Models                                                                    *)
(* -------------------------------------------------------------------------- *)

module Models : sig
  val list : unit -> Id.t list
  val create : Model.Create.t -> (unit, [`Already_exists]) result deferred
  val kill : Id.t -> (unit, [`No_model]) result deferred
  val logf : Id.t -> ('a, unit, string, unit) format4 -> 'a
  val get : Id.t -> Model.t option
end = struct
  let models : (Id.t, Model.t) Hashtbl.t = Hashtbl.Poly.create ()

  let get = Hashtbl.find models

  let list () = Hashtbl.keys models

  let logf id fmt = match Hashtbl.find models id with
    | Some t -> Model.logf t fmt
    | None -> failwithf "Impossible: no model for %s" (Id.to_string id) ()

  let create c =
    let module C = Model.Create in
    let id = c.C.id in
    match Hashtbl.mem models id with
    | true -> return (Error `Already_exists)
    | false ->
      Model.create c >>| fun t ->
      whenever (Model.start t);
      Hashtbl.replace models ~key:id ~data:t;
      Ok ()

  let kill id = match Hashtbl.mem models id with
    | true ->
      Model.kill (Hashtbl.find_exn models id) >>| fun () ->
      Hashtbl.remove models id;
      Ok ()
    | false ->
      return (Error `No_model)
end

(* -------------------------------------------------------------------------- *)
(*  Query                                                                     *)
(* -------------------------------------------------------------------------- *)

module Query = struct
  type ping = { version : int; uid : int } with sexp
  type t =
  (* Synchronous *)
  | List
  | Create of Model.Create.t
  | Kill of Id.t
  | Get_project_env of Id.t * Env.var
  | Set_project_env of Id.t * Env.var * bool
  | Set_emacs_env of Id.t
  | Show_model of Id.t
  (* Asynchronous *)
  | Ping of ping
  with sexp
end

(* -------------------------------------------------------------------------- *)
(*  Server                                                                    *)
(* -------------------------------------------------------------------------- *)

let handle_query writer s =
  let module Q = Query in
  let module C = Model.Create in
  let model_exists id =
    Log.printf "A model for %s already exists" (Id.to_string id)
  in
  let no_model 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)
        |! String.paren
      in
      To_emacs.message writer "ids: %s" ids;
      Deferred.unit
    | Q.Ping { Query.version; 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
      end;
      Deferred.unit
    | Q.Set_emacs_env id -> Env.set_emacs_env writer id
    | Q.Create create ->
      let id = create.C.id in
      let ids = Id.to_string id in
      begin
        Env.setenv_all id >>= fun () ->
        Models.create create >>| function
        | 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 () -> Log.printf "Model killed: %s" ids
        | Error `No_model -> no_model id
      end
    | Q.Get_project_env (id, x) ->
      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 () ->
      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
      Log.printf "%s" msg;
      Deferred.unit
  with exn ->
    Log.printf "Bad input: %s" (Sexp.to_string s);
    raise exn

(* Die if emacs dies *)
let watch_for_dead_emacs () =
  every (sec 3.) (fun () ->
    let pid = To_emacs.pid () in
    (* Send the 0 signal (are you alive?) to emacs *)
    match Result.try_with (fun () -> Signal.send_exn Signal.zero (`Pid pid)) with
    | Ok () -> ()
    | Error exn ->
      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;
  Ashell.rm File.socket >>= fun () ->
  (* Wait for the log to open *)
  Log.wait ()
  >>= fun () ->
  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 () ->
      Reader.read_sexp reader >>= function
      | `Eof ->
        Writer.close writer >>= fun () ->
        failwith "Read error"
      | `Ok 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 ->
      Log.exn (Monitor.extract_exn exn);
      Deferred.unit)

let connect msg =
  (* Make sure the message ends with a space so the sexp parser knows
     it's finished *)
  let msg = msg ^ " " in
  let file = File.socket in
  Asys.file_exists file >>= function
  | `No | `Unknown ->
    failwithf "Missing socket file: %s" file ()
  | `Yes ->
    Tcp.connect_unix ~file () >>= fun (reader, writer) ->
    Writer.write writer msg;
    Pipe.iter (Reader.pipe reader) ~f:(fun s ->
      eprintf "%s\n" s;
      Deferred.unit)

(* -------------------------------------------------------------------------- *)
(*  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)
  end;
  never_returns (Scheduler.go ())

let start_cmd = Command.basic
  ~summary:"Start the omake server"
  Command.Spec.(
    flag "-emacs-pid" (required int) ~doc:"INT pid of the associated emacs process"
    ++ Flags.debug
  )
  (fun pid debug ->
    let pid = Pid.of_int pid in
    schedule
    ~f:(fun () ->
      try_with (fun () ->
        if debug then Omake.debug := true;
        To_emacs.set_pid pid;
        serve ()) >>| function
      | Ok () -> ()
      | Error exn -> Log.exn exn)
    ())

let send_cmd =
  Command.basic
    ~summary:"Send a message to the server."
    Command.Spec.( Flags.msg )
    (fun msg ->
      schedule
        ~f:(fun () ->
          Log.wait ()
          >>= fun () ->
          try_with (fun () -> connect msg)
          >>| function
          | Ok () -> ()
          | Error 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
    ~summary:"return 0 if a server is listening on the socket, 1 otherwise"
    Command.Spec.( const () )
    (fun () ->
      schedule
        ~f:(fun () -> try_with (fun () -> connect "(Ping 0)") >>| function
        | Ok () -> shutdown 0
        | Error _ ->
          shutdown 1)
        ())

let show_model_cmd =
  Command.basic
    ~summary:"show a model"
    Command.Spec.( anon ("id" %: string) )
    (fun id ->
      let msg = sprintf "(Show_model %s)" id in
      schedule
        ~f:(fun () -> try_with (fun () -> connect msg) >>| function
        | Ok () -> shutdown 0
        | Error exn ->
          printf "Omake server error: %s\n" (Exn.to_string exn);
          shutdown 1)
        ~quit:()
        ())

let debug_cmd =
  let module C = Model.Create in
  Command.basic
    ~summary:"Run on a given file."
    Command.Spec.(
      anon ("file" %: string)
    )
    (fun file ->
      schedule
      ~f:(fun () ->
        Omake.debug := true;
        Reader.open_file file >>= fun reader ->
        let lines = Reader.lines reader in
        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);
          shutdown 1;
          Deferred.unit
        | Ok e ->
          printf "%s\n" e;
          Deferred.unit))
      ~quit:()
      ())

let version_cmd =
  Command.basic
    ~summary:"Print the version so we can sync with the elisp version"
    (Command.Spec.const ())
    (fun () -> Core.Std.printf "%d" omake_server_version)

let cmd = Command.group ~summary:"Omake server"
  [ ( "start", start_cmd )
  ; ( "send", send_cmd )
  ; ( "server-version", version_cmd )
  ; ( "in-use", in_use_cmd )
    (* Debug *)
  ; ( "debug", debug_cmd )
  ; ( "show-model", show_model_cmd )
  ]

let _ = Command.run cmd
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.