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

Question

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

背景

服务应用程序由Windows Service Control Manager执行。启动后，它会对StartServiceCtrlDispatcher进行阻塞调用，该函数提供用作服务主函数的回调函数。

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

问题

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

问题在于我无法调用服务处理函数。查询服务状态显示它正在运行，但是一旦我发送一个“停止”命令，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尚未测试。当我将编译后的可执行文件复制到多台机器上并执行相同的步骤时，结果不同。

- Michael Steele

---

+1，非常好的问题。我猜这个问题还没有被解决，因为有了赏金。我稍后会看一下这个问题。 - MrGomez

抱歉，但我没有看到您的svcHandler实现调用SetServiceStatus来报告服务的SERVICE_STOPPED状态。另一个问题：您在日志文件中是否看到消息“svcCtrlHandler：received.\n”？顺便说一下，我建议您使用sc interrogate Test来验证svcHandler是否正确注册。如果svcHandler接收到输入为SERVICE_CONTROL_INTERROGATE(4)，它应该像svcMain一样调用SetServiceStatus以报告状态rUNNING(SERVICE_RUNNING)和其接受的控制（aCCEPT_STOP）。 - Oleg

@Oleg 这个例子的处理程序为了保持简单并没有做任何事情。据我所见，它甚至没有被调用。我还没有尝试手动查询服务，但会去尝试一下。我的日志文件中没有包含预期的输出。 - Michael Steele

我回来并仔细研究了你的代码，重现了你遇到的完全相同的问题。sc interrogate Test 抛出了 _"The service cannot accept control messages at this time"_，这是一个很大的线索。根据微软提供的这个实例，在 SERVICE_RUNNING 之前，你需要将初始状态设置为 SERVICE_START_PENDING。我相信当你纠正了状态转换后，代码将开始按预期工作--其他所有内容都已检查完毕。 - MrGomez

哎呀，终于在闲逛了几天后找到了答案。根据您连接的代码返回值，一切都是正确的，但它却无法正常工作。我认为这是一个非常好的问题，可以向Raymond Chen请教。 - MrGomez

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

我发现令人失望的是，当您按顺序运行appendFile操作时，将抛出ERROR_INVALID_HANDLE和ERROR_ALREADY_EXISTS。哎呀，我以为我找到了什么。

然而，这告诉我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 来连接您的代码。在两种情况下，这是一个起始参考 用于构建您的服务。

我希望我能在这里做更多的事情（我真诚地、认真地尝试了），但即使只有这些，也应该可以显着帮助您使其正常工作。

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

- MrGomez

---

感谢您提供的所有尝试信息。听起来您遇到了与我尝试重新创建类似于MSDN示例服务时完全相同的问题。我一直在想这与线程工作方式有关，但在阅读了Simon Marlow的论文之后，它“似乎”我正在正确地处理事情。您认为可能是处理程序以某种方式被调用，使得Haskell运行时不可用吗？ - Michael Steele

@MichaelSteele 我认为这是非常可能的，但我没有机会在进程上贴一个调试器来查看（仅因为平凡的原因）。我推测实际上存在一道障碍，服务控制管理器无法解决，可能是关键部分的锁定、延迟的无效指针访问或其他问题。我和一位友好的前微软员工闲聊了一会儿，得出结论：服务控制管理器没有强大地处理这种情况，这与其他人的经验完全一致。 - MrGomez

感谢您的所有帮助。我每个月左右都会回来解决这个问题。今天，我成功地将我的处理程序调用了起来，只需切换到较新的“Ex”版本即可。我仍然不知道真正的问题是什么，但是这些函数的新版本在幕后一定做了一些不同的事情。 - Michael Steele

@MichaelSteele 没问题。我时不时地考虑通过他的博客The Old New Thing向Raymond Chen提交此内容。我认为获得权威答案会很有趣，但我不确定这将排在队列的哪个位置。不过，尝试一下也许是值得的。 :) - MrGomez

我今晚已将Win32-services软件包上传至Hackage，并将很快更新此问题。 - Michael Steele

Answer 2

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

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

- Michael Steele

---

到了现在，Windows 10 仍然存在这个 bug！我在调试一个简单的 Python ctypes 应用程序时遇到了相同的问题。您提供的解决方案，使用 RegisterServiceCtrlHandlerEx 替换 RegisterServiceCtrlHandler，解决了这个问题。非常感谢！ - George

Answer 3

如果使用C语言编写与服务交互的部分，并让其调用由Haskell编写的DLL文件，这样不是更容易吗？

- LRN

---

确实。这还会使Haskell在命令行上运行，使得挂载调试器变得更加容易，你可以在命令行上看到输出等。 - ixe013

我考虑了这个解决方案，特别是因为可以使用FFI定义并导出回调到 svcHandler。例如，一个人可以使用Microsoft提供的示例用C编写服务层，并使用指向Haskell编译的DLL的指针处理回调。 我唯一担心的是，这似乎与OP的意图相反。如果他们对这个解决方案“满意”，那么对它的具体说明在这里将很有用。 - MrGomez