46

我一直在努力用 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 尚未经过测试。当我将编译后的可执行文件复制到多台机器并执行相同的步骤时，我会得到不同的结果。

4

3 回答 3

18

我承认，这个问题已经困扰我好几天了。通过遍历返回值和 的内容GetLastError，我确定此代码应该根据系统正常工作。

因为它显然不是（它似乎进入了阻止服务处理程序成功运行的未定义状态），所以我发布了我的完整诊断和解决方法。这是微软应该意识到的确切情况，因为它的接口保证没有得到兑现。

检查

sc interrogate service当我尝试询问服务（通过并允许sc control service使用固定选项）时，对 Windows 报告的错误消息非常不满意后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它被抛出了。appendFilePhooey，在这里我以为我在做某事。

然而，这确实告诉我的是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 的代码。在这两种情况下，这里都是用于构建服务的起始参考。

我希望我能在这里做得更多（老实说，我合法地尝试过），但即使是这么多也应该能极大地帮助你完成这项工作。

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

于 2012-04-15T05:08:20.567 回答
6

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

解决方案是一起使用某些 Win32 调用组合，同时避免其他组合。

于 2013-07-11T18:04:51.063 回答
3

用 C 语言编写与服务交互的部分，并使其调用用 Haskell 编写的 DLL 不是更容易吗？

于 2012-04-13T21:22:47.167 回答