Подтвердить что ты не робот

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

Я пытаюсь написать приложение для Windows в Haskell.

Фон

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

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

Проблема

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

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

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

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

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

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

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 еще не были протестированы. Когда я копирую скомпилированный исполняемый файл на несколько машин и выполняю те же шаги, я получаю разные результаты.

4b9b3361

ОТВЕТЫ

Ответ 1

Я смог решить эту проблему и выпустил библиотеку hackage, Win32-services, для написания приложений для Windows в Haskell.

Решение заключалось в том, чтобы использовать определенные комбинации вызовов Win32 вместе, избегая других комбинаций.

Ответ 2

Я признаю, что эта проблема уже несколько дней раздражает меня. Из проходов возвращаемых значений и содержимого GetLastError я определил, что этот код должен работать правильно в соответствии с системой.

Потому что это явно не (кажется, что он вводит состояние undefined, которое препятствует успешному запуску обработчика службы), я опубликовал свой полный диагноз и обходной путь. Это точный вид сценария, о котором Microsoft должна знать, потому что его гарантии интерфейса не соблюдаются.

Inspection

После очень неудовлетворенности сообщениями об ошибках, сообщаемыми Windows, когда я попытался опросить службу (через sc interrogate service и sc control service с включенной опцией консервированной control), я написал свой собственный вызов в GetLastError чтобы узнать, происходит ли что-нибудь интересное:

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

То, что я обнаружил, к моему огорчению, заключалось в том, что ERROR_INVALID_HANDLE и ERROR_ALREADY_EXISTS были выброшены... когда вы выполняете операции appendFile последовательно, Phooey, и здесь я подумал, что я что-то наделал.

Однако это сказало, что StartServiceCtrlDispatcher, RegisterServiceCtrlHandler и SetServiceStatus не устанавливают код ошибки; действительно, я получаю ERROR_SUCCESS точно так, как надеялся.

Анализ

Поощряюще, диспетчер задач Windows и системные журналы регистрируют службу как RUNNING. Итак, предполагая, что часть уравнения действительно работает, мы должны вернуться к тому, почему наш обработчик сервиса не попадает должным образом.

Проверка этих строк:

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

Я попытался ввести nullFunPtr в качестве моего fpHandler. Поощряюще, это заставило службу висеть в состоянии START_PENDING. Хорошо: это означает, что содержимое fpHandler фактически обрабатывается при регистрации службы.

Затем я попробовал это:

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

И это, к сожалению, заняло. Однако который ожидался:

Если служба установлена ​​с помощью службы SERVICE_WIN32_OWN_PROCESStype, этот элемент игнорируется, но не может быть NULL. Этот член может быть пустую строку ("").

В соответствии с нашим подключенным GetLastError и возвратом от RegisterServiceCtrlHandler и SetServiceStatus ( действительные SERVICE_STATUS_HANDLE и true, соответственно), все хорошо соответствует системе. Это не может быть прав, и это совершенно непрозрачно, почему это не просто работает.

Текущее обходное решение

Поскольку неясно, работает ли ваша декларация в RegisterServiceCtrlHandler, я рекомендую опросить эту ветвь вашего кода в отладчике, пока ваша служба работает, и, более того важно связаться с Microsoft по этому вопросу. По всем сведениям, похоже, что вы правильно выполнили все функциональные зависимости, система возвращает все, что нужно для успешного запуска, и тем не менее ваша программа все еще входит в состояние undefined без видимых средств устранения. Это ошибка.

В то же время можно использовать Haskell FFI, чтобы определить вашу сервисную архитектуру на другом языке (например, С++) и подключиться к вашему коду либо (a) подвергая ваш код Haskell вашему уровню обслуживания, либо (б) подвергая ваш служебный код Haskell. В обоих случаях вот стартовая ссылка для использования для создания вашей службы.

Жаль, что я мог бы сделать больше здесь (честно, законно пробовал), но даже это многое должно помочь вам в этом.

Удачи вам. Похоже, у вас есть довольно большое количество людей, заинтересованных в ваших результатах.

Ответ 3

Не было бы проще записать часть, которая взаимодействует с сервисом в C, и заставить ее вызвать DLL, написанную в Haskell?