如何在Haskell中编写Windows服务应用程序？

Question

我一直在努力在Haskell中编写Windows服务应用程序.

背景

服务应用程序由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 ()

我需要使用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

我在Windows 7 64位上遇到此问题,但在Windows XP上没有.其他版本的Windows尚未经过测试.当我将编译的可执行文件复制到多台机器并执行相同的步骤时,我得到不同的结果.

Answer 1

我承认,这个问题一直困扰着我好几天了.从遍历返回值和内容GetLastError,我已经确定此代码应该根据系统正常工作.

因为它显然不是(它似乎进入一个禁止服务处理程序成功运行的未定义状态),我已经发布了我的完整诊断和解决方法.这是微软应该了解的确切类型,因为它的接口保证不受尊重.

检查

在我试图询问服务时(通过sc interrogate service并允许sc control service使用固定control选项)对Windows报告的错误消息非常不满意后,我编写了自己的调用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_PROCESS服务类型安装服务,则忽略此成员,但不能为NULL.该成员可以是空字符串("").

根据我们的钩子GetLastError和来自RegisterServiceCtrlHandler和SetServiceStatus(有效SERVICE_STATUS_HANDLE和true分别)的回报,一切都很好地根据系统.这不可能是正确的,并且为什么这不仅仅起作用是完全不透明的.

目前的解决方法

因为不清楚您的声明RegisterServiceCtrlHandler是否有效,我建议您在服务运行时在调试器中查询代码的这一分支,更重要的是,请联系Microsoft了解此问题.从各方面来看,您似乎已经正确地满足了所有功能依赖关系,系统会返回成功运行所需的一切,但是您的程序仍然进入未定义状态,看不到明确的补救措施.那是一个错误.

同时,一个可用的解决方法是使用Haskell FFI以另一种语言(例如,C++)定义您的服务架构,并通过(a)将您的Haskell代码暴露给您的服务层或(b)暴露您的服务来挂钩您的代码代码到Haskell.在这两种情况下,这里都是用于构建服务的起始参考.

我希望我能在这里做得更多(老实说,合法地尝试过),但即使这样做也应该能帮助你实现这一目标.

祝你好运.看起来你有相当多的人对你的结果感兴趣.

Answer 2

我能够解决这个问题,并在hackage上发布了一个库,Win32-services,用于在Haskell中编写Windows服务应用程序.

解决方案是将Win32调用的某些组合一起使用,同时避免其他组合.