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

Posted

技术标签:

【中文标题】如何用 Haskell 编写 Windows 服务应用程序?【英文标题】:How can a Windows service application be written in Haskell? 【发布时间】: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 提出一个绝妙的问题。 【参考方案1】:

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

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

检查

当我尝试询问服务时(通过sc interrogate servicesc 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,在这里我以为我在做某事。

这确实告诉我,StartServiceCtrlDispatcherRegisterServiceCtrlHandlerSetServiceStatus 没有设置错误代码;确实,我得到了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 以及来自RegisterServiceCtrlHandlerSetServiceStatus 的返回(分别是有效的SERVICE_STATUS_HANDLEtrue),根据系统,一切正常。这不可能是正确的,而且对于为什么这不起作用只是工作是完全不透明的。

当前的解决方法

由于不清楚您对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 的意图相反。如果他们对这个解决方案没问题,那么在这里具体化它会很有用。

以上是关于如何用 Haskell 编写 Windows 服务应用程序?的主要内容,如果未能解决你的问题,请参考以下文章

如何用vs2012编写能在windows2000运行的程序

如何用C#编程操作Windows系统服务

如何写一颗60行的红黑树(in Haskell)

如何用Dos环境下的C语言编写在Windows操作系统环境下使用的图形用户界面?

如何用Nginx部署Django

如何用 C# 编写可以远程调用的 DCOM 服务器?