feat(CLI): Add option learn-ocaml build serve --serve-during-build

erikmd · erikmd · commit f0108a34ae70 · 2024-04-09T21:04:48.000+02:00
Motivation: - Makes it possible to provide a feature similar to the `--replace` option (namely, `learn-ocaml build serve --replace`) within a Docker context. As `--replace` needed to successively start 2 learn-ocaml processes listening to the same port, but if we spin two different containers, ./www is not shared between containers, nor the local TCP interface. - If tweaking the default entrypoint could be an alternative solution, the shell script would be involved to cope with the need to handle signals properly. - The solution implemented in this patch is simpler and can be enabled in a docker-compose context by passing: ``` environment: LEARNOCAML_SERVE_DURING_BUILD: 'true' ``` then run a command such as `docker restart learn-ocaml`. Remarks: - Using docker-compose, to restart a server and benefit from this feature, use ( docker compose stop ; docker compose restart ) rather than ( docker compose down ; docker compose up -d ) - This commit has been double-checked with both native server ( make ; make opaminstall ; learn-ocaml build serve --serve-during-build --repo=$REPO ) and bytecode server ( make ; make opaminstall ; mv $(which learn-ocaml-server){,~} ; learn-ocaml build serve --serve-during-build --repo=$REPO ) Close #594
diff --git a/src/main/learnocaml_main.ml b/src/main/learnocaml_main.ml
@@ -76,6 +76,22 @@ module Args = struct
          Mandatory for '$(b,learn-ocaml build)' if the site is not hosted in path '/', \
          which typically occurs for static deployment."
 
+  let serve_during_build =
+    value & flag &
+      info ["serve-during-build"] ~docs ~env:(Cmd.Env.info "LEARNOCAML_SERVE_DURING_BUILD") ~doc:
+        "If the $(i,--app-dir) directory already exists from a previous build, \
+         create a child process thanks to $(i,Unix.fork) to serve this version \
+         during the build, reducing server's downtime as much as possible. \
+         This flag requires to run both commands '$(b,learn-ocaml build serve)'. \
+         After the build, the child process stops and a new server starts. \
+         This flag is useful in a docker-compose context, and can be enabled \
+         by adding to the environment: '$(i,LEARNOCAML_SERVE_DURING_BUILD=true)'."
+
+  let child_pid =
+    (* Note: option `--child-pid` is specific to the native learn-ocaml-server,
+       hence this dummy value here, to avoid copying it in "SERVER OPTIONS". *)
+    Term.const (-2)
+
   module Grader = struct
     let info = info ~docs:"GRADER OPTIONS"
 
@@ -263,17 +279,18 @@ module Args = struct
     app_dir: string;
     repo_dir: string;
     build_dir: string;
+    serve_during_build: bool;
     grader: Grader.t;
     builder: Builder.t;
     server: Server.t;
   }
 
-  let term =
-    let apply commands app_dir repo_dir build_dir grader builder server =
-      { commands; app_dir; repo_dir; build_dir; grader; builder; server }
+  let term child_pid =
+    let apply commands app_dir repo_dir build_dir grader builder server serve_during_build =
+      { commands; app_dir; repo_dir; build_dir; grader; builder; server; serve_during_build }
     in
     Term.(const apply $commands $app_dir $repo_dir $build_dir
-          $Grader.term $Builder.term $Server.term app_dir base_url)
+          $Grader.term $Builder.term $Server.term app_dir base_url child_pid $serve_during_build)
 end
 
 open Args
@@ -391,12 +408,12 @@ let main o =
       end
     else Lwt.return_unit
   in
