How can a Windows service application be written in Haskell?

Question

I've been struggling to write a Windows service application in Haskell.

Background

A service application is executed by the Windows Service Control Manager. Upon launching it makes a blocking call to StartServiceCtrlDispatcher which is supplied with a callback to be used as the service's main function.

The service's main function is supposed to register a second callback to handle incoming commands such as start, stop, continue etc. It does this by calling RegisterServiceCtrlHandler.

Problem

I'm able to write a program which will register a service main function. I can then install the program as a Windows service and start it from the Services Management Console. The service is able to start, report itself as running, and then wait for incoming requests.

The problem is that I'm unable to get my service handler function to be called. Querying the services status reveals that it is running, but as soon as I send it a 'stop' command windows pops up a message saying:

Windows could not stop the Test service on Local Computer.  Error 1061: The service cannot accept control messages at this time. 

According to MSDN documentation the StartServiceCtrlDispatcher function blocks until all services report that they are stopped. After the service main function gets called a dispatcher thread is supposed to wait until the Service Control Manager sends a command, at which point the handler function should be called by that thread.

Details

What follows is a very simplified version of what I am trying to do, but it demonstrates the problem of my handler function not being called.

First, a few names and imports:

module Main where  import Control.Applicative import Foreign import System.Win32  wIN32_OWN_PROCESS :: DWORD wIN32_OWN_PROCESS = 0x00000010  sTART_PENDING, rUNNING :: DWORD sTART_PENDING = 0x00000002 rUNNING = 0x00000004  aCCEPT_STOP, aCCEPT_NONE :: DWORD aCCEPT_STOP = 0x00000001 aCCEPT_NONE = 0x00000000  nO_ERROR :: DWORD nO_ERROR = 0x00000000  type HANDLER_FUNCTION = DWORD -> IO () type MAIN_FUNCTION = DWORD -> Ptr LPTSTR -> IO () 

I need to define a few special data types with Storable instances for data marshalling:

data TABLE_ENTRY = TABLE_ENTRY LPTSTR (FunPtr MAIN_FUNCTION)  instance Storable TABLE_ENTRY where   sizeOf _ = 8   alignment _ = 4   peek ptr = TABLE_ENTRY <$> peek (castPtr ptr) <*> peek (castPtr ptr `plusPtr` 4)   poke ptr (TABLE_ENTRY name proc) = do       poke (castPtr ptr) name       poke (castPtr ptr `plusPtr` 4) proc  data STATUS = STATUS DWORD DWORD DWORD DWORD DWORD DWORD DWORD  instance Storable STATUS where   sizeOf _ = 28   alignment _ = 4   peek ptr = STATUS        <$> peek (castPtr ptr)       <*> peek (castPtr ptr `plusPtr` 4)       <*> peek (castPtr ptr `plusPtr` 8)       <*> peek (castPtr ptr `plusPtr` 12)       <*> peek (castPtr ptr `plusPtr` 16)       <*> peek (castPtr ptr `plusPtr` 20)       <*> peek (castPtr ptr `plusPtr` 24)   poke ptr (STATUS a b c d e f g) = do       poke (castPtr ptr) a       poke (castPtr ptr `plusPtr` 4)  b       poke (castPtr ptr `plusPtr` 8)  c       poke (castPtr ptr `plusPtr` 12) d       poke (castPtr ptr `plusPtr` 16) e       poke (castPtr ptr `plusPtr` 20) f       poke (castPtr ptr `plusPtr` 24) g 

Only three foreign imports need to be made. There's a 'wrapper' import for the two callbacks I'll be supplying to Win32:

foreign import stdcall "wrapper"     smfToFunPtr :: MAIN_FUNCTION -> IO (FunPtr MAIN_FUNCTION) foreign import stdcall "wrapper"     handlerToFunPtr :: HANDLER_FUNCTION -> IO (FunPtr HANDLER_FUNCTION) foreign import stdcall "windows.h RegisterServiceCtrlHandlerW"     c_RegisterServiceCtrlHandler         :: LPCTSTR -> FunPtr HANDLER_FUNCTION -> IO HANDLE foreign import stdcall "windows.h SetServiceStatus"     c_SetServiceStatus :: HANDLE -> Ptr STATUS -> IO BOOL foreign import stdcall "windows.h StartServiceCtrlDispatcherW"     c_StartServiceCtrlDispatcher :: Ptr TABLE_ENTRY -> IO BOOL 

Main program

Finally, here is the main service application:

main :: IO () main =   withTString "Test" $ \name ->   smfToFunPtr svcMain >>= \fpMain ->   withArray [TABLE_ENTRY name fpMain, TABLE_ENTRY nullPtr nullFunPtr] $ \ste ->   c_StartServiceCtrlDispatcher ste >> return ()  svcMain :: MAIN_FUNCTION svcMain argc argv = do     appendFile "c:\\log.txt" "svcMain: svcMain here!\n"     args <- peekArray (fromIntegral argc) argv     fpHandler <- handlerToFunPtr svcHandler     h <- c_RegisterServiceCtrlHandler (head args) fpHandler     _ <- setServiceStatus h running     appendFile "c:\\log.txt" "svcMain: exiting\n"  svcHandler :: DWORD -> IO () svcHandler _ = appendFile "c:\\log.txt" "svcCtrlHandler: received.\n"  setServiceStatus :: HANDLE -> STATUS -> IO BOOL setServiceStatus h status = with status $ c_SetServiceStatus h  running :: STATUS running  = STATUS wIN32_OWN_PROCESS rUNNING aCCEPT_STOP nO_ERROR 0 0 3000 

