J'ai eu du mal à écrire une application de service Windows en Haskell.
Contexte
Une application de service est exécutée par le gestionnaire de contrôle des services Windows. Lors de son lancement, elle effectue un appel bloquant à StartServiceCtrlDispatcher qui est fourni avec un callback à utiliser comme le fonction principale du service .
La fonction principale du service est censée enregistrer une deuxième fonction de rappel pour gérer les commandes entrantes telles que démarrer, arrêter, continuer, etc. Elle le fait en appelant RegisterServiceCtrlHandler .
Problème
Je suis capable d'écrire un programme qui enregistrera une fonction principale de service. Je peux ensuite installer le programme en tant que service Windows et le démarrer à partir de la console de gestion des services. Le service est capable de démarrer, de se déclarer en cours d'exécution, puis d'attendre les demandes entrantes.
Le problème est que je ne parviens pas à faire en sorte que mon fonction de gestionnaire de service pour être appelé. L'interrogation de l'état des services révèle qu'il est en cours d'exécution, mais dès que je lui envoie une commande d'arrêt, Windows affiche un message disant :
Windows could not stop the Test service on Local Computer.
Error 1061: The service cannot accept control messages at this time.Según Documentation MSDN la fonction StartServiceCtrlDispatcher se bloque jusqu'à ce que tous les services signalent qu'ils sont arrêtés. Après l'appel de la fonction principale du service, un fil d'exécution du distributeur est censé attendre que le gestionnaire de contrôle des services envoie une commande, après quoi la fonction du gestionnaire doit être appelée par ce fil d'exécution.
Détails
Ce qui suit est une version très simplifiée de ce que j'essaie de faire, mais il démontre le problème de ma fonction de gestion qui n'est pas appelée.
Tout d'abord, quelques noms et importations :
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 ()J'ai besoin de définir quelques types de données spéciaux avec des instances Storable pour le marshalling de données :
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) gSeules trois importations étrangères doivent être effectuées. Il y a un import 'wrapper' pour les deux callbacks que je vais fournir à 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 BOOLProgramme principal
Enfin, voici l'application de service principale :
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 3000Sortie
J'ai précédemment installé le service en utilisant sc create Test binPath= c:\Main.exe .
Voici le résultat de la compilation du programme :
C:\path>ghc -threaded --make Main.hs
[1 of 1] Compiling Main ( Main.hs, Main.o )
Linking Main.exe ...
C:\path>Je lance ensuite le service à partir du Service Control Monitor. Voici la preuve que mon appel à SetServiceStatus a été accepté :
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>Voici le contenu de log.txt ce qui prouve que mon premier rappel, svcMain a été appelé :
svcMain: svcMain here!
svcMain: exitingDès que j'envoie une commande d'arrêt à l'aide du gestionnaire de contrôle des services, j'obtiens mon message d'erreur. Ma fonction de gestion était censée ajouter une ligne au fichier journal, mais cela ne se produit pas. Mon service apparaît alors dans l'état arrêté :
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>Question
Quelqu'un a-t-il une idée de ce que je pourrais essayer de faire pour que ma fonction de gestionnaire soit appelée ?
Mise à jour 20130306
J'ai ce problème sous Windows 7 64 bits, mais pas sous Windows XP. Les autres versions de Windows n'ont pas encore été testées. Lorsque je copie l'exécutable compilé sur plusieurs machines et que j'effectue les mêmes étapes, j'obtiens des résultats différents.
