我一直在努力用 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 ()
我需要使用 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 尚未经过测试。当我将编译后的可执行文件复制到多台机器并执行相同的步骤时,我会得到不同的结果。
最佳答案
我承认,这个问题已经困扰我好几天了。遍历 GetLastError
的返回值和内容,我已确定此代码应根据系统正常工作。
因为它显然不是(它似乎进入了阻止服务处理程序成功运行的未定义状态),所以我发布了我的完整诊断和解决方法。这是微软应该意识到的确切情况,因为它的接口(interface)保证没有得到兑现。
检查
当我尝试询问服务时(通过 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
and ERROR_ALREADY_EXISTS
被抛出......当你运行你的appendFile
依次操作。 Phooey,在这里我以为我在做某事。然而,这确实告诉我的是
StartServiceCtrlDispatcher
, RegisterServiceCtrlHandler
, 和 SetServiceStatus
没有设置错误代码;确实,我得到了 ERROR_SUCCESS
完全如所愿。分析
令人鼓舞的是,Windows 的任务管理器和系统日志将服务注册为
RUNNING
.所以,假设等式的一部分确实有效,我们必须回到为什么我们的服务处理程序没有被正确命中。检查这些行:
fpHandler <- handlerToFunPtr svcHandler
h <- c_RegisterServiceCtrlHandler (head args) fpHandler
_ <- setServiceStatus h running
我试图注入(inject)
nullFunPtr
作为我的fpHandler
.令人鼓舞的是,这导致服务在 START_PENDING
中挂起。状态。好:这意味着fpHandler
的内容实际上是在我们注册服务时处理的。然后,我尝试了这个:
t <- newTString "Foo"
h <- c_RegisterServiceCtrlHandler t fpHandler
而这,不幸的是,采取了。但是,that's expected :
If the service is installed with the
SERVICE_WIN32_OWN_PROCESS
service type, this member is ignored, but cannot be NULL. This member can be an empty string ("").
据我们迷上
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 来 Hook 你的代码。在这两种情况下,here's a starting reference to use用于构建您的服务。
我希望我能在这里做得更多(老实说,我合法地尝试过),但即使是这么多也应该极大地帮助你完成这项工作。
祝你好运。看起来您有相当多的人对您的结果感兴趣。
关于winapi - 如何用 Haskell 编写 Windows 服务应用程序?,我们在Stack Overflow上找到一个类似的问题: https://stackoverflow.com/questions/10037654/