diff --git a/.gitattributes b/.gitattributes new file mode 100644 index 00000000..f546dbcd --- /dev/null +++ b/.gitattributes @@ -0,0 +1 @@ +*.mc text eol=crlf diff --git a/bin/dune b/bin/dune index bc16a27e..e0f37e54 100644 --- a/bin/dune +++ b/bin/dune @@ -1,8 +1,35 @@ +(rule + (targets + provider.h + provider.rc + MSG00409.bin) + (deps provider.mc) + (action (run %{ocaml-config:target}-windmc %{deps})) + (enabled_if (= %{os_type} Win32))) + +(rule + (target provider.o) + (deps provider.rc) + (action (run %{ocaml-config:target}-windres %{deps} %{target})) + (enabled_if (= %{os_type} Win32))) + +(rule + (target dllprovider.dll) + (deps provider.o) + (action (run %{cc} -shared %{deps} -o %{target})) + (enabled_if (= %{os_type} Win32))) + +(install + (files dllprovider.dll) + (section lib) + (package ocluster) + (enabled_if (= %{os_type} Win32))) + (executables (public_names ocluster-scheduler ocluster-client ocluster-worker ocluster-admin) (package ocluster) (names scheduler client worker admin) - (libraries dune-build-info ocluster-api logs.cli logs.fmt fmt.cli fmt.tty capnp-rpc-unix cluster_scheduler cluster_worker prometheus-app.unix db + (libraries dune-build-info ocluster-api logs.cli logs.fmt fmt.cli fmt.tty capnp-rpc-unix cluster_scheduler cluster_worker prometheus-app.unix db win-eventlog (select winsvc_wrapper.ml from (winsvc -> winsvc_wrapper.winsvc.ml) ( -> winsvc_wrapper..ml)))) diff --git a/bin/logging.ml b/bin/logging.ml index c8a1c1eb..5158a3da 100644 --- a/bin/logging.ml +++ b/bin/logging.ml @@ -26,3 +26,15 @@ let term = let open Cmdliner in let docs = Manpage.s_common_options in Term.(const init $ Fmt_cli.style_renderer ~docs () $ Logs_cli.level ~docs ()) + +let combine_prometheus_eventlog name = + let prometheus = Logs.reporter () in + let eventlog = Win_eventlog.Log_eventlog.reporter ~eventlog:(Win_eventlog.Eventlog.register name) ~event:0x1 () in + let report = fun src level ~over k msgf -> + if level = Logs.Debug then + prometheus.Logs.report src level ~over k msgf + else + let v = eventlog.Logs.report src level ~over:(fun () -> ()) k msgf in + prometheus.Logs.report src level ~over (fun () -> v) msgf + in + Logs.set_reporter { Logs.report } diff --git a/bin/provider.mc b/bin/provider.mc new file mode 100644 index 00000000..8b50fada --- /dev/null +++ b/bin/provider.mc @@ -0,0 +1,7 @@ +LanguageNames=(English=0x409:MSG00409) + +MessageId= +SymbolicName=MESSAGE +Language=English +%1 +. diff --git a/bin/scheduler.ml b/bin/scheduler.ml index 8cf70e8f..7894ebf8 100644 --- a/bin/scheduler.ml +++ b/bin/scheduler.ml @@ -6,6 +6,7 @@ let ( / ) = Filename.concat let setup_log ?(formatter=Format.err_formatter) default_level = Prometheus_unix.Logging.init ~formatter ?default_level (); + if Sys.win32 then Logging.combine_prometheus_eventlog "ocluster-scheduler"; () let or_die = function diff --git a/bin/winsvc_wrapper.winsvc.ml b/bin/winsvc_wrapper.winsvc.ml index c3c2052c..93447c14 100644 --- a/bin/winsvc_wrapper.winsvc.ml +++ b/bin/winsvc_wrapper.winsvc.ml @@ -18,6 +18,7 @@ let run name state_dir (main:?formatter:Format.formatter -> unit -> unit) = let stop () = Lwt_unix.send_notification stop_notification end) in + Random.self_init (); try let name = Printf.sprintf "%s-%d.log" (Sys.executable_name |> Filename.basename |> Filename.remove_extension) (Random.bits ()) in let f = Filename.concat state_dir name in diff --git a/bin/worker.ml b/bin/worker.ml index 50ed524e..7a884c4e 100644 --- a/bin/worker.ml +++ b/bin/worker.ml @@ -1,7 +1,8 @@ open Lwt.Infix -let setup_log ?(formatter=Format.err_formatter) default_level = +let setup_log ?(formatter=Format.err_formatter) default_level name = Prometheus_unix.Logging.init ~formatter ?default_level (); + if Sys.win32 then Logging.combine_prometheus_eventlog name; () let or_die = function @@ -42,7 +43,7 @@ let update_normal () = Lwt.return (fun () -> Lwt.return ()) let main default_level ?formatter registration_path capacity name allow_push prune_threshold state_dir obuilder = - setup_log ?formatter default_level; + setup_log ?formatter default_level name; let update = if Sys.file_exists "/.dockerenv" then update_docker else update_normal @@ -56,11 +57,10 @@ let main default_level ?formatter registration_path capacity name allow_push pru (* Command-line parsing *) let main ~install (default_level, args1) ((registration_path, capacity, name, allow_push, prune_threshold, state_dir, obuilder), args2) = - let (name', display, text) = ("ocluster-worker", "OCluster Worker", "Run a build worker") in if install then - Ok (Winsvc_wrapper.install name' display text (args1 @ args2)) + Ok (Winsvc_wrapper.install name "OCluster Worker" "Run a build worker" (args1 @ args2)) else - Ok (Winsvc_wrapper.run name' state_dir (fun ?formatter () -> + Ok (Winsvc_wrapper.run name state_dir (fun ?formatter () -> main default_level ?formatter registration_path capacity name allow_push prune_threshold state_dir obuilder)) open Cmdliner @@ -144,22 +144,27 @@ let cmd ~install = let man = [ `P "On $(b,Windows), specify '$(b,install)' as the first \ command-line paramater to install the worker as a Windows \ - service with the specified parameters, and '$(b,remove)' to \ - remove the worker from the services." ] in + service with the specified parameters, and '$(b,remove) \ + $(i,name)' to remove the worker $(i,name) from the services." ] in let info = Cmd.info "ocluster-worker" ~doc ~man ~version:Version.t in Cmd.v info Term.(term_result' (const (main ~install) $ with_used_args (Logs_cli.level ()) $ worker_opts_t)) let () = - match Array.to_list Sys.argv with - | hd :: "install" :: argv -> - exit (Cmd.eval ~argv:(Array.of_list (hd :: argv)) (cmd ~install:true)) - | _ :: "remove" :: args -> + let remove name args = if args <> [] then begin prerr_endline "'remove' should be used only once, in first position."; exit 1 end else - Winsvc_wrapper.remove "ocluster-worker" + Winsvc_wrapper.remove name + in + match Array.to_list Sys.argv with + | hd :: "install" :: argv -> + exit (Cmd.eval ~argv:(Array.of_list (hd :: argv)) (cmd ~install:true)) + | _ :: "remove" :: name :: args -> remove name args + | _ :: name :: args when Astring.String.is_prefix ~affix:"remove=" name -> + let name = Astring.String.span ~max:(String.length "remove=") name |> snd in + remove name args | _ -> exit (Cmd.eval (cmd ~install:false)) diff --git a/dune-project b/dune-project index 861ede1b..faf5cdb2 100644 --- a/dune-project +++ b/dune-project @@ -34,6 +34,7 @@ (extunix (>= 0.3.2)) (winsvc (and (>= 1.0.1) (= :os "win32"))) (cmdliner (>= 1.1.0)) + (win-eventlog (>= 0.4)) logs fmt (conf-libev (<> :os "win32")) diff --git a/ocluster.opam b/ocluster.opam index 1aa81369..8c65805b 100644 --- a/ocluster.opam +++ b/ocluster.opam @@ -29,6 +29,7 @@ depends: [ "extunix" {>= "0.3.2"} "winsvc" {>= "1.0.1" & os = "win32"} "cmdliner" {>= "1.1.0"} + "win-eventlog" {>= "0.4"} "logs" "fmt" "conf-libev" {os != "win32"}