如何在Haskell中编写Windows服务应用程序？
我一直在努力在Haskell中编写Windows服务应用程序。
背景
服务应用程序由Windows服务控制pipe理器执行。 启动后，它会阻止对CallService提供的StartServiceCtrlDispatcher的调用，作为服务的主要function 。
该服务的主要function是应该注册第二个callback来处理传入的命令，如开始，停止，继续等。它通过调用RegisterServiceCtrlHandler 。
问题
我可以写一个程序，它将注册一个服务主要function。 然后，我可以将该程序安装为Windows服务，然后从服务pipe理控制台启动它。 该服务能够启动，报告自己正在运行，然后等待传入的请求。
问题是，我无法让我的服务处理函数被调用。 查询服务状态显示它正在运行，但只要我发送一个“停止”命令窗口popup消息说：
Windows could not stop the Test service on Local Computer. Error 1061: The service cannot accept control messages at this time. 根据MSDN文档 ，StartServiceCtrlDispatcher函数将阻塞，直到所有服务报告它们停止。 在调用服务主函数之后，调度程序线程应该等待，直到服务控制pipe理器发送一个命令，此时处理函数应该由该线程调用。
细节
接下来是我正在尝试做的一个非常简化的版本，但它演示了我的处理函数没有被调用的问题。
首先，一些名字和import：
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实例为数据编组定义一些特殊的数据types：
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 abcdefg) = 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
只需要三个外国import。 我将提供给Win32的两个callback有一个“包装”导入：
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>
然后我从服务控制监视器启动服务。 这certificate了我对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的内容，certificate我的第一个callbacksvcMain被调用了：
svcMain: svcMain here! svcMain: exiting
只要我使用服务控制pipe理器发送停止命令，我收到了我的错误消息。 我的处理程序函数应该添加一行到日志文件，但是这不会发生。 我的服务然后出现在停止状态：
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尚未经过testing。 当我编译的可执行文件复制到多台机器，并执行相同的步骤，我得到不同的结果。
我承认，这个问题已经让我烦恼了好几天了。 从走过返回值和GetLastError的内容，我已经确定这个代码应该根据系统正常工作。
因为它显然不是（似乎进入一个未定义的状态，禁止服务处理程序运行成功），我发布了我的完整诊断和解决方法。 这是微软应该知道的确切的情况，因为它的接口保证不被承认。
检查
在我试图询问服务（通过sc interrogate service和sc control service ，并且允许使用jar头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和ERROR_ALREADY_EXISTS正在被抛出……当你依次运行你的appendFile操作。 Phooey，在这里我以为我正在做些什么。
但是，这个告诉我的是， StartServiceCtrlDispatcher ， RegisterServiceCtrlHandler和SetServiceStatus 没有设置错误代码; 事实上，我完全按照希望得到了ERROR_SUCCESS 。
分析
令人鼓舞的是，Windows的“任务pipe理器”和“系统日志”将服务注册为“ 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服务types安装，则该成员将被忽略，但不能为NULL。 这个成员可以是一个空string（“”）。
根据我们挂钩的GetLastError和来自RegisterServiceCtrlHandler和SetServiceStatus （分别是一个有效的SERVICE_STATUS_HANDLE和true ）的返回，根据系统一切正常。 这不可能是正确的，而且这完全不透明。
目前的解决方法
因为目前还不清楚你的RegisterServiceCtrlHandler声明是否有效，所以我build议在你的服务正在运行的时候在debugging器中询问你的代码分支 ，更重要的是联系微软。 根据所有的说法，似乎你已经正确地满足了所有的函数依赖，系统返回了它应该成功运行的所有东西，但是你的程序仍然进入一个未定义的状态，没有明确的补救措施。 这是一个错误。
与此同时，可用的解决方法是使用Haskell FFI以另一种语言（例如C ++）定义您的服务架构，并通过（a）将您的Haskell代码暴露给您的服务层或（b）公开您的服务代码给Haskell。 在这两种情况下， 这是一个用于构build服务的开始参考 。
我希望我能在这里做更多的事情（我诚实地说，是合法的尝试），但即使这样做也会显着帮助你实现这个目标。
祝你好运。 看起来你有相当多的人对你的结果感兴趣。
我能解决这个问题，并发布了一个hackage库， Win32服务 ，用于在Haskell中编写Windows服务应用程序。
解决方法是使用某些Win32调用组合，同时避免其他组合。
用C编写与服务交互的部分会不会更容易，并且调用一个用Haskell编写的DLL？
