How can a Windows application be written to Haskell?

Question

I am trying to write a windows application in Haskell.

Background

The service is performed by the Windows Service Control Manager. After starting, it blocks the StartServiceCtrlDispatcher call, which comes with a callback that will be used as the main function.

The main function of the service is to register a second callback to process incoming commands, such as start, stop, continue, etc. It does this by calling RegisterServiceCtrlHandler .

Problem

I can write a program that will register the main function of the service. Then I can install the program as a Windows service and run it from the service management console. A service can start, report itself as starting, and then wait for incoming requests.

The problem is that I cannot get the function of the service handler . A service status request indicates that it is running, but as soon as I send it, the "stop" windows will display a message with the message:

Windows could not stop the Test service on Local Computer. Error 1061: The service cannot accept control messages at this time. 

According to the MSDN documentation, the StartServiceCtrlDispatcher function is blocked until all services report that they are stopped. After calling the main function of the service, the dispatcher thread must wait until the service control dispatcher sends a command, after which the handler function must be called by this thread.

More details

The following is a very simplified version of what I'm trying to do, but it demonstrates the problem of the non-invoked function of my handler.

First, a few names and imports:

 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 () 

I need to define some special data types with Storable instances to sort the data:

 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 

Only three import imports are required. There, a wrapper is imported for the two callbacks that I will supply 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 program

Finally, here is the main utility application:

 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 

Exit

I previously installed the service using sc create Test binPath= c:\Main.exe .

Here is the result of compiling the program:

 C:\path>ghc -threaded --make Main.hs [1 of 1] Compiling Main ( Main.hs, Main.o ) Linking Main.exe ... C:\path> 

Then I start the service from the service control monitor. Here is the proof that my call to SetServiceStatus was accepted:

 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> 

Here is the contents of log.txt proving that my first svcMain was called:

 svcMain: svcMain here! svcMain: exiting 

As soon as I send a stop command using the service control manager, I get an error. My handler function was to add a line to the log file, but this does not happen. Then my service appears in a stopped state:

 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

Does anyone have any ideas that I can try to call my handler function?

Update 20130306

I have this problem on a 64-bit version of Windows 7, but not on Windows XP. Other versions of Windows have not yet been tested. When I copy the compiled executable to several machines and follow the same steps, I get different results.

Answer 1

I was able to solve this problem and released the hackage library, Win32-services , for writing Windows applications in Haskell.

The solution was to use certain combinations of Win32 calls together, avoiding other combinations.

Answer 2

I admit that this problem has annoyed me for several days now. From passes of return values ​​and GetLastError content, I determined that this code should work correctly in accordance with the system.

Because this is clearly not (it seems to introduce an undefined state that prevents the service handler from starting successfully), I published my full diagnosis and workaround. This is the exact kind of scenario that Microsoft should be aware of because its interface guarantees are not respected.

Inspection

After very dissatisfaction with the error messages reported by Windows, when I tried to poll the service (via sc interrogate service and sc control service with the canned control option enabled), I wrote my own call to GetLastError to find out if something interesting was happening:

 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)) 

To my chagrin, what I discovered was that ERROR_INVALID_HANDLE and ERROR_ALREADY_EXISTS were thrown away ... when you execute the appendFile operations sequentially, Phooey, and here I thought I did something.

However, it said that StartServiceCtrlDispatcher , RegisterServiceCtrlHandler and SetServiceStatus did not set an error code; indeed, I get ERROR_SUCCESS exactly as I hoped.

Analysis

Encouragingly, Windows Task Manager and system logs register the service as RUNNING . So, assuming that part of the equation really works, we must get back to why our service handler is not getting properly.

Checking these lines:

 fpHandler <- handlerToFunPtr svcHandler h <- c_RegisterServiceCtrlHandler (head args) fpHandler _ <- setServiceStatus h running 

I tried to enter nullFunPtr as my fpHandler . Encouragingly, this made the service hang in the START_PENDING state. Good: this means that the contents of fpHandler actually processed when the service is registered.

Then I tried this:

 t <- newTString "Foo" h <- c_RegisterServiceCtrlHandler t fpHandler 

And this, unfortunately, took. However, which was expected :

If the service is installed using the SERVICE_WIN32_OWN_PROCESS type service, this element is ignored, but cannot be NULL. This member may be an empty string ("").

According to our connected GetLastError and return from RegisterServiceCtrlHandler and SetServiceStatus (valid SERVICE_STATUS_HANDLE and true , respectively), everything fits the system well. It may not be right, and it is completely opaque why it does not just work.

Current workaround

Since it is unclear if your declaration in RegisterServiceCtrlHandler works, I recommend that you poll this branch of your code in the debugger while your service is running , and more importantly, contact Microsoft about this. According to all the information, it seems that you correctly completed all the functional dependencies, the system returns everything that is necessary for a successful launch, and yet your program still enters an undefined state without visible remedies. This is mistake.

At the same time, you can use Haskell FFI to define your service architecture in another language (for example, C ++) and connect to your code either (a) exposing your Haskell code to your level of service, or (b) exposing your Haskell utility code . In both cases, here is a start link to use to create your service.

It is a pity that I could do more here (honestly, legally tried), but even this should help you a lot.

Good luck to you. It seems that you have a fairly large number of people interested in your results.

Answer 3

Wouldn’t it be easier to write down the part that interacts with the service in C and make it call the DLL written in Haskell?