Changes

src/winsvc.ml

@@ -1,14 +1,14 @@
 external install : string -> string -> string -> string -> unit
-  = "caml_winsvc_install"
+  = "winsvc_install"
 
-external remove : string -> unit = "caml_winsvc_remove"
+external remove : string -> unit = "winsvc_remove"
 
 external run : string -> (unit -> unit) -> (unit -> unit) -> unit
-  = "caml_winsvc_run"
+  = "winsvc_run"
 
 exception Error of string
 
-let () = Callback.register_exception "caml_winsvc_exn" (Error "register");
+let () = Callback.register_exception "winsvc_exn" (Error "register");
 
 module type Sig = sig
   val name : string

src/winsvc.mli

@@ -32,6 +32,8 @@ module Make (S : Sig) : sig
 
   (** [run main]
     @param main function to run, stdin/stdout not available (will raise exception if used),
-                when [S.stop] is called this function should return as soon as possible *)
+                when [S.stop] is called this function should return as soon as possible.
+    @raise Failure if the program is being run as a console application rather than as a
+                   service. *)
   val run : (unit -> unit) -> unit
 end

src/winsvc_stubs.c

@@ -11,23 +11,28 @@
   Adapted for ocaml by ygrek, (c) 2009
 */
 
+#define UNICODE
+#define _UNICODE
 #define WIN32_LEAN_AND_MEAN // Exclude rarely-used stuff from Windows headers
 #include <assert.h>
-#include <stdio.h>
-#include <tchar.h>
 #include <windows.h>
+#define STRSAFE_NO_CCH_FUNCTIONS
+#include <strsafe.h>
 
+#define CAML_NAME_SPACE
+#define CAML_INTERNALS
 #include <caml/alloc.h>
 #include <caml/callback.h>
 #include <caml/fail.h>
 #include <caml/memory.h>
 #include <caml/threads.h>
+#include <caml/osdeps.h>
 
 static value cb_service_run = Val_unit;
 static value cb_service_stop = Val_unit;
-static char *s_service_name = NULL;
+static char_os *s_service_name = NULL;
 
