feat(server): add a --replace option

Closes #529 which seemed to be a common complaint among teachers.

* `learn-ocaml serve --replace` will kill an existing server (running on the
  same port) just before starting

* `learn-ocaml build serve` with an existing server on the same port will fail
  fast (before actually doing the build)

* `learn-ocaml build serve --replace` is more clever:
  - it will do the build *in a temporary directory*
  - then, only if everything is ok, kill the older server
  - swap the files and start the new server

This is all done in order to minimise downtime and be convenient for server
updates.

Note that this PR sits on top of #481 and should be rebased once it's merged.

Author: AltGr

src/main/learnocaml_main.ml

@@ -292,9 +292,15 @@ let process_html_file orig_file dest_file base_url no_secret =
   Lwt_io.close ofile >>= fun () ->
   Lwt_io.close wfile
 
+let temp_app_dir o =
+  let open Filename in
+  concat
+    (dirname o.app_dir)
+    ((basename o.app_dir) ^ ".temp")
+
 let main o =
-  Printf.printf "Learnocaml v.%s running.\n" Learnocaml_api.version;
-  let grade () =
+  Printf.printf "Learnocaml v.%s running.\n%!" Learnocaml_api.version;
+  let grade o =
     if List.mem Grade o.commands then
       (if List.mem Build o.commands || List.mem Serve o.commands then
          failwith "The 'grade' command is incompatible with 'build' and \
@@ -322,9 +328,34 @@ let main o =
        >|= fun i -> Some i)
     else Lwt.return_none
   in
-  let generate () =
+  let generate o =
     if List.mem Build o.commands then
-      (Printf.printf "Updating app at %s\n%!" o.app_dir;
+      (let get_app_dir o =
+         if not (List.mem Serve o.commands) then
+           Lwt.return o.app_dir
+         else if o.server.Server.replace then
+           let app_dir = temp_app_dir o in
+           (if Sys.file_exists app_dir then
+             (Printf.eprintf "Warning: temporary directory %s already exists\n%!"
+                app_dir;
+              Lwt.return_unit)
+            else if Sys.file_exists o.app_dir then
+              Lwt_utils.copy_tree o.app_dir app_dir
+            else
+              Lwt.return_unit)
+           >>= fun () -> Lwt.return app_dir
+         else if Learnocaml_server.check_running () <> None then
+           (Printf.eprintf
+              "Error: another server is already running on port %d \
+               (consider using option `--replace`)\n%!"
+              !Learnocaml_server.port;
+            exit 10)
+         else Lwt.return o.app_dir
+       in
+       get_app_dir o >>= fun app_dir ->
+       let o = { o with app_dir } in
+       Learnocaml_store.static_dir := app_dir;
+       Printf.printf "Updating app at %s\n%!" o.app_dir;
        Lwt.catch
          (fun () -> Lwt_utils.copy_tree o.builder.Builder.contents_dir o.app_dir)
          (function
@@ -404,8 +435,44 @@ let main o =
     else
       Lwt.return true
   in
-  let run_server () =
+  let run_server o =
     if List.mem Serve o.commands then
+      let () =
+        if o.server.Server.replace then
+          let running = Learnocaml_server.check_running () in
+          Option.iter Learnocaml_server.kill_running running;
+          let temp = temp_app_dir o in
+          let app_dir =
+            if Filename.is_relative o.app_dir
+            then Filename.concat (Sys.getcwd ()) o.app_dir
+            else o.app_dir
+          in
+          let bak =
+            let f =
+              Filename.temp_file
+                ~temp_dir:(Filename.dirname app_dir)
+                (Filename.basename app_dir ^ ".bak.")
+                ""
+            in
+            Unix.unlink f; f
+          in
+          if Sys.file_exists app_dir then Sys.rename app_dir bak;
+          Sys.rename temp o.app_dir;
+          Learnocaml_store.static_dir := app_dir;
+          if Sys.file_exists bak then
+            Lwt.dont_wait (fun () ->
+                Lwt.pause () >>= fun () ->
+                Lwt_process.exec ("rm",[|"rm";"-rf";bak|]) >>= fun r ->
+                if r <> Unix.WEXITED 0 then
+                  Lwt.fail_with "Remove command failed"
+                else Lwt.return_unit
+              )
+              (fun ex ->
+                 Printf.eprintf
+                   "Warning: while cleaning up older application \
+                    directory %s:\n    %s\n%!"
+                   bak (Printexc.to_string ex))
+      in
       let native_server = Sys.executable_name ^ "-server" in
       if Sys.file_exists native_server then
         let server_args =
@@ -416,30 +483,39 @@ let main o =
           ("--port="^string_of_int o.server.port) ::
           (match o.server.cert with None -> [] | Some c -> ["--cert="^c])
         in
-        Unix.execv native_server (Array.of_list (native_server::server_args))
+        Lwt.return
+          (`Continuation
+             (fun () ->
+                Unix.execv native_server
+                  (Array.of_list (native_server::server_args))))
       else begin
           Printf.printf "Starting server on port %d\n%!"
             !Learnocaml_server.port;
           if o.builder.Builder.base_url <> "" then
             Printf.printf "Base URL: %s\n%!" o.builder.Builder.base_url;
-          Learnocaml_server.launch ()
+          Learnocaml_server.launch () >>= fun ret ->
+          Lwt.return (`Success ret)
         end
     else
-      Lwt.return true
+      Lwt.return (`Success true)
   in
   let ret =
     Lwt_main.run
-      (grade () >>= function
-        | Some i -> Lwt.return i
+      (grade o >>= function
+        | Some i -> Lwt.return (`Code i)
         | None ->
-            generate () >>= fun success ->
+            generate o >>= fun success ->
             if success then
-              run_server () >>= fun r ->
-              if r then Lwt.return 0 else Lwt.return 10
+              run_server o >>= function
+                | `Success true -> Lwt.return (`Code 0)
+                | `Success false -> Lwt.return (`Code 10)
+                | `Continuation f -> Lwt.return (`Continuation f)
             else
