Как приложение службы Windows может быть написано на Haskell?

Я изо всех сил пытался написать приложение-службу Windows на Haskell.

Предыстория

Служебное приложение выполняется диспетчером управления службами Windows.При запуске он делает блокирующий вызов StartServiceCtrlDispatcher, который поставляется с обратным вызовом, который будет использоваться в качестве основной функции службы .

Предполагается, что основная функция службы регистрирует второй обратный вызов для обработки входящих команд, таких как запуск, остановка, продолжение и т. д. Она делает это, вызывая RegisterServiceCtrlHandler.

Проблема

Я могу написать программу, которая будет регистрировать основную функцию службы.Затем я могу установить программу как службу Windows и запустить ее из консоли управления службами. Служба может запускаться, сообщать о том, что она запущена, а затем ждать входящих запросов.

Проблема в том, что я не могу вызвать функцию-обработчик службы. Запрос статуса службы показывает, что он работает, но как только я отправляю ему команду «стоп», в окнах появляется всплывающее сообщение:

Windows could not stop the Test service on Local Computer.

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

Согласно документации MSDNфункция StartServiceCtrlDispatcher блокируется до тех пор, пока все службы не сообщат что они остановлены. После вызова основной функции службы поток диспетчера должен ожидать, пока диспетчер управления службами не отправит команду, после чего функция обработчика должна быть вызвана этим потоком.

Подробности

Далее следует очень упрощенная версия того, что я пытаюсь сделать, но она демонстрирует проблему, связанную с тем, что моя функция-обработчик не вызывается.

Во-первых, несколько имен и импортов:

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

Мне нужно определить несколько специальных типов данных с хранимыми экземплярами для сортировки данных:

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

Нужно сделать только три внешних импорта. Импорт «оболочки» для двух обратных вызовов, которые я буду предоставлять в 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 :: 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

Вывод

Я ранее установил службу, используя sc create Test binPath= c:\Main.exe.

Вот результат компиляции программы:

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

C:\path>

Затем я запускаю службу из монитора управления службами.Вот доказательство того, что мой вызов SetServiceStatus был принят:

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>

Вот содержимое log.txt, доказывающее, что мой первый обратный вызов svcMainбыл вызван:

svcMain: svcMain here!
svcMain: exiting

As как только я отправляю команду остановки с помощью диспетчера управления службами, я получаю сообщение об ошибке. Моя функция-обработчик должна была добавить строчку в лог-файл, но этого не происходит. После этого моя служба оказывается в остановленном состоянии:

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>

Вопрос

Есть ли у кого-нибудь идеи, что я могу попытаться сделать, чтобы вызывалась моя функция-обработчик?

Обновление 20130306

Эта проблема возникает в 64-разрядной версии Windows 7, но не в Windows XP. Другие версии Windows еще не тестировались. Когда я копирую скомпилированный исполняемый файл на несколько машин и выполняю одни и те же шаги, я получаю разные результаты.