-void call_service_run(void) {
+static void call_service_run(void) {
   assert(Val_unit != cb_service_run);
   caml_c_thread_register();
   caml_acquire_runtime_system();
@@ -36,7 +41,7 @@ void call_service_run(void) {
   caml_c_thread_unregister();
 }
 
-void call_service_stop(void) {
+static void call_service_stop(void) {
   assert(Val_unit != cb_service_stop);
 
   caml_c_thread_register();
@@ -46,11 +51,11 @@ void call_service_stop(void) {
   caml_c_thread_unregister();
 }
 
-static SERVICE_STATUS service_status;	
-static SERVICE_STATUS_HANDLE handle_service_status = 0;	
+static SERVICE_STATUS service_status;
+static SERVICE_STATUS_HANDLE handle_service_status = 0;
 static int check_point = 1;
 
-BOOL report_status(DWORD current_state, DWORD win32_exitcode, DWORD wait_hint) {
+static BOOL report_status(DWORD current_state, DWORD win32_exitcode, DWORD wait_hint) {
   if (current_state != SERVICE_START_PENDING)
     service_status.dwControlsAccepted = SERVICE_ACCEPT_STOP;
   service_status.dwCurrentState = current_state;
@@ -66,21 +71,21 @@ BOOL report_status(DWORD current_state, DWORD win32_exitcode, DWORD wait_hint) {
   return SetServiceStatus(handle_service_status, &service_status);
 }
 
-void stop_service() {
+static void stop_service() {
   report_status(SERVICE_STOP_PENDING, NO_ERROR, 1000);
 
   call_service_stop();
 }
 
-void WINAPI service_ctrl_handler(DWORD ctrl_code) {
+static void WINAPI service_ctrl_handler(DWORD ctrl_code) {
   if (ctrl_code == SERVICE_CONTROL_STOP) {
     stop_service();
   } else {
     report_status(service_status.dwCurrentState, NO_ERROR, 0);
   }
 }
 
-void service_main(DWORD argc, TCHAR **argv) {
+static void service_main(DWORD argc, WCHAR **argv) {
   memset(&service_status, 0, sizeof(SERVICE_STATUS));
   service_status.dwServiceType = SERVICE_WIN32_OWN_PROCESS;
   service_status.dwServiceSpecificExitCode = 0;
@@ -95,58 +100,98 @@ void service_main(DWORD argc, TCHAR **argv) {
   report_status(SERVICE_STOPPED, NO_ERROR, 2000);
 }
 
-#define raise_error(str) caml_raise_with_string(*caml_named_value("caml_service_exn"), str)
+static void raise_error(const char_os *prefix, DWORD rc) {
+  LPVOID buffer = NULL;
+  char_os msg[2048] = { 0 };
+
+  FormatMessage(
+    FORMAT_MESSAGE_ALLOCATE_BUFFER |
+    FORMAT_MESSAGE_FROM_SYSTEM |
+    FORMAT_MESSAGE_IGNORE_INSERTS,
+    NULL,
+    rc,
+    MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT),
+    (LPTSTR) &buffer,
+    0, NULL);
+  StringCbPrintf(
+    msg, sizeof(msg)/sizeof(msg[0]),
+    L"%s: %s",
+    prefix,
+    buffer);
+  LocalFree(buffer);
+
+  caml_raise_with_arg(*caml_named_value("winsvc_exn"),
+                      caml_copy_string_of_os(msg));
+}
 
-CAMLprim value caml_winsvc_install(value v_name, value v_display, value v_text,
+CAMLprim value winsvc_install(value v_name, value v_display, value v_text,
                                     value v_path) {
   CAMLparam4(v_name, v_display, v_text, v_path);
 
   SC_HANDLE handle_manager;
   SC_HANDLE handle_service;
   SERVICE_DESCRIPTION description;
+  char_os *name, *display, *text, *path;
+  DWORD rc;
 
   handle_manager = OpenSCManager(0, 0, SC_MANAGER_ALL_ACCESS);
-  if (handle_manager == 0) {
-    raise_error("Failed to open service control manager");
+  if (handle_manager == NULL) {
+    raise_error(L"OpenSCManager", GetLastError());
   }
 
+  name = caml_stat_strdup_to_os(String_val(v_name));
+  display = caml_stat_strdup_to_os(String_val(v_display));
+  path = caml_stat_strdup_to_os(String_val(v_path));
+
   handle_service = CreateService(
-      handle_manager, String_val(v_name), String_val(v_display),
+      handle_manager, name, display,
       SERVICE_ALL_ACCESS, SERVICE_WIN32_OWN_PROCESS, SERVICE_AUTO_START,
-      SERVICE_ERROR_NORMAL, String_val(v_path), 0, 0, 0, 0, 0);
-  if (handle_service == 0) {
+      SERVICE_ERROR_NORMAL, path, 0, 0, 0, 0, 0);
+  rc = GetLastError();
+
+  caml_stat_free(name);
+  caml_stat_free(display);
+  caml_stat_free(path);
+
+  if (handle_service == NULL) {
     CloseServiceHandle(handle_manager);
-    raise_error("Failed to create service in service control manager");
+    raise_error(L"CreateService", rc);
   }
 
-  description.lpDescription = String_val(v_text);
+  text = caml_stat_strdup_to_os(String_val(v_text));
+  description.lpDescription = text;
   ChangeServiceConfig2(handle_service, SERVICE_CONFIG_DESCRIPTION,
                        &description);
+  caml_stat_free(text);
 
   CloseServiceHandle(handle_service);
   CloseServiceHandle(handle_manager);
 
   CAMLreturn(Val_unit);
 }
 
-CAMLprim value caml_winsvc_remove(value v_name) {
+CAMLprim value winsvc_remove(value v_name) {
   CAMLparam1(v_name);
 
   SC_HANDLE handle_manager;
   SC_HANDLE handle_service;
   SERVICE_STATUS status;
   BOOL result;
+  char_os *name;
+  DWORD rc;
 
   handle_manager = OpenSCManager(0, 0, SC_MANAGER_ALL_ACCESS);
-  if (handle_manager == 0) {
-    raise_error("Failed to open service control manager");
+  if (handle_manager == NULL) {
+    raise_error(L"OpenSCManager", GetLastError());
   }
 
+  name = caml_stat_strdup_to_os(String_val(v_name));
   handle_service =
-      OpenService(handle_manager, String_val(v_name), SERVICE_ALL_ACCESS);
-  if (handle_service == 0) {
+      OpenService(handle_manager, name, SERVICE_ALL_ACCESS);
+  caml_stat_free(name);
+  if (handle_service == NULL) {
     CloseServiceHandle(handle_manager);
-    raise_error("Failed to open service in service control manager");
+    raise_error(L"OpenService", GetLastError());
   }
 
   memset(&status, 0, sizeof(SERVICE_STATUS));
@@ -160,28 +205,29 @@ CAMLprim value caml_winsvc_remove(value v_name) {
   }
 
   result = DeleteService(handle_service);
+  rc = GetLastError();
 
   CloseServiceHandle(handle_service);
   CloseServiceHandle(handle_manager);
 
-  if (0 == result) {
-    raise_error("Failed to remove service");
+  if (!result) {
+    raise_error(L"DeleteService", rc);
   }
 
   CAMLreturn(Val_unit);
 }
 
-CAMLprim value caml_winsvc_run(value v_name, value v_run, value v_stop) {
+CAMLprim value winsvc_run(value v_name, value v_run, value v_stop) {
   CAMLparam3(v_name, v_run, v_stop);
   BOOL result;
-  // not sure whether it is needed but better stay on the safe side
-  char *s_name = strdup(String_val(v_name));
+  char_os *s_name = caml_stat_strdup_to_os(String_val(v_name));
   SERVICE_TABLE_ENTRY dispatch_table[] = {
       {s_name, (LPSERVICE_MAIN_FUNCTION)service_main}, {0, 0}};
+  DWORD rc;
 
   if (Val_unit != cb_service_run) {
-    free(s_name);
-    raise_error("Already running");
+    caml_stat_free(s_name);
+    caml_raise_with_string(*caml_named_value("winsvc_exn"), "Already running");
   }
 
   s_service_name = s_name;
@@ -193,6 +239,7 @@ CAMLprim value caml_winsvc_run(value v_name, value v_run, value v_stop) {
 
   caml_release_runtime_system();
   result = StartServiceCtrlDispatcher(dispatch_table);
+  rc = GetLastError();
   caml_acquire_runtime_system();
 
   caml_remove_generational_global_root(&cb_service_run);
@@ -201,11 +248,14 @@ CAMLprim value caml_winsvc_run(value v_name, value v_run, value v_stop) {
   cb_service_stop = Val_unit;
 
   s_service_name = NULL;
+  caml_stat_free(s_name);
 
-  free(s_name);
-
-  if (FALSE == result)
-    raise_error("Failed to run service");
+  if (!result) {
+    if (rc == ERROR_FAILED_SERVICE_CONTROLLER_CONNECT)
+      caml_failwith("ERROR_FAILED_SERVICE_CONTROLLER_CONNECT");
+    else
+      raise_error(L"StartServiceCtrlDispatcher", rc);
+  }
 
   CAMLreturn(Val_unit);
 }