-              Lwt.return 1)
+              Lwt.return (`Code 1))
   in
-  exit ret
+  match ret with
+  | `Code n -> exit n
+  | `Continuation f -> f ()
 
 let man = 
   let open Manpage in

src/main/learnocaml_server_args.ml

@@ -19,6 +19,7 @@ module type S = sig
     base_url: string;
     port: int;
     cert: string option;
+    replace: bool;
   }
 
   val term: string Cmdliner.Term.t -> string Cmdliner.Term.t -> t Cmdliner.Term.t
@@ -51,15 +52,21 @@ module Args (SN : Section_name) = struct
           HTTPS is enabled."
           default_http_port default_https_port)
 
+  let replace =
+    value & flag &
+    info ["replace"] ~doc:
+      "Replace a previously running instance of the server on the same port."
+
   type t = {
     sync_dir: string;
     base_url: string;
     port: int;
     cert: string option;
+    replace: bool;
   }
 
   let term app_dir base_url =
-    let apply app_dir sync_dir base_url port cert =
+    let apply app_dir sync_dir base_url port cert replace =
       Learnocaml_store.static_dir := app_dir;
       Learnocaml_store.sync_dir := sync_dir;
       let port = match port, cert with
@@ -73,10 +80,10 @@ module Args (SN : Section_name) = struct
         | None -> None);
       Learnocaml_server.port := port;
       Learnocaml_server.base_url := base_url;
-      { sync_dir; base_url; port; cert }
+      { sync_dir; base_url; port; cert; replace }
     in
   (* warning: if you add any options here, remember to pass them through when
      calling the native server from learn-ocaml main *)
-    Term.(const apply $ app_dir $ sync_dir $ base_url $ port $ cert)
+    Term.(const apply $ app_dir $ sync_dir $ base_url $ port $ cert $ replace)
 
 end

src/main/learnocaml_server_args.mli

@@ -16,9 +16,10 @@ module type S = sig
     base_url: string;
     port: int;
     cert: string option;
+    replace: bool;
   }
 
   val term: string Cmdliner.Term.t -> string Cmdliner.Term.t -> t Cmdliner.Term.t
 end
 
-module Args : functor (_ : Section_name) -> S
+module Args : functor (_ : Section_name) -> S

src/main/learnocaml_server_main.ml

@@ -31,6 +31,17 @@ let main o =
     Learnocaml_api.version o.port;
   if o.base_url <> "" then
     Printf.printf "Base URL: %s\n%!" o.base_url;
+  let () =
+    match Learnocaml_server.check_running (), o.replace with
+    | None, _ -> ()
+    | Some _, false ->
+        Printf.eprintf "Error: another server is already running on port %d \
+                        (consider using option `--replace`)\n%!"
+          !Learnocaml_server.port;
+        exit 10
+    | Some pid, true ->
+        Learnocaml_server.kill_running pid
+  in
   let rec run () =
     let minimum_duration = 15. in
     let t0 = Unix.time () in

src/repo/learnocaml_process_exercise_repository.ml

@@ -62,7 +62,7 @@ let spawn_grader
     ?print_result ?dirname meta ex_dir output_json =
   let rec sleep () =
     if !n_processes <= 0 then
-      Lwt_main.yield () >>= sleep
+      Lwt.pause () >>= sleep
     else (
       decr n_processes; Lwt.return_unit
     )

src/server/learnocaml_server.ml

@@ -715,3 +715,35 @@ let launch () =
   | e ->
       Printf.eprintf "Server error: %s\n%!" (Printexc.to_string e);
       Lwt.return false
+
+let check_running () =
+  try
+    let ic = Printf.ksprintf Unix.open_process_in "lsof -Qti tcp:%d -s tcp:LISTEN" !port in
+    let pid = match input_line ic with
+      | "" -> None
+      | s -> int_of_string_opt s
+      | exception End_of_file -> None
+    in
+    close_in ic;
+    pid
+  with Unix.Unix_error _ ->
+    Printf.eprintf "Warning: could not check for previously running instance";
+    None
+
+let kill_running pid =
+  let timeout = 15 in
+  Unix.kill pid Sys.sigint;
+  Printf.eprintf "Waiting for process %d to terminate... %2d%!" pid timeout;
+  let rec aux tout =
+    Printf.eprintf "\027[2D%2d" tout;
+    if Printf.ksprintf Sys.command "lsof -ti tcp:%d -p %d >/dev/null" !port pid
+       = 0
+    then
+      if tout <= 0 then
+        (prerr_endline "Error: process didn't terminate in time"; exit 10)
+      else
+        (Unix.sleep 1;
+         aux (tout - 1))
+  in
+  aux timeout;
+  prerr_endline "\027[2Dok"

src/server/learnocaml_server.mli

@@ -16,5 +16,12 @@ val args: (Arg.key * Arg.spec * Arg.doc) list
 
 (** Main *)
 
-(* Returns [false] if interrupted prematurely due to an error *)
+val check_running: unit -> int option
+(** Returns the pid or an existing process listening on the tcp port *)
+
+val kill_running: int -> unit
+(** Kills the given process and waits for termination (fails upon
+    reaching a timeout) *)
+
 val launch: unit -> bool Lwt.t
+(** Returns [false] if interrupted prematurely due to an error *)