From a47f8ddef2762ad20c2bb168f05d706d6fa31dd5 Mon Sep 17 00:00:00 2001 From: Erik Martin-Dorel Date: Mon, 8 Apr 2024 16:50:48 +0200 Subject: [PATCH] feat(CLI): Add option `learn-ocaml build serve --serve-during-build` 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 commit is simpler and can be enabled in a docker-compose context by passing: ``` environment: LEARNOCAML_SERVE_DURING_BUILD: 'true' ``` or: ``` 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 ) - For uniformity, this commit also introduces an environment variable 'LEARNOCAML_REPLACE=true' as a fallback for `--replace`. Close #594 --- src/main/learnocaml_main.ml | 133 ++++++++++++++++++++++------ src/main/learnocaml_server_args.ml | 20 +++-- src/main/learnocaml_server_args.mli | 3 +- src/main/learnocaml_server_main.ml | 77 +++++++++++++--- 4 files changed, 187 insertions(+), 46 deletions(-) diff --git a/src/main/learnocaml_main.ml b/src/main/learnocaml_main.ml index 9f521be32..c4c20e923 100644 --- a/src/main/learnocaml_main.ml +++ b/src/main/learnocaml_main.ml @@ -76,6 +76,23 @@ 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:"SERVER OPTIONS" + ~env:(Cmd.Env.info "LEARNOCAML_SERVE_DURING_BUILD") ~doc: + "If the directory specified by $(b,--app-dir) already exists from a \ + previous build, create a temporary child process to serve it \ + while the build completes, in order to reduce server downtime. \ + 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: '$(env)=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 (None: int option) + module Grader = struct let info = info ~docs:"GRADER OPTIONS" @@ -263,17 +280,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 +409,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 +425,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 +519,29 @@ 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; + Unix.kill pid Sys.sigint; + Printf.eprintf "Waiting for child process %d to terminate... %!" pid; + ignore (Unix.waitpid [] pid); + prerr_endline "ok ") + 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 () = - if o.server.Server.replace then - let running = Learnocaml_server.check_running () in - Option.iter Learnocaml_server.kill_running running; + let int_child_pid = Option.value child_pid ~default:(-1) in + 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 +578,8 @@ let main o = ("--sync-dir="^o.server.sync_dir) :: ("--base-url="^o.builder.Builder.base_url) :: ("--port="^string_of_int o.server.port) :: + (match child_pid with None -> [] | Some n -> ["--child-pid="^string_of_int n]) + @ (match o.server.cert with None -> [] | Some c -> ["--cert="^c]) in Lwt.return @@ -550,8 +588,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 child_pid with + | None -> "" + | Some 0 -> "(temporary)" + | Some _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 +603,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_unix.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` instead of `--serve-during-build`)\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 temporary 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 +708,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 index 04706025b..297568a05 100644 --- 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 option; } - 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 option Cmdliner.Term.t -> t Cmdliner.Term.t end module Args (SN : Section_name) = struct @@ -54,8 +55,12 @@ 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. \ + Use this to reduce server downtime when updating the content \ + of an instance: the running server will only be stopped once the \ + new one is ready. If running in a Docker context, you may want to \ + have a look at the flag $(b,--serve-during-build) instead." type t = { sync_dir: string; @@ -63,10 +68,11 @@ module Args (SN : Section_name) = struct port: int; cert: string option; replace: bool; + child_pid: int option; } - 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 index c10e3bebd..fe201463c 100644 --- 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 option; } - 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 option 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 index 3fd57d53b..226d817c9 100644 --- a/src/main/learnocaml_server_main.ml +++ b/src/main/learnocaml_server_main.ml @@ -25,22 +25,63 @@ 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; + Unix.kill pid Sys.sigint; + Printf.eprintf "Waiting for child process %d to terminate... %!" pid; + ignore (Unix.waitpid [] pid); + prerr_endline "ok ") + let main o = let open Server_args in - Printf.printf "Learnocaml server v.%s starting on port %d\n%!" - Learnocaml_api.version o.port; + let check_comment = + match o.child_pid with + | Some n when n < 0 -> + (Printf.eprintf "Error: incorrect value for option `--child-pid=%d`\n%!" n; + exit 10) + | None -> "" + | Some n -> + if o.replace then + (Printf.eprintf "Error: option `--replace` is incompatible with option `--child-pid`\n%!"; + exit 10); + if n = 0 then + "(temporary)" + else + "(main)" + in + (* Note: "int_child_pid > 0 then at_exit (kill_once int_child_pid);" is + unneeded as "learn-ocaml serve" already made sure the child terminated. *) + Printf.printf "Learnocaml server%s v.%s starting on port %d\n%!" + check_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, None -> + Printf.eprintf "Error: another server is already running on port %d \ + (consider using option `--replace`)\n%!" + !Learnocaml_server.port; + exit 10 + | Some _, false, Some 0 -> + Printf.eprintf "Warning(child): another server is running on port %d \ + (skipping temporary server start)\n%!" + !Learnocaml_server.port; + exit 0 + | Some pid, false, Some 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'; + kill_once pid' (); + exit 10) + | Some pid, true, _ -> + Learnocaml_server.kill_running pid in let rec run () = let minimum_duration = 15. in @@ -98,6 +139,18 @@ 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 (some int) None & + info ["child-pid"] ~docv:"CHILD_PID" ~doc: + "For internal purposes." +(* This flag is used by learn-ocaml's exec call to tell learn-ocaml-server + about the pid of the child process created by 'Lwt_unix.fork' when using + the CLI option '--serve-during-build'. If 'CHILD_PID' gets the value 0, + it means the current instance is the temporary server (child process). + If 'CHILD_PID' is ommitted or has the value None, it means no fork occurred + 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 +169,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