¿Cómo se puede escribir una aplicación de servicio de Windows en Haskell?

He estado luchando para escribir una aplicación de servicio de Windows en Haskell.

Antecedentes

El Administrador de Control de Servicios de Windows ejecuta una aplicación de servicio. Al iniciar, realiza una llamada de bloqueo a StartServiceCtrlDispatcherque se suministra con una devolución de llamada para ser utilizada como la función principal del servicio .

Se supone que la función principal del servicio registra una segunda devolución de llamada para manejar comandos entrantes como start, stop, continuar etc. Lo hace llamando a RegisterServiceCtrlHandler.

Problema

Soy capaz de escribir un programa que registrará una función principal de servicio. Luego puedo instalar el programa como un servicio de Windows e iniciarlo desde la consola de administración de servicios. El servicio es capaz de iniciar, informar a sí mismo como en ejecución, y luego esperar a las solicitudes entrantes.

El problema es que no puedo hacer que se llame a mi función de controlador de servicio. Consultar el el estado de los servicios revela que se está ejecutando, pero tan pronto como le envío un comando 'stop', Windows aparece un mensaje que dice:

Windows could not stop the Test service on Local Computer.

Error 1061: The service cannot accept control messages at this time.

De acuerdo con MSDN documentation la función StartServiceCtrlDispatcher se bloquea hasta que todos los servicios informan que se han detenido. Después de que se llame a la función principal del servicio, se supone que un subproceso de despachador debe esperar hasta que el Administrador de Control de Servicio envíe un comando, momento en el que la función manejadora debe ser llamada por eso hilo.

Detalles

Lo que sigue es una versión muy simplificada de lo que estoy tratando de hacer, pero demuestra el problema de no llamar a mi función de controlador.

Primero, algunos nombres e importaciones:

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

Necesito definir algunos tipos de datos especiales con instancias almacenables para el marshalling de datos:

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

Solo se necesitan tres importaciones extranjeras. Hay una importación de 'wrapper' para las dos devoluciones de llamada que suministraré a 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

Programa principal

Finalmente, aquí está la aplicación de servicio principal:

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

Salida

He instalado previamente el servicio usando sc create Test binPath= c:\Main.exe.

Aquí está la salida de la compilación del programa:

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

C:\path>

Luego inicio el servicio desde el Monitor de Control de Servicio. He aquí la prueba de que mi llamada a SetServiceStatus fue aceptada:

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>

Aquí está el contenido de log.txt, demostrando que mi primera devolución de llamada, svcMain, fue llamado:

svcMain: svcMain here!
svcMain: exiting

Tan pronto como envío un comando stop usando el Administrador de Control de Servicio, recibo mi mensaje de error. Se suponía que mi función handler debía agregar una línea al archivo de registro, pero esto no sucede. Mi servicio aparece entonces en el estado detenido:

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>

Pregunta

¿Alguien tiene ideas sobre lo que puedo intentar para que se llame a mi función de controlador?

Actualización 20130306

Tengo este problema en Windows 7 de 64 bits, pero no en Windows XP. Otro las versiones de Windows no han sido probadas todavía. Cuando copio el ejecutable compilado en varias máquinas y realizo los mismos pasos, obtengo resultados diferentes.