-  let generate o =
+  let generate ?(check_port = true) o =
     if List.mem Build o.commands then
       (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
+         else if o.server.Server.replace || o.serve_during_build then
            let temp_dir = temp_app_dir o in
            (if Sys.file_exists temp_dir then
              (Printf.eprintf "Warning: temporary directory %s already exists\n%!"
@@ -407,7 +424,8 @@ let main o =
             else
               Lwt.return_unit)
            >>= fun () -> Lwt.return temp_dir
-         else if Learnocaml_server.check_running () <> None then
+         else if check_port && Learnocaml_server.check_running () <> None then
+           (* This server-specific check is here to fail earlier if need be *)
            (Printf.eprintf
               "Error: another server is already running on port %d \
                (consider using option `--replace`)\n%!"
@@ -500,12 +518,27 @@ let main o =
     else
       Lwt.return true
   in
-  let run_server o =
+  let kill_once pid =
+    let already = ref false in
+    fun () ->
+    if !already then () else
+      (already := true;
+       Learnocaml_server.kill_running pid;
+       ignore (Unix.waitpid [Unix.WNOHANG] pid))
+  in
+  (* child_pid = None => no --serve-during-build
+     child_pid = Some 0 => --serve-during-build, child process
+     child_pid = Some n, n>0 => --serve-during-build, main process *)
+  let run_server ~child_pid o =
     if List.mem Serve o.commands then
+      let int_child_pid = Option.value child_pid ~default:(-1) in
       let () =
-        if o.server.Server.replace then
-          let running = Learnocaml_server.check_running () in
-          Option.iter Learnocaml_server.kill_running running;
+        if o.server.Server.replace || (o.serve_during_build && int_child_pid > 0) then
+          let () =
+            (if int_child_pid > 0 then kill_once int_child_pid ()
+             else let running = Learnocaml_server.check_running () in
+                  Option.iter Learnocaml_server.kill_running running)
+          in
           let temp = temp_app_dir o in
           let app_dir = absolute_filename o.app_dir in
           let bak =
@@ -542,6 +575,7 @@ let main o =
           ("--sync-dir="^o.server.sync_dir) ::
           ("--base-url="^o.builder.Builder.base_url) ::
           ("--port="^string_of_int o.server.port) ::
+          ("--child-pid="^string_of_int int_child_pid) ::
           (match o.server.cert with None -> [] | Some c -> ["--cert="^c])
         in
         Lwt.return
@@ -550,8 +584,13 @@ let main o =
                 Unix.execv native_server
                   (Array.of_list (native_server::server_args))))
       else begin
-          Printf.printf "Starting server on port %d\n%!"
-            !Learnocaml_server.port;
+          let comment = match int_child_pid with
+            | -1 -> ""
+            | 0 -> "(child)"
+            | _pid -> "(main)"
+          in
+          Printf.printf "Starting server%s on port %d\n%!"
+            comment !Learnocaml_server.port;
           if o.builder.Builder.base_url <> "" then
             Printf.printf "Base URL: %s\n%!" o.builder.Builder.base_url;
           Learnocaml_server.launch () >>= fun ret ->
@@ -560,19 +599,57 @@ let main o =
     else
       Lwt.return (`Success true)
   in
+  let lwt_run_server ~child_pid build_ok =
+    if build_ok then
+      run_server ~child_pid o >>= function
+      | `Success true -> Lwt.return (`Code 0)
+      | `Success false -> Lwt.return (`Code 10)
+      | `Continuation f -> Lwt.return (`Continuation f)
+    else
+      Lwt.return (`Code 1)
+  in
+  (* NOTE: the code below handles "learn-ocaml build serve --serve-during-build"
+     by relying on Lwt.fork; and to stay on the safe side, we make sure
+     that this fork is triggered before the first Lwt_main.run command. *)
   let ret =
-    Lwt_main.run
-      (grade o >>= function
-        | Some i -> Lwt.return (`Code i)
-        | None ->
-            generate o >>= fun success ->
-            if success then
-              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 (`Code 1))
+    if o.serve_during_build then begin
+        if not (List.mem Build o.commands && List.mem Serve o.commands) then
+          (Printf.eprintf
+             "Error: option `--serve-during-build` requires both commands `build serve`.\n%!";
+           exit 1)
+        else if o.server.Server.replace then
+          (Printf.eprintf
+             "Error: option `--replace` is incompatible with option `--serve-during-build`.\n%!";
+           exit 10)
+        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);
+        match Lwt_unix.fork () with
+        | 0 ->
+           if Sys.file_exists o.app_dir then
+             Lwt_main.run (lwt_run_server ~child_pid:(Some 0) true)
+           else
+             (Printf.eprintf
+                "Info: no existing app-dir in '%s', \
+                 will be available at next run (skipping child server start).\n%!" o.app_dir;
+              `Code 0)
+        | child_pid ->
+           at_exit (kill_once child_pid);
+           Lwt_main.run
+             (grade o >>= function
+              | Some i -> Lwt.return (`Code i)
+              | None ->
+                 generate ~check_port:false o >>= lwt_run_server ~child_pid:(Some child_pid))
+      end
+    else
+      Lwt_main.run
+        (grade o >>= function
+         | Some i -> Lwt.return (`Code i)
+         | None ->
+            generate o >>= lwt_run_server ~child_pid:None)
   in
   match ret with
   | `Code n -> exit n
@@ -627,7 +704,7 @@ let main_info =
     ~version:Learnocaml_api.version 
     "learn-ocaml"
 
-let main_term = Term.(const main $ Args.term)
+let main_term = Term.(const main $ Args.term child_pid)
 
 let () =
   match
diff --git a/src/main/learnocaml_server_args.ml b/src/main/learnocaml_server_args.ml
@@ -20,9 +20,10 @@ module type S = sig
     port: int;
     cert: string option;
     replace: bool;
+    child_pid: int;
   }
 
-  val term: string Cmdliner.Term.t -> string Cmdliner.Term.t -> t Cmdliner.Term.t
+  val term: string Cmdliner.Term.t -> string Cmdliner.Term.t -> int Cmdliner.Term.t -> t Cmdliner.Term.t
 end
 
 module Args (SN : Section_name) = struct
@@ -54,19 +55,24 @@ module Args (SN : Section_name) = struct
 
   let replace =
     value & flag &
-    info ["replace"] ~doc:
-      "Replace a previously running instance of the server on the same port."
+    info ["replace"] ~env:(Cmd.Env.info "LEARNOCAML_REPLACE") ~doc:
+      "Replace a previously running instance of the server on the same port. \
+       This flag is incompatible with flag $(i,--serve-during-build), \
+       albeit both flags aim to reduce server downtime. In practice, \
+       flag $(i,--replace) is useful in a non-Docker context, while \
+       flag $(i,--serve-during-build) is useful in a Docker context."
 
   type t = {
     sync_dir: string;
     base_url: string;
     port: int;
     cert: string option;
     replace: bool;
+    child_pid: int;
   }
 
-  let term app_dir base_url =
-    let apply app_dir sync_dir base_url port cert replace =
+  let term app_dir base_url child_pid =
+    let apply app_dir sync_dir base_url port cert replace child_pid =
       Learnocaml_store.static_dir := app_dir;
       Learnocaml_store.sync_dir := sync_dir;
       let port = match port, cert with
@@ -80,10 +86,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; replace }
+      { sync_dir; base_url; port; cert; replace; child_pid }
     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 $ replace)
+    Term.(const apply $ app_dir $ sync_dir $ base_url $ port $ cert $ replace $ child_pid)
 
 end
diff --git a/src/main/learnocaml_server_args.mli b/src/main/learnocaml_server_args.mli
@@ -17,9 +17,10 @@ module type S = sig
     port: int;
     cert: string option;
     replace: bool;
+    child_pid: int;
   }
 
