46

HaskellでWindowsサービスアプリケーションを書くのに苦労してきました。

バックグラウンド

サービスアプリケーションは、Windowsサービスコントロールマネージャーによって実行されます。起動すると、サービスのメイン関数として使用されるコールバックが提供されるStartServiceCtrlDispatcherへのブロッキング呼び出しを行います。

サービスのメイン関数は、start、stop、continueなどの着信コマンドを処理するための2番目のコールバックを登録することになっています。これは、RegisterServiceCtrlHandlerを呼び出すことによって行われます。

問題

サービスの主な機能を登録するプログラムを書くことができます。その後、プログラムを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

外国からの輸入は3回だけです。Win32に提供する2つのコールバックには「ラッパー」インポートがあります。

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>

次に、ServiceControlMonitorからサービスを開始します。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を更新

この問題はWindows764ビットで発生しますが、WindowsXPでは発生しません。他のバージョンのWindowsはまだテストされていません。コンパイルされた実行可能ファイルを複数のマシンにコピーして同じ手順を実行すると、異なる結果が得られます。

4

3 に答える 3

18

私は認めます、この問題はここ数日私を悩ませてきました。戻り値との内容をGetLastError調べて、このコードはシステムに従って正しく機能するはずだと判断しました。

明らかにそうではないため（サービスハンドラーの正常な実行を妨げる未定義の状態になっているようです）、完全な診断と回避策を投稿しました。これは、インターフェイスの保証が守られていないため、Microsoftが認識しておくべき正確な種類のシナリオです。

検査

（固定オプションを使用して）サービスに問い合わせようsc interrogate serviceとしたときにWindowsから報告されたエラーメッセージに大いに不満を感じた後、何か面白いことが起こっているかどうかを確認するために自分の呼び出しを書き込みました。sc control servicecontrolGetLastError

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_EXISTSappendFileフーイ、そしてここで私は何かに取り組んでいると思った。

しかし、これが私に教えてくれたのは、、、が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へのコード。どちらの場合も、サービスの構築に使用する最初のリファレンスは次のとおりです。

ここでもっとできたらよかったのに（正直に言って、合法的に試しました）、これでもこれを機能させるのに大いに役立つはずです。

幸運を祈ります。結果に興味を持っている人がかなり多いようです。

于 2012-04-15T05:08:20.567 に答える
6

私はこの問題を解決することができ、HaskellでWindowsサービスアプリケーションを作成するためのハッキングに関するライブラリWin32-servicesをリリースしました。

解決策は、他の組み合わせを避けながら、Win32呼び出しの特定の組み合わせを一緒に使用することでした。

于 2013-07-11T18:04:51.063 に答える
3

Cでサービスと相互作用する部分を記述し、Haskellで記述されたDLLを呼び出すようにする方が簡単ではないでしょうか。

于 2012-04-13T21:22:47.167 に答える