How can a Windows service application be written in Haskell?

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.

Solution 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.

Solution 2:

I was able to resolve this problem, and released a library on hackage, Win32-services, for writing Windows service applications in Haskell.

The solution was to use certain combinations of Win32 calls together while avoiding other combinations.

Solution 3:

Wouldn't it be easier to write the part that interacts with the service in C, and make it call a DLL written in Haskell?