Win32-services 0.2.4 → 0.2.5
raw patch · 12 files changed
+738/−721 lines, 12 filesdep −errorsdep ~base
Dependencies removed: errors
Dependency ranges changed: base
Files
- LICENSE +1/−1
- Win32-services.cabal +126/−125
- src/Import.hs +19/−0
- src/System/Win32/SystemServices/Services.hs +169/−170
- src/System/Win32/SystemServices/Services/Raw.hs +31/−33
- src/System/Win32/SystemServices/Services/SERVICE_ACCEPT.hs +88/−91
- src/System/Win32/SystemServices/Services/SERVICE_CONTROL.hs +64/−68
- src/System/Win32/SystemServices/Services/SERVICE_STATE.hs +52/−56
- src/System/Win32/SystemServices/Services/SERVICE_STATUS.hs +103/−83
- src/System/Win32/SystemServices/Services/SERVICE_TABLE_ENTRY.hs +26/−29
- src/System/Win32/SystemServices/Services/SERVICE_TYPE.hs +50/−55
- src/System/Win32/SystemServices/Services/Types.hs +9/−10
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c)2011-2014, Michael Steele +Copyright 2011-2015, Michael Steele All rights reserved.
Win32-services.cabal view
@@ -1,125 +1,126 @@-name: Win32-services -category: System -version: 0.2.4 -cabal-version: >= 1.14 -build-type: Simple -author: Michael Steele -maintainer: Michael Steele <mikesteele81@gmail.com> -copyright: Copyright (C) 2011-2014 Michael Steele -homepage: http://github.com/mikesteele81/win32-services -bug-reports: http://github.com/mikesteele81/win32-services/issues -license: BSD3 -license-file: LICENSE -tested-with: GHC == 7.8.2 -stability: provisional -synopsis: Windows service applications -description: - This package provides a partial binding to the Win32 System Services - API. It makes it easy to write Windows service applications using - Haskell. - . - The binding is partial. Here are a few ways in which it differs from the - official API: - . - * Only services running within their own process are supported. These are - processes of the 'WIN32_OWN_PROCESS' type. - . - * In cases where multiple versions of the same function exist (for - compatibility), this binding only offers one of them. - . - * None of the extended control codes are supported. Handlers you write will - automatically report this to the operating system when such controls are - received. - . - * Only facilities for writing services are supported; not controlling them. - . - Effort has been made to simplify using the API without hiding what is - happening behind the scenes. Users are encouraged to read Microsoft's - documentation under 'Dev Center - Desktop > Docs > Desktop app development - documentation > System Services > Services'. The official example has been - ported to Haskell. This can be found in the 'examples' directory of the - source tree. - . - /Simple Example and Usage/ - . - @ - module Main where - . - import Control.Concurrent.MVar - import System.Win32.SystemServices.Services - . - main = do -   mStop <- newEmptyMVar -   startServiceCtrlDispatcher \"Test\" 3000 (handler mStop) $ \\_ _ h -> do -   setServiceStatus h running -   takeMVar mStop -   setServiceStatus h stopped - . - handler mStop hStatus STOP = do -   setServiceStatus hStatus stopPending -   putMVar mStop () -   return True - handler _ _ INTERROGATE = return True - handler _ _ _ = return False - . - running = SERVICE_STATUS WIN32_OWN_PROCESS RUNNING [ACCEPT_STOP] nO_ERROR 0 0 0 - stopped = SERVICE_STATUS WIN32_OWN_PROCESS STOPPED [] nO_ERROR 0 0 0 - stopPending = SERVICE_STATUS WIN32_OWN_PROCESS START_PENDING [ACCEPT_STOP] nO_ERROR 0 0 0 - @ - . - @ - C:\programming\test\>ghc --make -threaded Main.hs - [1 of 1] Compiling Main ( Main.hs, Main.o ) - Linking Main.exe ... - \<linker warnings omitted\> - C:\\programming\\test\>copy Main.exe c:\\svc\\Test.exe - 1 file(s) copied. - @ - . - Execute the following from an elevated command prompt to register the - service: - . - @ - C:\\svc\>sc create Test binPath= c:\\svc\\Test.exe - [SC] CreateService SUCCESS - @ - . - The service can now be started and stopped from the services console. - . - Installation Notes: - . - Depending on which version of Windows and the Windows SDK you are using the - .cabal file will need to be modified before installing. A simple `cabal - install Win32-services` may not work. For example, If you are building on - Windows 8 64-bit with the Windows 8 SDK the 'extra-lib-dirs' field will need - to be changed to read as follows: - . - @ - Extra-Lib-Dirs: \"C:\\\\Program Files (x86)\\\\Windows Kits\\\\8.0\\\\Lib\\\\win8\\\\um\\\\x86\" - @ -extra-source-files: - changelog - examples/*.hs - -source-repository head - type: git - location: git://github.com/mikesteele81/win32-services.git - -library - build-depends: base >= 4.5 && < 4.8 - , errors >= 1.4 && < 1.5 - , Win32 >= 2.2 && < 2.4 - default-language: Haskell2010 - ghc-options: -Wall - hs-source-dirs: src - Exposed-Modules: System.Win32.SystemServices.Services - Extra-Libraries: Advapi32 - Extra-Lib-Dirs: c:\Windows\System32 - other-modules: System.Win32.SystemServices.Services.SERVICE_STATUS - , System.Win32.SystemServices.Services.Raw - , System.Win32.SystemServices.Services.SERVICE_TABLE_ENTRY - , System.Win32.SystemServices.Services.Types - , System.Win32.SystemServices.Services.SERVICE_ACCEPT - , System.Win32.SystemServices.Services.SERVICE_CONTROL - , System.Win32.SystemServices.Services.SERVICE_STATE - , System.Win32.SystemServices.Services.SERVICE_TYPE +name: Win32-services+category: System+version: 0.2.5+cabal-version: >= 1.16+build-type: Simple+author: Michael Steele+maintainer: Michael Steele <mikesteele81@gmail.com>+copyright: Copyright 2011-2015 Michael Steele+homepage: http://github.com/mikesteele81/win32-services+bug-reports: http://github.com/mikesteele81/win32-services/issues+license: BSD3+license-file: LICENSE+tested-with: GHC == 7.6.3, GHC == 7.8.3, GHC == 7.10.1+stability: provisional+synopsis: Windows service applications+description:+ This package provides a partial binding to the Win32 System Services+ API. It makes it easy to write Windows service applications using+ Haskell. _Only 32-bit versions of GHC are supported at this time._+ .+ The binding is partial. Here are a few ways in which it differs from the+ official API:+ .+ * Only services running within their own process are supported. These are+ processes of the 'WIN32_OWN_PROCESS' type.+ .+ * In cases where multiple versions of the same function exist (for+ compatibility), this binding only offers one of them.+ .+ * None of the extended control codes are supported. Handlers you write will+ automatically report this to the operating system when such controls are+ received.+ .+ * Only facilities for writing services are supported; not controlling them.+ .+ Effort has been made to simplify using the API without hiding what is+ happening behind the scenes. Users are encouraged to read Microsoft's+ documentation under 'Dev Center - Desktop > Docs > Desktop app development+ documentation > System Services > Services'. The official example has been+ ported to Haskell. This can be found in the 'examples' directory of the+ source tree.+ .+ /Simple Example and Usage/+ .+ @+ module Main where+ .+ import Control.Concurrent.MVar+ import System.Win32.SystemServices.Services+ .+ main = do+   mStop <- newEmptyMVar+   startServiceCtrlDispatcher \"Test\" 3000 (handler mStop) $ \\_ _ h -> do+   setServiceStatus h running+   takeMVar mStop+   setServiceStatus h stopped+ .+ handler mStop hStatus STOP = do+   setServiceStatus hStatus stopPending+   putMVar mStop ()+   return True+ handler _ _ INTERROGATE = return True+ handler _ _ _ = return False+ .+ running = SERVICE_STATUS WIN32_OWN_PROCESS RUNNING [ACCEPT_STOP] nO_ERROR 0 0 0+ stopped = SERVICE_STATUS WIN32_OWN_PROCESS STOPPED [] nO_ERROR 0 0 0+ stopPending = SERVICE_STATUS WIN32_OWN_PROCESS START_PENDING [ACCEPT_STOP] nO_ERROR 0 0 0+ @+ .+ @+ C:\programming\test\>ghc --make -threaded Main.hs+ [1 of 1] Compiling Main ( Main.hs, Main.o )+ Linking Main.exe ...+ \<linker warnings omitted\>+ C:\\programming\\test\>copy Main.exe c:\\svc\\Test.exe+ 1 file(s) copied.+ @+ .+ Execute the following from an elevated command prompt to register the+ service:+ .+ @+ C:\\svc\>sc create Test binPath= c:\\svc\\Test.exe+ [SC] CreateService SUCCESS+ @+ .+ The service can now be started and stopped from the services console.+ .+ Installation Notes:+ .+ Depending on which version of Windows and the Windows SDK you are using the+ .cabal file will need to be modified before installing. A simple `cabal+ install Win32-services` may not work. For example, If you are building on+ Windows 8 64-bit with the Windows 8 SDK the 'extra-lib-dirs' field will need+ to be changed to read as follows:+ .+ @+ Extra-Lib-Dirs: \"C:\\\\Program Files (x86)\\\\Windows Kits\\\\8.0\\\\Lib\\\\win8\\\\um\\\\x86\"+ @+extra-source-files:+ changelog+ examples/*.hs++source-repository head+ type: git+ location: git://github.com/mikesteele81/win32-services.git++library+ build-depends: base >= 4.5 && < 4.9+ , Win32 >= 2.2 && < 2.4+ default-language: Haskell2010+ ghc-options: -Wall+ hs-source-dirs: src+ Exposed-Modules: System.Win32.SystemServices.Services+ Extra-Libraries: Advapi32+ Extra-Lib-Dirs: c:\Windows\System32+ other-modules:+ Import+ , System.Win32.SystemServices.Services.SERVICE_STATUS+ , System.Win32.SystemServices.Services.Raw+ , System.Win32.SystemServices.Services.SERVICE_TABLE_ENTRY+ , System.Win32.SystemServices.Services.Types+ , System.Win32.SystemServices.Services.SERVICE_ACCEPT+ , System.Win32.SystemServices.Services.SERVICE_CONTROL+ , System.Win32.SystemServices.Services.SERVICE_STATE+ , System.Win32.SystemServices.Services.SERVICE_TYPE
+ src/Import.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE CPP #-} + +module Import + ( module X + , hush + ) where + +#if MIN_VERSION_base(4,8,0) +#else +import Control.Applicative as X +#endif +import Foreign as X + +import System.Win32.Types as X + +-- | Suppress the 'Left' value of an 'Either' +-- taken from the errors package +hush :: Either a b -> Maybe b +hush = either (const Nothing) Just
src/System/Win32/SystemServices/Services.hs view
@@ -1,170 +1,169 @@-module System.Win32.SystemServices.Services - ( HandlerFunction - , ServiceMainFunction - , SERVICE_ACCEPT (..) - , SERVICE_CONTROL (..) - , SERVICE_STATE (..) - , SERVICE_STATUS (..) - , SERVICE_TYPE (..) - , nO_ERROR - , eRROR_SERVICE_SPECIFIC_ERROR - , queryServiceStatus - , setServiceStatus - , startServiceCtrlDispatcher - ) where - -import Control.Exception -import Control.Monad.Fix -import Foreign -import System.Win32.Types - -import System.Win32.SystemServices.Services.Raw -import System.Win32.SystemServices.Services.SERVICE_ACCEPT -import System.Win32.SystemServices.Services.SERVICE_CONTROL -import qualified System.Win32.SystemServices.Services.SERVICE_CONTROL as SC -import System.Win32.SystemServices.Services.SERVICE_STATE -import System.Win32.SystemServices.Services.SERVICE_STATUS -import System.Win32.SystemServices.Services.SERVICE_TABLE_ENTRY -import System.Win32.SystemServices.Services.SERVICE_TYPE -import System.Win32.SystemServices.Services.Types - --- | A handler function is registered with the service dispatcher thread --- from a 'ServiceMainFunction'. The first argument is a 'HANDLE' returned --- from calling 'registerServiceCtrlHandler'. The second argument represents --- the command this service has been directed to perform. -type HandlerFunction = HANDLE -> SERVICE_CONTROL -> IO Bool - --- | The service dispatcher thread will call each function of this type that --- you provide. The first argument will be the name of the service. Any --- additional command-line parameters will appear in the second argument. --- --- Each of these functions should call 'registerServiceCtrlHandler' to --- register a function to handle incoming commands. It should then set --- the service's status to 'START_PENDING', and specify that no controls --- will be accepted. At this point the function may perform any other --- initialization steps before setting the service's status to --- 'RUNNING'. All of this should take no more than 100ms. -type ServiceMainFunction = String -> [String] -> HANDLE -> IO () - --- |Retrieves the current status of the specified service. -queryServiceStatus :: HANDLE - -- ^ MSDN documentation: A handle to the service. This handle is returned - -- by the OpenService or the CreateService function, and it must have the - -- SERVICE_QUERY_STATUS access right. For more information, see Service - -- Security and Access Rights. - -> IO SERVICE_STATUS - -- ^ This function will raise an exception if the Win32 call returned an - -- error condition. -queryServiceStatus h = alloca $ \pStatus -> do - failIfFalse_ (unwords ["QueryServiceStatus"]) - $ c_QueryServiceStatus h pStatus - peek pStatus - --- | Register an handler function to be called whenever the operating system --- receives service control messages. -registerServiceCtrlHandlerEx :: String - -- ^ The name of the service. According to MSDN documentation this - -- argument is unused in WIN32_OWN_PROCESS type services, which is the - -- only type supported by this binding. Even so, it is recommended - -- that the name of the service be used. - -- - -- MSDN description: The name of the service run by the calling thread. - -- This is the service name that the service control program specified in - -- the CreateService function when creating the service. - -> HandlerFunction - -- ^ A Handler function to be called in response to service control - -- messages. Behind the scenes this is translated into a "HandlerEx" type - -- handler. - -> IO (HANDLE, LPHANDLER_FUNCTION_EX) - -- ^ The returned handle may be used in calls to SetServiceStatus. For - -- convenience Handler functions also receive a handle for the service. -registerServiceCtrlHandlerEx str handler = - withTString str $ \lptstr -> - -- use 'ret' instead of (h', _) to avoid divergence. - mfix $ \ret -> do - fpHandler <- handlerToFunPtr $ toHandlerEx (fst ret) handler - h <- failIfNull (unwords ["RegisterServiceCtrlHandlerEx", str]) - $ c_RegisterServiceCtrlHandlerEx lptstr fpHandler nullPtr - return (h, fpHandler) - --- |Updates the service control manager's status information for the calling --- service. -setServiceStatus :: HANDLE - -- ^ MSDN documentation: A handle to the status information structure for - -- the current service. This handle is returned by the - -- RegisterServiceCtrlHandlerEx function. - -> SERVICE_STATUS - -- ^ MSDN documentation: A pointer to the SERVICE_STATUS structure the - -- contains the latest status information for the calling service. - -> IO () - -- ^ This function will raise an exception if the Win32 call returned an - -- error condition. -setServiceStatus h status = - with status $ \pStatus -> do - failIfFalse_ (unwords ["SetServiceStatus", show h, show status]) - $ c_SetServiceStatus h pStatus - --- |Register a callback function to initialize the service, which will be --- called by the operating system immediately. startServiceCtrlDispatcher --- will block until the provided callback function returns. --- --- MSDN documentation: Connects the main thread of a service process to the --- service control manager, which causes the thread to be the service control --- dispatcher thread for the calling process. -startServiceCtrlDispatcher :: String - -- ^ The name of the service. According to MSDN documentation this - -- argument is unused in WIN32_OWN_PROCESS type services, which is the - -- only type supported by this binding. Even so, it is recommended - -- that the name of the service be used. - -- - -- MSDN description: The name of the service run by the calling thread. - -- This is the service name that the service control program specified in - -- the CreateService function when creating the service. - -> DWORD - -> HandlerFunction - -> ServiceMainFunction - -- ^ This is a callback function that will be called by the operating - -- system whenever the service is started. It should perform service - -- initialization including the registration of a handler function. - -- MSDN documentation gives conflicting advice as to whether this function - -- should return before the service has entered the stopped state. - -- In the official example the service main function blocks until the - -- service is ready to stop. - -> IO () - -- ^ An exception will be raised if the underlying Win32 call returns an - -- error condition. -startServiceCtrlDispatcher name wh handler main = - withTString name $ \lptstr -> - bracket (toSMF main handler wh >>= smfToFunPtr) freeHaskellFunPtr $ \fpMain -> - withArray [SERVICE_TABLE_ENTRY lptstr fpMain, nullSTE] $ \pSTE -> - failIfFalse_ (unwords ["StartServiceCtrlDispatcher", name]) $ do - c_StartServiceCtrlDispatcher pSTE - -toSMF :: ServiceMainFunction -> HandlerFunction -> DWORD -> IO SERVICE_MAIN_FUNCTION -toSMF f handler wh = return $ \len pLPTSTR -> do - lptstrx <- peekArray (fromIntegral len) pLPTSTR - args <- mapM peekTString lptstrx - -- MSDN guarantees args will have at least 1 member. - let name = head args - (h, fpHandler) <- registerServiceCtrlHandlerEx name handler - setServiceStatus h $ SERVICE_STATUS WIN32_OWN_PROCESS START_PENDING [] nO_ERROR 0 0 wh - f name (tail args) h - freeHaskellFunPtr fpHandler - --- This was originally written with older style handle functions in mind. --- I'm now using HandlerEx style functions, and need to add support for --- the extra parameters here. -toHandlerEx :: HANDLE -> HandlerFunction -> HANDLER_FUNCTION_EX -toHandlerEx h f = \dwControl _ _ _ -> - case SC.fromDWORD dwControl of - Right control -> do - handled <- f h control - case control of - INTERROGATE -> return nO_ERROR - -- If we ever support extended control codes this will have to - -- change. see "Dev Center - Desktop > Docs > Desktop app - -- development documentation > System Services > Services > - -- Service Reference > Service Functions > HandlerEx". - _ -> return $ if handled then nO_ERROR - else eRROR_CALL_NOT_IMPLEMENTED - Left _ -> return eRROR_CALL_NOT_IMPLEMENTED +module System.Win32.SystemServices.Services+ ( HandlerFunction+ , ServiceMainFunction+ , SERVICE_ACCEPT (..)+ , SERVICE_CONTROL (..)+ , SERVICE_STATE (..)+ , SERVICE_STATUS (..)+ , SERVICE_TYPE (..)+ , nO_ERROR+ , eRROR_SERVICE_SPECIFIC_ERROR+ , queryServiceStatus+ , setServiceStatus+ , startServiceCtrlDispatcher+ ) where++import Control.Exception+import Control.Monad.Fix++import Import+import System.Win32.SystemServices.Services.Raw+import System.Win32.SystemServices.Services.SERVICE_ACCEPT+import System.Win32.SystemServices.Services.SERVICE_CONTROL+import qualified System.Win32.SystemServices.Services.SERVICE_CONTROL as SC+import System.Win32.SystemServices.Services.SERVICE_STATE+import System.Win32.SystemServices.Services.SERVICE_STATUS+import System.Win32.SystemServices.Services.SERVICE_TABLE_ENTRY+import System.Win32.SystemServices.Services.SERVICE_TYPE+import System.Win32.SystemServices.Services.Types++-- | A handler function is registered with the service dispatcher thread+-- from a 'ServiceMainFunction'. The first argument is a 'HANDLE' returned+-- from calling 'registerServiceCtrlHandler'. The second argument represents+-- the command this service has been directed to perform.+type HandlerFunction = HANDLE -> SERVICE_CONTROL -> IO Bool++-- | The service dispatcher thread will call each function of this type that+-- you provide. The first argument will be the name of the service. Any+-- additional command-line parameters will appear in the second argument.+--+-- Each of these functions should call 'registerServiceCtrlHandler' to+-- register a function to handle incoming commands. It should then set+-- the service's status to 'START_PENDING', and specify that no controls+-- will be accepted. At this point the function may perform any other+-- initialization steps before setting the service's status to+-- 'RUNNING'. All of this should take no more than 100ms.+type ServiceMainFunction = String -> [String] -> HANDLE -> IO ()++-- |Retrieves the current status of the specified service.+queryServiceStatus :: HANDLE+ -- ^ MSDN documentation: A handle to the service. This handle is returned+ -- by the OpenService or the CreateService function, and it must have the+ -- SERVICE_QUERY_STATUS access right. For more information, see Service+ -- Security and Access Rights.+ -> IO SERVICE_STATUS+ -- ^ This function will raise an exception if the Win32 call returned an+ -- error condition.+queryServiceStatus h = alloca $ \pStatus -> do+ failIfFalse_ (unwords ["QueryServiceStatus"])+ $ c_QueryServiceStatus h pStatus+ peek pStatus++-- | Register an handler function to be called whenever the operating system+-- receives service control messages.+registerServiceCtrlHandlerEx :: String+ -- ^ The name of the service. According to MSDN documentation this+ -- argument is unused in WIN32_OWN_PROCESS type services, which is the+ -- only type supported by this binding. Even so, it is recommended+ -- that the name of the service be used.+ --+ -- MSDN description: The name of the service run by the calling thread.+ -- This is the service name that the service control program specified in+ -- the CreateService function when creating the service.+ -> HandlerFunction+ -- ^ A Handler function to be called in response to service control+ -- messages. Behind the scenes this is translated into a "HandlerEx" type+ -- handler.+ -> IO (HANDLE, LPHANDLER_FUNCTION_EX)+ -- ^ The returned handle may be used in calls to SetServiceStatus. For+ -- convenience Handler functions also receive a handle for the service.+registerServiceCtrlHandlerEx str handler =+ withTString str $ \lptstr ->+ -- use 'ret' instead of (h', _) to avoid divergence.+ mfix $ \ret -> do+ fpHandler <- handlerToFunPtr $ toHandlerEx (fst ret) handler+ h <- failIfNull (unwords ["RegisterServiceCtrlHandlerEx", str])+ $ c_RegisterServiceCtrlHandlerEx lptstr fpHandler nullPtr+ return (h, fpHandler)++-- |Updates the service control manager's status information for the calling+-- service.+setServiceStatus :: HANDLE+ -- ^ MSDN documentation: A handle to the status information structure for+ -- the current service. This handle is returned by the+ -- RegisterServiceCtrlHandlerEx function.+ -> SERVICE_STATUS+ -- ^ MSDN documentation: A pointer to the SERVICE_STATUS structure the+ -- contains the latest status information for the calling service.+ -> IO ()+ -- ^ This function will raise an exception if the Win32 call returned an+ -- error condition.+setServiceStatus h status =+ with status $ \pStatus -> do+ failIfFalse_ (unwords ["SetServiceStatus", show h, show status])+ $ c_SetServiceStatus h pStatus++-- |Register a callback function to initialize the service, which will be+-- called by the operating system immediately. startServiceCtrlDispatcher+-- will block until the provided callback function returns.+--+-- MSDN documentation: Connects the main thread of a service process to the+-- service control manager, which causes the thread to be the service control+-- dispatcher thread for the calling process.+startServiceCtrlDispatcher :: String+ -- ^ The name of the service. According to MSDN documentation this+ -- argument is unused in WIN32_OWN_PROCESS type services, which is the+ -- only type supported by this binding. Even so, it is recommended+ -- that the name of the service be used.+ --+ -- MSDN description: The name of the service run by the calling thread.+ -- This is the service name that the service control program specified in+ -- the CreateService function when creating the service.+ -> DWORD+ -> HandlerFunction+ -> ServiceMainFunction+ -- ^ This is a callback function that will be called by the operating+ -- system whenever the service is started. It should perform service+ -- initialization including the registration of a handler function.+ -- MSDN documentation gives conflicting advice as to whether this function+ -- should return before the service has entered the stopped state.+ -- In the official example the service main function blocks until the+ -- service is ready to stop.+ -> IO ()+ -- ^ An exception will be raised if the underlying Win32 call returns an+ -- error condition.+startServiceCtrlDispatcher name wh handler main =+ withTString name $ \lptstr ->+ bracket (toSMF main handler wh >>= smfToFunPtr) freeHaskellFunPtr $ \fpMain ->+ withArray [SERVICE_TABLE_ENTRY lptstr fpMain, nullSTE] $ \pSTE ->+ failIfFalse_ (unwords ["StartServiceCtrlDispatcher", name]) $ do+ c_StartServiceCtrlDispatcher pSTE++toSMF :: ServiceMainFunction -> HandlerFunction -> DWORD -> IO SERVICE_MAIN_FUNCTION+toSMF f handler wh = return $ \len pLPTSTR -> do+ lptstrx <- peekArray (fromIntegral len) pLPTSTR+ args <- mapM peekTString lptstrx+ -- MSDN guarantees args will have at least 1 member.+ let name = head args+ (h, fpHandler) <- registerServiceCtrlHandlerEx name handler+ setServiceStatus h $ SERVICE_STATUS WIN32_OWN_PROCESS START_PENDING [] nO_ERROR 0 0 wh+ f name (tail args) h+ freeHaskellFunPtr fpHandler++-- This was originally written with older style handle functions in mind.+-- I'm now using HandlerEx style functions, and need to add support for+-- the extra parameters here.+toHandlerEx :: HANDLE -> HandlerFunction -> HANDLER_FUNCTION_EX+toHandlerEx h f = \dwControl _ _ _ ->+ case SC.fromDWORD dwControl of+ Right control -> do+ handled <- f h control+ case control of+ INTERROGATE -> return nO_ERROR+ -- If we ever support extended control codes this will have to+ -- change. see "Dev Center - Desktop > Docs > Desktop app+ -- development documentation > System Services > Services >+ -- Service Reference > Service Functions > HandlerEx".+ _ -> return $ if handled then nO_ERROR+ else eRROR_CALL_NOT_IMPLEMENTED+ Left _ -> return eRROR_CALL_NOT_IMPLEMENTED
src/System/Win32/SystemServices/Services/Raw.hs view
@@ -1,33 +1,31 @@-{-# LANGUAGE ForeignFunctionInterface #-} - -module System.Win32.SystemServices.Services.Raw where - -import Foreign.Ptr (Ptr) -import System.Win32.Types - -import System.Win32.SystemServices.Services.SERVICE_STATUS -import System.Win32.SystemServices.Services.SERVICE_TABLE_ENTRY -import System.Win32.SystemServices.Services.Types - -foreign import stdcall "wrapper" - smfToFunPtr :: SERVICE_MAIN_FUNCTION -> IO LPSERVICE_MAIN_FUNCTION - -foreign import stdcall "wrapper" - handlerToFunPtr :: HANDLER_FUNCTION_EX -> IO LPHANDLER_FUNCTION_EX - --- BOOL WINAPI QueryServiceStatus( --- _In_ SC_HANDLE hService, --- _Out_ LPSERVICE_STATUS lpServiceStatus --- ); -foreign import stdcall "windows.h QueryServiceStatus" - c_QueryServiceStatus :: HANDLE -> Ptr SERVICE_STATUS -> IO BOOL - --- I've not been able to get RegisterServiceCtrlHandler to work on Windows 7 64-bit. -foreign import stdcall "windows.h RegisterServiceCtrlHandlerExW" - c_RegisterServiceCtrlHandlerEx :: LPTSTR -> LPHANDLER_FUNCTION_EX -> Ptr () -> IO HANDLE - -foreign import stdcall "windows.h SetServiceStatus" - c_SetServiceStatus :: HANDLE -> Ptr SERVICE_STATUS -> IO BOOL - -foreign import stdcall "windows.h StartServiceCtrlDispatcherW" - c_StartServiceCtrlDispatcher :: Ptr SERVICE_TABLE_ENTRY -> IO BOOL +{-# LANGUAGE ForeignFunctionInterface #-}++module System.Win32.SystemServices.Services.Raw where++import Import+import System.Win32.SystemServices.Services.SERVICE_STATUS+import System.Win32.SystemServices.Services.SERVICE_TABLE_ENTRY+import System.Win32.SystemServices.Services.Types++foreign import stdcall "wrapper"+ smfToFunPtr :: SERVICE_MAIN_FUNCTION -> IO LPSERVICE_MAIN_FUNCTION++foreign import stdcall "wrapper"+ handlerToFunPtr :: HANDLER_FUNCTION_EX -> IO LPHANDLER_FUNCTION_EX++-- BOOL WINAPI QueryServiceStatus(+-- _In_ SC_HANDLE hService,+-- _Out_ LPSERVICE_STATUS lpServiceStatus+-- );+foreign import stdcall "windows.h QueryServiceStatus"+ c_QueryServiceStatus :: HANDLE -> Ptr SERVICE_STATUS -> IO BOOL++-- I've not been able to get RegisterServiceCtrlHandler to work on Windows 7 64-bit.+foreign import stdcall "windows.h RegisterServiceCtrlHandlerExW"+ c_RegisterServiceCtrlHandlerEx :: LPTSTR -> LPHANDLER_FUNCTION_EX -> Ptr () -> IO HANDLE++foreign import stdcall "windows.h SetServiceStatus"+ c_SetServiceStatus :: HANDLE -> Ptr SERVICE_STATUS -> IO BOOL++foreign import stdcall "windows.h StartServiceCtrlDispatcherW"+ c_StartServiceCtrlDispatcher :: Ptr SERVICE_TABLE_ENTRY -> IO BOOL
src/System/Win32/SystemServices/Services/SERVICE_ACCEPT.hs view
@@ -1,92 +1,89 @@-module System.Win32.SystemServices.Services.SERVICE_ACCEPT - ( SERVICE_ACCEPT (..) - , pokeServiceAccept - , peekServiceAccept - ) where - -import Control.Applicative -import Data.Bits -import Data.Maybe -import Foreign -import System.Win32.Types (DWORD) -import Text.Printf - -import Control.Error - --- | The control codes the service accepts and processes in its handler --- function (See 'HandlerFunction'). By default, all services accept the --- 'INTERROGATE' value. To accept the 'DEVICEEVENT' value, the service must --- register to receive device events by using the --- 'registerDeviceNotification' function. -data SERVICE_ACCEPT - -- | The service is a network component that can accept changes in its - -- binding without being stopped and restarted. This control code allows - -- the service to receive 'NETBINDADD', 'NETBINDREMOVE', 'NETBINDENABLE' - -- , and 'NETBINDDISABLE' notifications. - = ACCEPT_NETBINDCHANGE - -- | The service can reread its startup parameters without being stopped - -- and restarted. This control code allows the service to receive - -- 'PARAMCHANGE' notifications. - | ACCEPT_PARAMCHANGE - -- | The service can be paused and continued. This control code allows the - -- service to receive 'PAUSE' and 'CONTINUE' notifications. - | ACCEPT_PAUSE_CONTINUE - -- | MSDN documentation says that this function is not supported on - -- Windows Server 2003 or Windows XP/2000. The support status on other - -- versions is unknown to me. - -- - -- The service can perform preshutdown tasks. This control code enables - -- the service to receive 'PRESHUTDOWN' notifications. - -- Note that only the system can send it. - | ACCEPT_PRESHUTDOWN - -- | The service is notified when system shutdown occurs. This control - -- code allows the service to receive 'SHUTDOWN' notifications. Note - -- that only the system can send it. - | ACCEPT_SHUTDOWN - -- | The service can be stopped. This control code allows the service to - -- receive 'STOP' notifications. - | ACCEPT_STOP - deriving (Show) - -peekServiceAccept :: Ptr DWORD -> IO [SERVICE_ACCEPT] -peekServiceAccept ptr = unflag <$> peek ptr - -pokeServiceAccept :: Ptr DWORD -> [SERVICE_ACCEPT] -> IO () -pokeServiceAccept ptr sas = poke ptr . flag $ sas - -toDWORD :: SERVICE_ACCEPT -> DWORD -toDWORD ACCEPT_NETBINDCHANGE = 0x00000010 -toDWORD ACCEPT_PARAMCHANGE = 0x00000008 -toDWORD ACCEPT_PAUSE_CONTINUE = 0x00000002 -toDWORD ACCEPT_PRESHUTDOWN = 0x00000100 -toDWORD ACCEPT_SHUTDOWN = 0x00000004 -toDWORD ACCEPT_STOP = 0x00000001 - -fromDWORD :: DWORD -> Either String SERVICE_ACCEPT -fromDWORD 0x00000010 = Right ACCEPT_NETBINDCHANGE -fromDWORD 0x00000008 = Right ACCEPT_PARAMCHANGE -fromDWORD 0x00000002 = Right ACCEPT_PAUSE_CONTINUE -fromDWORD 0x00000100 = Right ACCEPT_PRESHUTDOWN -fromDWORD 0x00000004 = Right ACCEPT_SHUTDOWN -fromDWORD 0x00000001 = Right ACCEPT_STOP -fromDWORD 0x00000020 = unsupported "SERVICE_ACCEPT_HARDWAREPROFILECHANGE" -fromDWORD 0x00000040 = unsupported "SERVICE_ACCEPT_POWEREVENT" -fromDWORD 0x00000080 = unsupported "SERVICE_ACCEPT_SESSIONCHANGE" -fromDWORD 0x00000200 = unsupported "SERVICE_ACCEPT_TIMECHANGE" -fromDWORD 0x00000400 = unsupported "SERVICE_ACCEPT_TRIGGEREVENT" -fromDWORD 0x00000800 = unsupported "SERVICE_ACCEPT_USERMODEREBOOT" -fromDWORD x = Left $ "The " ++ printf "%x" x ++ " control code is undocumented." - -unsupported :: String -> Either String a -unsupported name = Left $ "The " ++ name ++ " control code is unsupported by this binding." - --- | This function takes a 'DWORD' and assumes it is a flagfield. Each bit --- is masked off and converted into a value. Any failures are silently --- discarded. -unflag :: DWORD -> [SERVICE_ACCEPT] -unflag f = mapMaybe (hush . fromDWORD . (.&. f)) masks - where - masks = take 32 $ iterate (`shiftL` 1) 1 - -flag :: [SERVICE_ACCEPT] -> DWORD +module System.Win32.SystemServices.Services.SERVICE_ACCEPT+ ( SERVICE_ACCEPT (..)+ , pokeServiceAccept+ , peekServiceAccept+ ) where++import Data.Bits+import Data.Maybe+import Text.Printf++import Import++-- | The control codes the service accepts and processes in its handler+-- function (See 'HandlerFunction'). By default, all services accept the+-- 'INTERROGATE' value. To accept the 'DEVICEEVENT' value, the service must+-- register to receive device events by using the+-- 'registerDeviceNotification' function.+data SERVICE_ACCEPT+ -- | The service is a network component that can accept changes in its+ -- binding without being stopped and restarted. This control code allows+ -- the service to receive 'NETBINDADD', 'NETBINDREMOVE', 'NETBINDENABLE'+ -- , and 'NETBINDDISABLE' notifications.+ = ACCEPT_NETBINDCHANGE+ -- | The service can reread its startup parameters without being stopped+ -- and restarted. This control code allows the service to receive+ -- 'PARAMCHANGE' notifications.+ | ACCEPT_PARAMCHANGE+ -- | The service can be paused and continued. This control code allows the+ -- service to receive 'PAUSE' and 'CONTINUE' notifications.+ | ACCEPT_PAUSE_CONTINUE+ -- | MSDN documentation says that this function is not supported on+ -- Windows Server 2003 or Windows XP/2000. The support status on other+ -- versions is unknown to me.+ --+ -- The service can perform preshutdown tasks. This control code enables+ -- the service to receive 'PRESHUTDOWN' notifications.+ -- Note that only the system can send it.+ | ACCEPT_PRESHUTDOWN+ -- | The service is notified when system shutdown occurs. This control+ -- code allows the service to receive 'SHUTDOWN' notifications. Note+ -- that only the system can send it.+ | ACCEPT_SHUTDOWN+ -- | The service can be stopped. This control code allows the service to+ -- receive 'STOP' notifications.+ | ACCEPT_STOP+ deriving (Show)++peekServiceAccept :: Ptr DWORD -> IO [SERVICE_ACCEPT]+peekServiceAccept ptr = unflag <$> peek ptr++pokeServiceAccept :: Ptr DWORD -> [SERVICE_ACCEPT] -> IO ()+pokeServiceAccept ptr sas = poke ptr . flag $ sas++toDWORD :: SERVICE_ACCEPT -> DWORD+toDWORD ACCEPT_NETBINDCHANGE = 0x00000010+toDWORD ACCEPT_PARAMCHANGE = 0x00000008+toDWORD ACCEPT_PAUSE_CONTINUE = 0x00000002+toDWORD ACCEPT_PRESHUTDOWN = 0x00000100+toDWORD ACCEPT_SHUTDOWN = 0x00000004+toDWORD ACCEPT_STOP = 0x00000001++fromDWORD :: DWORD -> Either String SERVICE_ACCEPT+fromDWORD 0x00000010 = Right ACCEPT_NETBINDCHANGE+fromDWORD 0x00000008 = Right ACCEPT_PARAMCHANGE+fromDWORD 0x00000002 = Right ACCEPT_PAUSE_CONTINUE+fromDWORD 0x00000100 = Right ACCEPT_PRESHUTDOWN+fromDWORD 0x00000004 = Right ACCEPT_SHUTDOWN+fromDWORD 0x00000001 = Right ACCEPT_STOP+fromDWORD 0x00000020 = unsupported "SERVICE_ACCEPT_HARDWAREPROFILECHANGE"+fromDWORD 0x00000040 = unsupported "SERVICE_ACCEPT_POWEREVENT"+fromDWORD 0x00000080 = unsupported "SERVICE_ACCEPT_SESSIONCHANGE"+fromDWORD 0x00000200 = unsupported "SERVICE_ACCEPT_TIMECHANGE"+fromDWORD 0x00000400 = unsupported "SERVICE_ACCEPT_TRIGGEREVENT"+fromDWORD 0x00000800 = unsupported "SERVICE_ACCEPT_USERMODEREBOOT"+fromDWORD x = Left $ "The " ++ printf "%x" x ++ " control code is undocumented."++unsupported :: String -> Either String a+unsupported name = Left $ "The " ++ name ++ " control code is unsupported by this binding."++-- | This function takes a 'DWORD' and assumes it is a flagfield. Each bit+-- is masked off and converted into a value. Any failures are silently+-- discarded.+unflag :: DWORD -> [SERVICE_ACCEPT]+unflag f = mapMaybe (hush . fromDWORD . (.&. f)) masks+ where+ masks = take 32 $ iterate (`shiftL` 1) 1++flag :: [SERVICE_ACCEPT] -> DWORD flag fs = foldl (\flag' f -> flag' .|. toDWORD f) 0 fs
src/System/Win32/SystemServices/Services/SERVICE_CONTROL.hs view
@@ -1,68 +1,64 @@-module System.Win32.SystemServices.Services.SERVICE_CONTROL - ( SERVICE_CONTROL (..) - , peekServiceControl - , pokeServiceControl - , fromDWORD - ) where - -import Foreign -import System.Win32.Types (DWORD) -import Text.Printf - -import Control.Error - --- | A SERVICE_CONTROL is used in Handler functions. All control codes are --- defined here, but some can only be used with a 'HandlerEx' callback. --- Use 'convertSuccess' to translate from a 'SERVICE_CONTROL' to a 'DWORD'. --- Use 'convertAttempt' to translate from a 'DWORD' to a 'SERVICE_CONTROL'. -data SERVICE_CONTROL = CONTINUE | INTERROGATE | NETBINDADD | NETBINDDISABLE - | NETBINDENABLE | NETBINDREMOVE | PARAMCHANGE | PAUSE - | PRESHUTDOWN | SHUTDOWN | STOP - deriving (Show) - -peekServiceControl :: Ptr DWORD -> IO SERVICE_CONTROL -peekServiceControl ptr = runScript $ do - dword <- scriptIO $ peek ptr - hoistEither $ fromDWORD dword - -pokeServiceControl :: Ptr DWORD -> SERVICE_CONTROL -> IO () -pokeServiceControl ptr sc = poke ptr . toDWORD $ sc - -toDWORD :: SERVICE_CONTROL -> DWORD -toDWORD CONTINUE = 0x00000003 -toDWORD INTERROGATE = 0x00000004 -toDWORD NETBINDADD = 0x00000007 -toDWORD NETBINDDISABLE = 0x0000000A -toDWORD NETBINDENABLE = 0x00000009 -toDWORD NETBINDREMOVE = 0x00000008 -toDWORD PARAMCHANGE = 0x00000006 -toDWORD PAUSE = 0x00000002 -toDWORD PRESHUTDOWN = 0x0000000F -toDWORD SHUTDOWN = 0x00000005 -toDWORD STOP = 0x00000001 - -fromDWORD :: DWORD -> Either String SERVICE_CONTROL -fromDWORD 0x00000003 = Right CONTINUE -fromDWORD 0x00000004 = Right INTERROGATE -fromDWORD 0x00000007 = Right NETBINDADD -fromDWORD 0x0000000A = Right NETBINDDISABLE -fromDWORD 0x00000009 = Right NETBINDENABLE -fromDWORD 0x00000008 = Right NETBINDREMOVE -fromDWORD 0x00000006 = Right PARAMCHANGE -fromDWORD 0x00000002 = Right PAUSE -fromDWORD 0x0000000F = Right PRESHUTDOWN -fromDWORD 0x00000005 = Right SHUTDOWN -fromDWORD 0x00000001 = Right STOP -fromDWORD 0x0000000B = unsupported "SERVICE_CONTROL_DEVICEEVENT" -fromDWORD 0x0000000C = unsupported "SERVICE_CONTROL_HARDWAREPROFILECHANGE" -fromDWORD 0x0000000D = unsupported "SERVICE_CONTROL_POWEREVENT" -fromDWORD 0x0000000E = unsupported "SERVICE_CONTROL_SESSIONCHANGE" -fromDWORD 0x00000010 = unsupported "SERVICE_CONTROL_TIMECHANGE" -fromDWORD 0x00000020 = unsupported "SERVICE_CONTROL_TRIGGEREVENT" -fromDWORD 0x00000040 = unsupported "SERVICE_CONTROL_USERMODEREBOOT" -fromDWORD x - | x >= 128 && x <= 255 = Left "user defined control codes are unsupported by this binding." - | otherwise = Left $ "The " ++ printf "%x" x ++ " control code is undocumented." - -unsupported :: String -> Either String a -unsupported name = Left $ "The " ++ name ++ " control code is unsupported by this binding." +module System.Win32.SystemServices.Services.SERVICE_CONTROL+ ( SERVICE_CONTROL (..)+ , peekServiceControl+ , pokeServiceControl+ , fromDWORD+ ) where++import Text.Printf++import Import++-- | A SERVICE_CONTROL is used in Handler functions. All control codes are+-- defined here, but some can only be used with a 'HandlerEx' callback.+-- Use 'convertSuccess' to translate from a 'SERVICE_CONTROL' to a 'DWORD'.+-- Use 'convertAttempt' to translate from a 'DWORD' to a 'SERVICE_CONTROL'.+data SERVICE_CONTROL = CONTINUE | INTERROGATE | NETBINDADD | NETBINDDISABLE+ | NETBINDENABLE | NETBINDREMOVE | PARAMCHANGE | PAUSE+ | PRESHUTDOWN | SHUTDOWN | STOP+ deriving (Show)++peekServiceControl :: Ptr DWORD -> IO (Either String SERVICE_CONTROL)+peekServiceControl ptr = fromDWORD <$> peek ptr++pokeServiceControl :: Ptr DWORD -> SERVICE_CONTROL -> IO ()+pokeServiceControl ptr sc = poke ptr . toDWORD $ sc++toDWORD :: SERVICE_CONTROL -> DWORD+toDWORD CONTINUE = 0x00000003+toDWORD INTERROGATE = 0x00000004+toDWORD NETBINDADD = 0x00000007+toDWORD NETBINDDISABLE = 0x0000000A+toDWORD NETBINDENABLE = 0x00000009+toDWORD NETBINDREMOVE = 0x00000008+toDWORD PARAMCHANGE = 0x00000006+toDWORD PAUSE = 0x00000002+toDWORD PRESHUTDOWN = 0x0000000F+toDWORD SHUTDOWN = 0x00000005+toDWORD STOP = 0x00000001++fromDWORD :: DWORD -> Either String SERVICE_CONTROL+fromDWORD 0x00000003 = Right CONTINUE+fromDWORD 0x00000004 = Right INTERROGATE+fromDWORD 0x00000007 = Right NETBINDADD+fromDWORD 0x0000000A = Right NETBINDDISABLE+fromDWORD 0x00000009 = Right NETBINDENABLE+fromDWORD 0x00000008 = Right NETBINDREMOVE+fromDWORD 0x00000006 = Right PARAMCHANGE+fromDWORD 0x00000002 = Right PAUSE+fromDWORD 0x0000000F = Right PRESHUTDOWN+fromDWORD 0x00000005 = Right SHUTDOWN+fromDWORD 0x00000001 = Right STOP+fromDWORD 0x0000000B = unsupported "SERVICE_CONTROL_DEVICEEVENT"+fromDWORD 0x0000000C = unsupported "SERVICE_CONTROL_HARDWAREPROFILECHANGE"+fromDWORD 0x0000000D = unsupported "SERVICE_CONTROL_POWEREVENT"+fromDWORD 0x0000000E = unsupported "SERVICE_CONTROL_SESSIONCHANGE"+fromDWORD 0x00000010 = unsupported "SERVICE_CONTROL_TIMECHANGE"+fromDWORD 0x00000020 = unsupported "SERVICE_CONTROL_TRIGGEREVENT"+fromDWORD 0x00000040 = unsupported "SERVICE_CONTROL_USERMODEREBOOT"+fromDWORD x+ | x >= 128 && x <= 255 = Left "user defined control codes are unsupported by this binding."+ | otherwise = Left $ "The " ++ printf "%x" x ++ " control code is undocumented."++unsupported :: String -> Either String a+unsupported name = Left $ "The " ++ name ++ " control code is unsupported by this binding."
src/System/Win32/SystemServices/Services/SERVICE_STATE.hs view
@@ -1,56 +1,52 @@-module System.Win32.SystemServices.Services.SERVICE_STATE - ( SERVICE_STATE (..) - , nO_ERROR - , eRROR_CALL_NOT_IMPLEMENTED - , eRROR_SERVICE_SPECIFIC_ERROR - , peekServiceState - , pokeServiceState - ) where - -import Foreign -import System.Win32.Types -import Text.Printf - -import Control.Error - -nO_ERROR :: ErrCode -nO_ERROR = 0 - -eRROR_CALL_NOT_IMPLEMENTED :: ErrCode -eRROR_CALL_NOT_IMPLEMENTED = 0x78 - -eRROR_SERVICE_SPECIFIC_ERROR :: ErrCode -eRROR_SERVICE_SPECIFIC_ERROR = 0x42a - --- | The current state of a service. -data SERVICE_STATE = CONTINUE_PENDING | PAUSE_PENDING | PAUSED | RUNNING - | START_PENDING | STOP_PENDING | STOPPED - deriving (Eq, Show) - -fromDWORD :: DWORD -> Either String SERVICE_STATE -fromDWORD 5 = Right CONTINUE_PENDING -fromDWORD 6 = Right PAUSE_PENDING -fromDWORD 7 = Right PAUSED -fromDWORD 4 = Right RUNNING -fromDWORD 2 = Right START_PENDING -fromDWORD 3 = Right STOP_PENDING -fromDWORD 1 = Right STOPPED -fromDWORD x = Left $ "Unable to interpret " ++ printf "%x" x - ++ " as a SERVICE_STATE." - -toDWORD :: SERVICE_STATE -> DWORD -toDWORD STOPPED = 0x00000001 -toDWORD START_PENDING = 0x00000002 -toDWORD STOP_PENDING = 0x00000003 -toDWORD RUNNING = 0x00000004 -toDWORD CONTINUE_PENDING = 0x00000005 -toDWORD PAUSE_PENDING = 0x00000006 -toDWORD PAUSED = 0x00000007 - -peekServiceState :: Ptr DWORD -> Script SERVICE_STATE -peekServiceState ptr = do - dword <- scriptIO $ peek ptr - hoistEither $ fromDWORD dword - -pokeServiceState :: Ptr DWORD -> SERVICE_STATE -> IO () -pokeServiceState ptr sc = poke ptr . toDWORD $ sc +module System.Win32.SystemServices.Services.SERVICE_STATE+ ( SERVICE_STATE (..)+ , nO_ERROR+ , eRROR_CALL_NOT_IMPLEMENTED+ , eRROR_SERVICE_SPECIFIC_ERROR+ , peekServiceState+ , pokeServiceState+ ) where++import Text.Printf++import Import++nO_ERROR :: ErrCode+nO_ERROR = 0++eRROR_CALL_NOT_IMPLEMENTED :: ErrCode+eRROR_CALL_NOT_IMPLEMENTED = 0x78++eRROR_SERVICE_SPECIFIC_ERROR :: ErrCode+eRROR_SERVICE_SPECIFIC_ERROR = 0x42a++-- | The current state of a service.+data SERVICE_STATE = CONTINUE_PENDING | PAUSE_PENDING | PAUSED | RUNNING+ | START_PENDING | STOP_PENDING | STOPPED+ deriving (Eq, Show)++fromDWORD :: DWORD -> Either String SERVICE_STATE+fromDWORD 5 = Right CONTINUE_PENDING+fromDWORD 6 = Right PAUSE_PENDING+fromDWORD 7 = Right PAUSED+fromDWORD 4 = Right RUNNING+fromDWORD 2 = Right START_PENDING+fromDWORD 3 = Right STOP_PENDING+fromDWORD 1 = Right STOPPED+fromDWORD x = Left $ "Unable to interpret " ++ printf "%x" x+ ++ " as a SERVICE_STATE."++toDWORD :: SERVICE_STATE -> DWORD+toDWORD STOPPED = 0x00000001+toDWORD START_PENDING = 0x00000002+toDWORD STOP_PENDING = 0x00000003+toDWORD RUNNING = 0x00000004+toDWORD CONTINUE_PENDING = 0x00000005+toDWORD PAUSE_PENDING = 0x00000006+toDWORD PAUSED = 0x00000007++peekServiceState :: Ptr DWORD -> IO (Either String SERVICE_STATE)+peekServiceState ptr = fromDWORD <$> peek ptr++pokeServiceState :: Ptr DWORD -> SERVICE_STATE -> IO ()+pokeServiceState ptr sc = poke ptr . toDWORD $ sc
src/System/Win32/SystemServices/Services/SERVICE_STATUS.hs view
@@ -1,83 +1,103 @@-module System.Win32.SystemServices.Services.SERVICE_STATUS where - -import Control.Applicative -import Foreign -import System.Win32.Types - -import Control.Error - -import System.Win32.SystemServices.Services.SERVICE_ACCEPT -import System.Win32.SystemServices.Services.SERVICE_STATE -import System.Win32.SystemServices.Services.SERVICE_TYPE - --- | Contains status information for a service. -data SERVICE_STATUS = SERVICE_STATUS - { serviceType :: SERVICE_TYPE - -- ^ The type of service. This binding only supports the WIN32_OWN_PROCESS - -- type. - , currentState :: SERVICE_STATE - -- ^ The current state of the service. - , controlsAccepted :: [SERVICE_ACCEPT] - -- ^ See 'SERVICE_ACCEPT' for details on this field. - , win32ExitCode :: DWORD - -- ^ The error code the service uses to report an error that occurs when - -- it is starting or stopping. To return an error code specific to the - -- service, the service must set this value to - -- 'eRROR_SERVICE_SPECIFIC_ERROR' to indicate that the - -- 'serviceSpecificExitCode' member contains the error code. The service - -- should set this value to 'nO_ERROR' when it is running and on normal - -- termination. - , serviceSpecificExitCode :: DWORD - -- ^ A service-specific error code that the service returns when an error - -- occurs while the service is starting or stopping. This value is - -- ignored unless the 'win32ExitCode' member is set to - -- 'eRROR_SERVICE_SPECIFIC_ERROR'. - -- - -- This binding does not support service-specific error codes. - , checkPoint :: DWORD - -- ^ The check-point value the service increments periodically to report - -- its progress during a lengthy start, stop, pause, or continue - -- operation. For example, the service should increment this value as it - -- completes each step of its initialization when it is starting up. The - -- user interface program that invoked the operation on the service uses - -- this value to track the progress of the service during a lengthy - -- operation. This value is not valid and should be zero when the - -- service does not have a start, stop, pause, or continue operation - -- pending. - , waitHint :: DWORD - -- ^ The estimated time required for a pending start, stop, pause, or - -- continue operation, in milliseconds. Before the specified amount of - -- time has elapsed, the service should make its next call to the - -- SetServiceStatus function with either an incremented dwCheckPoint - -- value or a change in 'currentState'. If the amount of time specified - -- by 'waitHint' passes, and 'checkPoint' has not been incremented or - -- 'currentState' has not changed, the service control manager or - -- service control program can assume that an error has occurred and the - -- service should be stopped. However, if the service shares a process - -- with other services, the service control manager cannot terminate the - -- service application because it would have to terminate the other - -- services sharing the process as well. - } deriving (Show) - -instance Storable SERVICE_STATUS where - sizeOf _ = 28 - alignment _ = 4 - peek ptr = SERVICE_STATUS <$> (runScript . peekServiceType) pST - <*> (runScript . peekServiceState) pCS <*> peekServiceAccept pCA - <*> peek pEC <*> peek pSSEC <*> peek pCP <*> peek pWH - where - pST = castPtr ptr - pCS = castPtr ptr `plusPtr` 4 - pCA = castPtr ptr `plusPtr` 8 - pEC = castPtr ptr `plusPtr` 12 - pSSEC = castPtr ptr `plusPtr` 16 - pCP = castPtr ptr `plusPtr` 20 - pWH = castPtr ptr `plusPtr` 24 - poke ptr (SERVICE_STATUS st cs ca ec ssec cp wh) = do - pokeServiceType (castPtr ptr) st - pokeServiceState (castPtr ptr `plusPtr` 4) cs - pokeServiceAccept (castPtr ptr `plusPtr` 8) ca - poke (castPtr ptr `plusPtr` 12) ec - poke (castPtr ptr `plusPtr` 16) ssec - poke (castPtr ptr `plusPtr` 20) cp - poke (castPtr ptr `plusPtr` 24) wh +module System.Win32.SystemServices.Services.SERVICE_STATUS where++-- These two imports are here to preserve existing behavior now that+-- the dependency on "errors" has been dropped.+import System.Exit+import System.IO++import Import+import System.Win32.SystemServices.Services.SERVICE_ACCEPT+import System.Win32.SystemServices.Services.SERVICE_STATE+import System.Win32.SystemServices.Services.SERVICE_TYPE++-- | Contains status information for a service.+data SERVICE_STATUS = SERVICE_STATUS+ { serviceType :: SERVICE_TYPE+ -- ^ The type of service. This binding only supports the WIN32_OWN_PROCESS+ -- type.+ , currentState :: SERVICE_STATE+ -- ^ The current state of the service.+ , controlsAccepted :: [SERVICE_ACCEPT]+ -- ^ See 'SERVICE_ACCEPT' for details on this field.+ , win32ExitCode :: DWORD+ -- ^ The error code the service uses to report an error that occurs when+ -- it is starting or stopping. To return an error code specific to the+ -- service, the service must set this value to+ -- 'eRROR_SERVICE_SPECIFIC_ERROR' to indicate that the+ -- 'serviceSpecificExitCode' member contains the error code. The service+ -- should set this value to 'nO_ERROR' when it is running and on normal+ -- termination.+ , serviceSpecificExitCode :: DWORD+ -- ^ A service-specific error code that the service returns when an error+ -- occurs while the service is starting or stopping. This value is+ -- ignored unless the 'win32ExitCode' member is set to+ -- 'eRROR_SERVICE_SPECIFIC_ERROR'.+ --+ -- This binding does not support service-specific error codes.+ , checkPoint :: DWORD+ -- ^ The check-point value the service increments periodically to report+ -- its progress during a lengthy start, stop, pause, or continue+ -- operation. For example, the service should increment this value as it+ -- completes each step of its initialization when it is starting up. The+ -- user interface program that invoked the operation on the service uses+ -- this value to track the progress of the service during a lengthy+ -- operation. This value is not valid and should be zero when the+ -- service does not have a start, stop, pause, or continue operation+ -- pending.+ , waitHint :: DWORD+ -- ^ The estimated time required for a pending start, stop, pause, or+ -- continue operation, in milliseconds. Before the specified amount of+ -- time has elapsed, the service should make its next call to the+ -- SetServiceStatus function with either an incremented dwCheckPoint+ -- value or a change in 'currentState'. If the amount of time specified+ -- by 'waitHint' passes, and 'checkPoint' has not been incremented or+ -- 'currentState' has not changed, the service control manager or+ -- service control program can assume that an error has occurred and the+ -- service should be stopped. However, if the service shares a process+ -- with other services, the service control manager cannot terminate the+ -- service application because it would have to terminate the other+ -- services sharing the process as well.+ } deriving (Show)++instance Storable SERVICE_STATUS where+ sizeOf _ = 28+ alignment _ = 4+ peek ptr = do+ -- This block is not ideal. It is here to preserve backwards+ -- compatibility with former behavior, and will be replaced in a future+ -- version. We used to wrap peekServiceType and peekServiceState in+ -- calls to runScript from the "errors" package. This results in a+ -- line being printed to stderr and process termination on a left value.+ -- Service applications do not have stderr.+ est <- peekServiceType (pST ptr)+ eca <- peekServiceState (pCS ptr)+ case (,) <$> est <*> eca of+ Left e -> do+ -- runScript would call this on error.+ hPutStrLn stderr e+ exitFailure+ Right (st, ca) -> SERVICE_STATUS st ca+ <$> (peekServiceAccept . pCA) ptr+ <*> (peek . pEC) ptr+ <*> (peek . pSSEC) ptr+ <*> (peek . pCP) ptr+ <*> (peek . pWH) ptr+ poke ptr (SERVICE_STATUS st cs ca ec ssec cp wh) = do+ pokeServiceType (pST ptr) st+ pokeServiceState (pCS ptr) cs+ pokeServiceAccept (pCA ptr) ca+ poke (pEC ptr) ec+ poke (pSSEC ptr) ssec+ poke (pCP ptr) cp+ poke (pWH ptr) wh++pST, pCS, pCA, pEC, pSSEC, pCP, pWH+ :: Ptr SERVICE_STATUS -> Ptr DWORD++pST = castPtr+pCS = (`plusPtr` 4) . castPtr+pCA = (`plusPtr` 8) . castPtr+pEC = (`plusPtr` 12) . castPtr+pSSEC = (`plusPtr` 16) . castPtr+pCP = (`plusPtr` 20) . castPtr+pWH = (`plusPtr` 24) . castPtr
src/System/Win32/SystemServices/Services/SERVICE_TABLE_ENTRY.hs view
@@ -1,29 +1,26 @@-module System.Win32.SystemServices.Services.SERVICE_TABLE_ENTRY where - -import Control.Applicative -import Foreign -import System.Win32.Types - -import System.Win32.SystemServices.Services.Types - -data SERVICE_TABLE_ENTRY = SERVICE_TABLE_ENTRY - { serviceName :: LPWSTR - , serviceProc :: FunPtr SERVICE_MAIN_FUNCTION - } - -instance Storable SERVICE_TABLE_ENTRY where - sizeOf _ = 8 - alignment _ = 4 - peek ptr = SERVICE_TABLE_ENTRY <$> peek pServiceName <*> peek pServiceProc - where - pServiceName = castPtr ptr - pServiceProc = castPtr ptr `plusPtr` 4 - poke ptr ste = do - poke pServiceName . serviceName $ ste - poke pServiceProc . serviceProc $ ste - where - pServiceName = castPtr ptr - pServiceProc = castPtr ptr `plusPtr` 4 - -nullSTE :: SERVICE_TABLE_ENTRY -nullSTE = SERVICE_TABLE_ENTRY nullPtr nullFunPtr +module System.Win32.SystemServices.Services.SERVICE_TABLE_ENTRY where++import Import+import System.Win32.SystemServices.Services.Types++data SERVICE_TABLE_ENTRY = SERVICE_TABLE_ENTRY+ { serviceName :: LPWSTR+ , serviceProc :: FunPtr SERVICE_MAIN_FUNCTION+ }++instance Storable SERVICE_TABLE_ENTRY where+ sizeOf _ = 8+ alignment _ = 4+ peek ptr = SERVICE_TABLE_ENTRY <$> peek pServiceName <*> peek pServiceProc+ where+ pServiceName = castPtr ptr+ pServiceProc = castPtr ptr `plusPtr` 4+ poke ptr ste = do+ poke pServiceName . serviceName $ ste+ poke pServiceProc . serviceProc $ ste+ where+ pServiceName = castPtr ptr+ pServiceProc = castPtr ptr `plusPtr` 4++nullSTE :: SERVICE_TABLE_ENTRY+nullSTE = SERVICE_TABLE_ENTRY nullPtr nullFunPtr
src/System/Win32/SystemServices/Services/SERVICE_TYPE.hs view
@@ -1,55 +1,50 @@-module System.Win32.SystemServices.Services.SERVICE_TYPE - ( SERVICE_TYPE (..) - , peekServiceType - , pokeServiceType - ) where - -import Foreign -import System.Win32.Types (DWORD) -import Text.Printf - -import Control.Error - - --- | Win32 defines many types of services, but this binding only supports --- WIN32_OWN_PROCESS. -data SERVICE_TYPE - -- | The service is a file system driver. - = FILE_SYSTEM_DRIVER - -- | The service is a device driver. - | KERNEL_DRIVER - -- | The service runs in its own process. - | WIN32_OWN_PROCESS - -- | The service shares a process with other services. - | WIN32_SHARE_PROCESS - -- | Do no write your own services of this type. Windows Vista and above - -- prevent service processes from directly interacting with users. - -- - -- A 'SERVICE_INTERACTIVE_PROCESS' is either a 'WIN32_OWN_PROCESS' or a - -- 'WIN32_SHARE_PROCESS' running in the context of the LocalSystem - -- account which is allowed to directly interact with users. - | SERVICE_INTERACTIVE_PROCESS - deriving (Show) - -toDWORD :: SERVICE_TYPE -> DWORD -toDWORD FILE_SYSTEM_DRIVER = 0x00000002 -toDWORD KERNEL_DRIVER = 0x00000001 -toDWORD WIN32_OWN_PROCESS = 0x00000010 -toDWORD WIN32_SHARE_PROCESS = 0x00000020 -toDWORD SERVICE_INTERACTIVE_PROCESS = 0x00000100 - -fromDWORD :: DWORD -> Either String SERVICE_TYPE -fromDWORD 0x00000002 = Right FILE_SYSTEM_DRIVER -fromDWORD 0x00000001 = Right KERNEL_DRIVER -fromDWORD 0x00000010 = Right WIN32_OWN_PROCESS -fromDWORD 0x00000020 = Right WIN32_SHARE_PROCESS -fromDWORD 0x00000100 = Right SERVICE_INTERACTIVE_PROCESS -fromDWORD x = Left $ "Invalid SERVICE_TYPE: " ++ printf "%x" x - -peekServiceType :: Ptr DWORD -> Script SERVICE_TYPE -peekServiceType ptr = do - dword <- scriptIO $ peek ptr - hoistEither $ fromDWORD dword - -pokeServiceType :: Ptr DWORD -> SERVICE_TYPE -> IO () -pokeServiceType ptr x = poke ptr . toDWORD $ x +module System.Win32.SystemServices.Services.SERVICE_TYPE+ ( SERVICE_TYPE (..)+ , peekServiceType+ , pokeServiceType+ ) where++import Text.Printf++import Import++-- | Win32 defines many types of services, but this binding only supports+-- WIN32_OWN_PROCESS.+data SERVICE_TYPE+ -- | The service is a file system driver.+ = FILE_SYSTEM_DRIVER+ -- | The service is a device driver.+ | KERNEL_DRIVER+ -- | The service runs in its own process.+ | WIN32_OWN_PROCESS+ -- | The service shares a process with other services.+ | WIN32_SHARE_PROCESS+ -- | Do no write your own services of this type. Windows Vista and above+ -- prevent service processes from directly interacting with users.+ --+ -- A 'SERVICE_INTERACTIVE_PROCESS' is either a 'WIN32_OWN_PROCESS' or a+ -- 'WIN32_SHARE_PROCESS' running in the context of the LocalSystem+ -- account which is allowed to directly interact with users.+ | SERVICE_INTERACTIVE_PROCESS+ deriving (Show)++toDWORD :: SERVICE_TYPE -> DWORD+toDWORD FILE_SYSTEM_DRIVER = 0x00000002+toDWORD KERNEL_DRIVER = 0x00000001+toDWORD WIN32_OWN_PROCESS = 0x00000010+toDWORD WIN32_SHARE_PROCESS = 0x00000020+toDWORD SERVICE_INTERACTIVE_PROCESS = 0x00000100++fromDWORD :: DWORD -> Either String SERVICE_TYPE+fromDWORD 0x00000002 = Right FILE_SYSTEM_DRIVER+fromDWORD 0x00000001 = Right KERNEL_DRIVER+fromDWORD 0x00000010 = Right WIN32_OWN_PROCESS+fromDWORD 0x00000020 = Right WIN32_SHARE_PROCESS+fromDWORD 0x00000100 = Right SERVICE_INTERACTIVE_PROCESS+fromDWORD x = Left $ "Invalid SERVICE_TYPE: " ++ printf "%x" x++peekServiceType :: Ptr DWORD -> IO (Either String SERVICE_TYPE)+peekServiceType ptr = fromDWORD <$> peek ptr++pokeServiceType :: Ptr DWORD -> SERVICE_TYPE -> IO ()+pokeServiceType ptr x = poke ptr . toDWORD $ x
src/System/Win32/SystemServices/Services/Types.hs view
@@ -1,10 +1,9 @@-module System.Win32.SystemServices.Services.Types where - -import Foreign.Ptr (FunPtr, Ptr) -import System.Win32.Types - -type HANDLER_FUNCTION_EX = DWORD -> DWORD -> Ptr () -> Ptr () -> IO DWORD -type LPHANDLER_FUNCTION_EX = FunPtr HANDLER_FUNCTION_EX - -type SERVICE_MAIN_FUNCTION = DWORD -> Ptr LPTSTR -> IO () -type LPSERVICE_MAIN_FUNCTION = FunPtr SERVICE_MAIN_FUNCTION +module System.Win32.SystemServices.Services.Types where++import Import++type HANDLER_FUNCTION_EX = DWORD -> DWORD -> Ptr () -> Ptr () -> IO DWORD+type LPHANDLER_FUNCTION_EX = FunPtr HANDLER_FUNCTION_EX++type SERVICE_MAIN_FUNCTION = DWORD -> Ptr LPTSTR -> IO ()+type LPSERVICE_MAIN_FUNCTION = FunPtr SERVICE_MAIN_FUNCTION