如何用 Haskell 编写 Windows 服务应用程序？答案

【问题标题】：How can a Windows service application be written in Haskell?如何用 Haskell 编写 Windows 服务应用程序？
【发布时间】：2012-04-19 17:27:23
【问题描述】：

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

背景

服务应用程序由 Windows 服务控制管理器执行。在启动时，它会对StartServiceCtrlDispatcher 进行阻塞调用，并提供一个回调用作service's main function。

服务的主函数应该注册第二个回调来处理传入的命令，例如启动、停止、继续等。它通过调用 RegisterServiceCtrlHandler 来实现。

问题

我可以编写一个注册服务主函数的程序。然后我可以将该程序安装为 Windows 服务并从服务管理控制台启动它。该服务能够启动，报告自己正在运行，然后等待传入的请求。

问题是我无法调用我的service handler function。查询服务状态显示它正在运行，但只要我发送它一个“停止”命令窗口就会弹出一条消息说：

Windows could not stop the Test service on Local Computer.

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

根据MSDN documentation，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

一旦我使用服务控制管理器发送停止命令，我就会收到错误消息。我的处理程序函数应该在日志文件中添加一行，但这不会发生。然后我的服务出现在停止状态：

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

【问题讨论】：

+1，非常好的问题。考虑到赏金的增加，我认为这还没有解决。稍后我会看看这个。
抱歉，我没有看到您的svcHandler 实现调用SetServiceStatus 来报告服务的SERVICE_STOPPED 状态。另一个问题：您是否在日志文件中看到消息“svcCtrlHandler: received.\n”？顺便说一句，我建议您使用sc interrogate Test 来验证svcHandler 是否正确注册。如果svcHandler 接收SERVICE_CONTROL_INTERROGATE (4) 作为输入，它应该调用SetServiceStatus 以与svcMain 相同的方式使用报告状态rUNNING (SERVICE_RUNNING) 并控制它接受(@ 987654352@).
@Oleg 这个例子的处理程序没有做任何事情来保持简单。据我所知，它甚至没有被调用。我没有尝试手动询问服务，但会这样做。我的日志文件不包含预期的输出。
我回来并处理了您的代码，重现了您遇到的完全相同的问题。 sc interrogate Test 抛出 "The service cannot accept control messages at this time"，这是一个很大的线索。基于this worked example from Microsoft，需要在SERVICE_RUNNING之前设置初始SERVICE_START_PENDING状态。我相信当你纠正状态转换时，代码将开始按预期工作——其他一切都检查出来了。
唷。经过几天的闲逛，看看我是否能在您的实施中找到一些问题，我终于找到了答案。这一切都根据您挂钩的代码的返回值进行检查，但它不工作。我认为这种事情会为Raymond Chen 提出一个绝妙的问题。

标签： winapi haskell callback windows-services ffi

【解决方案1】：

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

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

检查

当我尝试询问服务时（通过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))

令我懊恼的是，当您按顺序运行 appendFile 操作时，ERROR_INVALID_HANDLE and ERROR_ALREADY_EXISTS 被抛出... 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

不幸的是，这被拿走了。不过，that's expected：

如果服务与SERVICE_WIN32_OWN_PROCESS 服务一起安装类型，该成员被忽略，但不能为 NULL。这个会员可以一个空字符串 ("")。

根据我们上钩的GetLastError 以及来自RegisterServiceCtrlHandler 和SetServiceStatus 的返回（分别是有效的SERVICE_STATUS_HANDLE 和true），根据系统，一切正常。这不可能是正确的，而且对于为什么这不起作用只是工作是完全不透明的。

当前的解决方法

由于不清楚您对RegisterServiceCtrlHandler 的声明是否有效，我建议interrogating this branch of your code in a debugger while your service is running，更重要的是，就这个问题联系微软。总而言之，您似乎已经正确地满足了所有功能依赖关系，系统返回了成功运行所需的所有内容，但是您的程序仍然进入未定义状态，看不到明确的补救措施。这是一个错误。

与此同时，一个可用的解决方法是使用 Haskell FFI 以另一种语言（例如 C++）定义您的服务架构，并通过 (a) 将您的 Haskell 代码暴露给您的服务层或 ( b) 将您的服务代码暴露给 Haskell。在这两种情况下，here's a starting reference to use 用于构建您的服务。

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

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

【讨论】：

感谢您提供有关您尝试的所有信息。听起来您在尝试重新创建诸如 MSDN 的示例服务之类的东西时遇到了完全相同的问题。我一直认为这与线程的工作方式有关，但在阅读了 Simon Marlow 的 paper 之后，似乎我正在以正确的方式做事。您是否认为处理程序的调用方式可能导致 Haskell 运行时不可用？
@MichaelSteele 我认为这是非常有可能的，但我没有机会在进程上安装调试器来查看（仅出于普通原因）。我认为实际上存在服务控制管理器无法解决的障碍，可能是关键部分的锁定、延迟的无效指针访问或其他问题。一位友好的前微软员工和我对此讨论了一会儿，我们得出的结论是，服务控制管理器没有有效地处理这种情况，这与其他人的经验完全一致 .
感谢您的所有帮助。我每个月左右都会回到这个问题。今天，我能够在切换到一些函数的较新“Ex”版本后调用我的处理程序。我仍然不知道真正的问题是什么，但那些版本的函数肯定在幕后做了一些不同的事情。
@MichaelSteele 没问题。每隔一段时间，我会考虑通过他的博客The Old New Thing 将其提交给Raymond Chen。我认为获得权威答案会很有趣，但我不确定这会落在队列中的哪个位置。不过，这可能值得一试。 :)
我今晚将Win32-services包上传到Hackage，很快就会更新这个问题。

【解决方案2】：

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

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

【讨论】：

到目前为止，Windows 10 仍然存在这个错误！我在调试一个简单的 Python ctypes 应用程序时遇到了同样的错误行为。您的解决方案使用RegisterServiceCtrlHandlerEx 代替RegisterServiceCtrlHandler，修复了它。非常感谢！

【解决方案3】：

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

【讨论】：

确实如此。它还会使 Haskell 在命令行中运行，这使得挂钩调试器更容易一些，+您可以在命令行中看到输出，等等。
我考虑过这个解决方案，特别是因为可以使用FFI 定义和外部化对 svcHandler 的回调。例如，可以使用the example provided by Microsoft 在 C 中编写服务层，并使用指向 Haskell 编译的 DLL 的指针为回调提供服务。我唯一担心的是这似乎与 OP 的意图相反。如果他们对这个解决方案没问题，那么在这里具体化它会很有用。