Windows event log

.gitattributes

@@ -0,0 +1 @@
+*.mc    text eol=crlf

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))))

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 }

bin/provider.mc

@@ -0,0 +1,7 @@
+LanguageNames=(English=0x409:MSG00409)
+
+MessageId=
+SymbolicName=MESSAGE
+Language=English
+%1
+.

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

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

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))

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"))

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"}