Output

I've previously installed the service using sc create Test binPath= c:\Main.exe.

Here is the output from compiling the program:

C:\path>ghc -threaded --make Main.hs [1 of 1] Compiling Main             ( Main.hs, Main.o ) Linking Main.exe ...  C:\path> 

I then start the service from the Service Control Monitor. Here is proof that my call to SetServiceStatus was accepted:

C:\Path>sc query Test  SERVICE_NAME: Test         TYPE               : 10  WIN32_OWN_PROCESS         STATE              : 4  RUNNING                                 (STOPPABLE, NOT_PAUSABLE, IGNORES_SHUTDOWN)         WIN32_EXIT_CODE    : 0  (0x0)         SERVICE_EXIT_CODE  : 0  (0x0)         CHECKPOINT         : 0x0         WAIT_HINT          : 0x0  C:\Path> 

Here is the contents of log.txt, proving that my first callback, svcMain, was called:

svcMain: svcMain here! svcMain: exiting 

As soon as I send a stop command using the Service Control Manager I get my error message. My handler function was supposed to add a line to the log file, but this does not happen. My service then appears in the stopped state:

C:\Path>sc query Test  SERVICE_NAME: Test         TYPE               : 10  WIN32_OWN_PROCESS         STATE              : 1  STOPPED         WIN32_EXIT_CODE    : 0  (0x0)         SERVICE_EXIT_CODE  : 0  (0x0)         CHECKPOINT         : 0x0         WAIT_HINT          : 0x0  C:\Path> 

Question

Does anyone have ideas for what I may try to get my handler function to be called?

Update 20130306

I have this problem on Windows 7 64-bit, but not on Windows XP. Other versions of Windows have not been tested yet. When I copy the compiled executable to multiple machines and perform the same steps I get different results.

Answer 1

I admit, this problem has been vexing me for some days now. From walking the return values and the contents of GetLastError, I've determined that this code should be working correctly according to the system.

Because it clearly isn't (it seems to enter an undefined state that inhibits the service handler from running successfully), I've posted my full diagnosis and a workaround. This is the exact kind of scenario Microsoft should be made aware of, because its interface guarantees aren't being honored.

Inspection

After becoming greatly unsatisfied with the error messages being reported by Windows when I attempted to interrogate the service (via sc interrogate service and sc control service with a canned control option allowed), I wrote my own call into GetLastError to see if anything interesting was going on:

import Text.Printf import System.Win32  foreign import stdcall "windows.h GetLastError"     c_GetLastError :: IO DWORD   ...  d <- c_GetLastError appendFile "c:\\log.txt" (Text.Printf.printf "%d\n" (fromEnum d)) 

What I discovered, much to my chagrin, was that ERROR_INVALID_HANDLE and ERROR_ALREADY_EXISTS were being thrown... when you run your appendFile operations sequentially. Phooey, and here I'd thought I was on to something.

What this did tell me, however, is that StartServiceCtrlDispatcher, RegisterServiceCtrlHandler, and SetServiceStatus aren't setting an error code; indeed, I get ERROR_SUCCESS exactly as hoped.

Analysis

Encouragingly, Windows' Task Manager and System Logs register the service as RUNNING. So, assuming that piece of the equation is actually working, we must return to why our service handler isn't being hit properly.

Inspecting these lines:

fpHandler <- handlerToFunPtr svcHandler h <- c_RegisterServiceCtrlHandler (head args) fpHandler _ <- setServiceStatus h running 

I attempted to inject nullFunPtr in as my fpHandler. Encouragingly, this caused the service to hang in the START_PENDING state. Good: that means the contents of fpHandler are actually being handled when we register the service.

Then, I tried this:

t <- newTString "Foo" h <- c_RegisterServiceCtrlHandler t fpHandler 

And this, unfortunately, took. However, that's expected:

If the service is installed with the SERVICE_WIN32_OWN_PROCESS service type, this member is ignored, but cannot be NULL. This member can be an empty string ("").

According to our hooked GetLastError and the returns from RegisterServiceCtrlHandler and SetServiceStatus (a valid SERVICE_STATUS_HANDLE and true, respectively), all is well according to the system. That can't be right, and it's completely opaque as to why this doesn't just work.

Current Workaround

Because it's unclear if your declaration into RegisterServiceCtrlHandler is working effectively, I recommend interrogating this branch of your code in a debugger while your service is running and, more importantly, contacting Microsoft about this issue. By all accounts, it appears that you've satisfied all of the functional dependencies correctly, the system returns everything that it should for a successful run, and yet your program is still entering an undefined state with no clear remedy in sight. That's a bug.

A usable workaround in the meantime is to use Haskell FFI to define your service architecture in another language (for example, C++) and hook into your code by either (a) exposing your Haskell code to your service layer or (b) exposing your service code to Haskell. In both cases, here's a starting reference to use for building your service.

I wish I could have done more here (I honestly, legitimately tried), but even this much should significantly help you in getting this working.

Best of luck to you. It looks like you have a rather large number of people interested in your results.