-  val term: string Cmdliner.Term.t -> string Cmdliner.Term.t -> t Cmdliner.Term.t
+  val term: string Cmdliner.Term.t -> string Cmdliner.Term.t -> int Cmdliner.Term.t -> t Cmdliner.Term.t
 end
 
 module Args : functor (_ : Section_name) -> S
diff --git a/src/main/learnocaml_server_main.ml b/src/main/learnocaml_server_main.ml
@@ -25,31 +25,66 @@ let signal_waiter =
   let _ = Lwt_unix.on_signal Sys.sigterm handler in
   waiter
 
+let kill_once pid =
+  let already = ref false in
+  fun () ->
+  if !already then () else
+    (already := true;
+     Learnocaml_server.kill_running pid;
+     ignore (Unix.waitpid [Unix.WNOHANG] pid))
+
 let main o =
   let open Server_args in
-  Printf.printf "Learnocaml server v.%s starting on port %d\n%!"
-    Learnocaml_api.version o.port;
+  if o.child_pid < -1 then
+    (Printf.eprintf "Error: incorrect value `--child-pid=%d`\n%!" o.child_pid;
+     exit 10);
+  if o.child_pid >= 0 && o.replace then
+    (Printf.eprintf "Error: option `--replace` is incompatible with option `--child-pid`\n%!";
+     exit 10);
+  (* Note: "if o.child_pid>0 then at_exit (kill_once o.child_pid);" is unneeded
+     as "learn-ocaml serve" already made sure that the child pid terminated. *)
+  let comment = match o.child_pid with
+    | -1 -> ""
+    | 0 -> "(child)"
+    | _pid -> "(main)"
+  in
+  Printf.printf "Learnocaml server%s v.%s starting on port %d\n%!"
+    comment 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
+    match Learnocaml_server.check_running (), o.replace, o.child_pid with
+    | None, _, _ -> ()
+    | Some _, false, -1 ->
+       Printf.eprintf "Error: another server is already running on port %d \
+                       (consider using option `--replace`)\n%!"
+         !Learnocaml_server.port;
+       exit 10
+    | Some _, false, 0 ->
+       Printf.eprintf "Warning(child): another server is running on port %d \
+                       (skipping child server start)\n%!"
+         !Learnocaml_server.port;
+       exit 0
+    | Some pid, false, pid' ->
+       if pid = pid' then
+         kill_once pid' ()
+       else
+         (Printf.eprintf "Error: another server (pid %d) is already running on port %d \
+                          (while expecting `--child-pid=%d`)\n%!"
+            pid !Learnocaml_server.port pid';
+          Learnocaml_server.kill_running pid';
+          exit 10)
+    | Some pid, true, _ ->
+       Learnocaml_server.kill_running pid
   in
   let rec run () =
     let minimum_duration = 15. in
     let t0 = Unix.time () in
     try
       Lwt_main.run @@ Lwt.pick [
-        (Learnocaml_server.launch () >|= function true -> 0 | false -> 10);
-        signal_waiter
-      ]
+                          (Learnocaml_server.launch () >|= function true -> 0 | false -> 10);
+                          signal_waiter
+                        ]
     with Unix.Unix_error (err, fn, arg) ->
       Format.eprintf "SERVER CRASH in %s(%s):@ @[<hv 2>%s@]@."
         fn arg (Unix.error_message err);
@@ -98,6 +133,16 @@ let base_url =
        Mandatory for '$(b,learn-ocaml build)' if the site is not hosted in path '/', \
        which typically occurs for static deployment."
 
+let child_pid =
+  let open Arg in
+  value & opt int (-1) &
+    info ["child-pid"] ~docv:"CHILD_PID" ~doc:
+      "Set the pid of the child process created by $(i,Unix.fork) when the CLI \
+       option $(i,--serve-during-build) is used. If $(docv) has the value 0, \
+       it means the current instance is the temporary server (child process). \
+       If $(docv) is ommitted or has the value -1, it means no forking occured \
+       and the server should check no concurrent server is running on this port."
+
 let  exits =
   let open Cmd.Exit in
   [ info ~doc:"Default exit." ok
@@ -116,7 +161,7 @@ let main_info =
     "learn-ocaml-server"
 
 
-let main_term = Term.(const main $ Server_args.term app_dir base_url)
+let main_term = Term.(const main $ Server_args.term app_dir base_url child_pid)
 
 let () =
   match
