Win32-services 0.2.1 → 0.2.2
raw patch · 9 files changed
+750/−746 lines, 9 filesdep ~base
Dependency ranges changed: base
Files
- Win32-services.cabal +156/−152
- examples/official.hs +49/−49
- examples/simple.hs +22/−22
- src/System/Win32/SystemServices/Services.hs +170/−170
- src/System/Win32/SystemServices/Services/SERVICE_ACCEPT.hs +91/−91
- src/System/Win32/SystemServices/Services/SERVICE_CONTROL.hs +68/−68
- src/System/Win32/SystemServices/Services/SERVICE_STATE.hs +56/−56
- src/System/Win32/SystemServices/Services/SERVICE_STATUS.hs +83/−83
- src/System/Win32/SystemServices/Services/SERVICE_TYPE.hs +55/−55
Win32-services.cabal view
@@ -1,152 +1,156 @@-name: Win32-services -category: System -version: 0.2.1 -cabal-version: >= 1.14 -build-type: Simple -author: Michael Steele -maintainer: Michael Steele <mikesteele81@gmail.com> -copyright: Copyright (C) 2011-2013 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.4.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\" - @ - . - Release Notes: - . - Changes in 0.2.1 - . - * bug fix: Services were failing to enter a STOPPED state. It is now the - user's responsibility to enter a stopped state in the service main function. - The 'startServiceCtrlDispatcher' function will continue to automatically put - the service into a START_PENDING state. - . - Changes in 0.2 - . - * Writing services of the WIN32_OWN_PROCESS type is now easier. Handler - registration is performed automatically. By the time the service main - function is entered, the service will already be in the 'START_PENDING' - state. It is the user's responsibility to enter the 'RUNNING' state as soon - as possible. - . - * Once the service main function exits two things will occur. The service - will enter the 'STOPPED' state, and the handler function will be freed. - . - * The 'registerServiceCtrlHandlerEx' function is no longer - exported. Handlers are registered automatically by the - 'startServiceCtrlDispatcher' function. - . - * The 'queryServiceStatus' function has been added. - . - Changes in 0.1 - . - * First release -extra-source-files: examples/*.hs - -source-repository head - type: git - location: git://github.com/mikesteele81/win32-services.git - -library - build-depends: base >= 4.5 && < 4.6 - , errors - , Win32 - default-language: Haskell2010 - ghc-options: -Wall - hs-source-dirs: src - Exposed-Modules: System.Win32.SystemServices.Services - Extra-Libraries: Advapi32 - 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.2+cabal-version: >= 1.14+build-type: Simple+author: Michael Steele+maintainer: Michael Steele <mikesteele81@gmail.com>+copyright: Copyright (C) 2011-2013 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+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\"+ @+ .+ Release Notes:+ .+ Changes in 0.2.2+ .+ * Update library dependencies to support GHC 7.8.+ .+ Changes in 0.2.1+ .+ * bug fix: Services were failing to enter a STOPPED state. It is now the+ user's responsibility to enter a stopped state in the service main function.+ The 'startServiceCtrlDispatcher' function will continue to automatically put+ the service into a START_PENDING state.+ .+ Changes in 0.2+ .+ * Writing services of the WIN32_OWN_PROCESS type is now easier. Handler+ registration is performed automatically. By the time the service main+ function is entered, the service will already be in the 'START_PENDING'+ state. It is the user's responsibility to enter the 'RUNNING' state as soon+ as possible.+ .+ * Once the service main function exits two things will occur. The service+ will enter the 'STOPPED' state, and the handler function will be freed.+ .+ * The 'registerServiceCtrlHandlerEx' function is no longer+ exported. Handlers are registered automatically by the+ 'startServiceCtrlDispatcher' function.+ .+ * The 'queryServiceStatus' function has been added.+ .+ Changes in 0.1+ .+ * First release+extra-source-files: examples/*.hs++source-repository head+ type: git+ location: git://github.com/mikesteele81/win32-services.git++library+ build-depends: base >= 4.5 && < 4.7+ , errors+ , Win32+ default-language: Haskell2010+ ghc-options: -Wall+ hs-source-dirs: src+ Exposed-Modules: System.Win32.SystemServices.Services+ Extra-Libraries: Advapi32+ 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
examples/official.hs view
@@ -1,49 +1,49 @@-module Main where - -import Control.Concurrent.MVar -import System.Win32.SystemServices.Services -import System.Win32.Types - -main :: IO () -main = do - gState <- newMVar (1, SERVICE_STATUS WIN32_OWN_PROCESS - START_PENDING [] nO_ERROR 0 0 3000) - mStop <- newEmptyMVar - startServiceCtrlDispatcher "Test" 3000 (svcCtrlHandler mStop gState) $ svcMain mStop gState - -svcMain mStop gState _ _ h = do - reportSvcStatus h RUNNING nO_ERROR 0 gState - takeMVar mStop - reportSvcStatus h STOPPED nO_ERROR 0 gState - -reportSvcStatus :: HANDLE -> SERVICE_STATE -> DWORD -> DWORD - -> MVar (DWORD, SERVICE_STATUS) -> IO () -reportSvcStatus hStatus state win32ExitCode waitHint mState = do - modifyMVar_ mState $ \(checkPoint, svcStatus) -> do - let state' = nextState (checkPoint, svcStatus - { win32ExitCode = win32ExitCode - , waitHint = waitHint - , currentState = state }) - setServiceStatus hStatus (snd state') - return state' - -nextState :: (DWORD, SERVICE_STATUS) -> (DWORD, SERVICE_STATUS) -nextState (checkPoint, svcStatus) = case (currentState svcStatus) of - START_PENDING -> (checkPoint + 1, svcStatus - { controlsAccepted = [], checkPoint = checkPoint + 1 }) - RUNNING -> (checkPoint, svcStatus - { controlsAccepted = [ACCEPT_STOP], checkPoint = 0 }) - STOPPED -> (checkPoint, svcStatus - { controlsAccepted = [], checkPoint = 0 }) - _ -> (checkPoint + 1, svcStatus - { controlsAccepted = [], checkPoint = checkPoint + 1 }) - -svcCtrlHandler :: MVar () -> MVar (DWORD, SERVICE_STATUS) - -> HandlerFunction -svcCtrlHandler mStop mState hStatus STOP = do - reportSvcStatus hStatus STOP_PENDING nO_ERROR 3000 mState - putMVar mStop () - return True -svcCtrlHandler _ _ _ INTERROGATE = return True -svcCtrlHandler _ _ _ _ = return False - +module Main where++import Control.Concurrent.MVar+import System.Win32.SystemServices.Services+import System.Win32.Types++main :: IO ()+main = do+ gState <- newMVar (1, SERVICE_STATUS WIN32_OWN_PROCESS+ START_PENDING [] nO_ERROR 0 0 3000)+ mStop <- newEmptyMVar+ startServiceCtrlDispatcher "Test" 3000 (svcCtrlHandler mStop gState) $ svcMain mStop gState++svcMain mStop gState _ _ h = do+ reportSvcStatus h RUNNING nO_ERROR 0 gState+ takeMVar mStop+ reportSvcStatus h STOPPED nO_ERROR 0 gState++reportSvcStatus :: HANDLE -> SERVICE_STATE -> DWORD -> DWORD+ -> MVar (DWORD, SERVICE_STATUS) -> IO ()+reportSvcStatus hStatus state win32ExitCode waitHint mState = do+ modifyMVar_ mState $ \(checkPoint, svcStatus) -> do+ let state' = nextState (checkPoint, svcStatus+ { win32ExitCode = win32ExitCode+ , waitHint = waitHint+ , currentState = state })+ setServiceStatus hStatus (snd state')+ return state'++nextState :: (DWORD, SERVICE_STATUS) -> (DWORD, SERVICE_STATUS)+nextState (checkPoint, svcStatus) = case (currentState svcStatus) of + START_PENDING -> (checkPoint + 1, svcStatus+ { controlsAccepted = [], checkPoint = checkPoint + 1 })+ RUNNING -> (checkPoint, svcStatus+ { controlsAccepted = [ACCEPT_STOP], checkPoint = 0 })+ STOPPED -> (checkPoint, svcStatus+ { controlsAccepted = [], checkPoint = 0 })+ _ -> (checkPoint + 1, svcStatus+ { controlsAccepted = [], checkPoint = checkPoint + 1 })++svcCtrlHandler :: MVar () -> MVar (DWORD, SERVICE_STATUS)+ -> HandlerFunction+svcCtrlHandler mStop mState hStatus STOP = do+ reportSvcStatus hStatus STOP_PENDING nO_ERROR 3000 mState+ putMVar mStop ()+ return True+svcCtrlHandler _ _ _ INTERROGATE = return True+svcCtrlHandler _ _ _ _ = return False+
examples/simple.hs view
@@ -1,22 +1,22 @@-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 +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
src/System/Win32/SystemServices/Services.hs view
@@ -1,170 +1,170 @@-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 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
src/System/Win32/SystemServices/Services/SERVICE_ACCEPT.hs view
@@ -1,92 +1,92 @@-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 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 flag fs = foldl (\flag' f -> flag' .|. toDWORD f) 0 fs
src/System/Win32/SystemServices/Services/SERVICE_CONTROL.hs view
@@ -1,68 +1,68 @@-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 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."
src/System/Win32/SystemServices/Services/SERVICE_STATE.hs view
@@ -1,56 +1,56 @@-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 = 0x429 - --- | 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 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 = 0x429++-- | 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
src/System/Win32/SystemServices/Services/SERVICE_STATUS.hs view
@@ -1,83 +1,83 @@-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++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
src/System/Win32/SystemServices/Services/SERVICE_TYPE.hs view
@@ -1,55 +1,55 @@-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 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