diff --git a/Win32-services.cabal b/Win32-services.cabal --- a/Win32-services.cabal +++ b/Win32-services.cabal @@ -1,113 +1,145 @@ -name: Win32-services -category: System -version: 0.1 -cabal-version: >= 1.14 -build-type: Simple -author: Michael Steele -maintainer: Michael Steele -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's now possible 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 = startServiceCtrlDispatcher \"Test\" $ \name _ -> do - mStop <- newEmptyMVar - hStatus <- registerServiceCtrlHandlerEx name $ handler mStop - setServiceStatus hStatus running - takeMVar mStop - setServiceStatus hStatus stopped - . - handler mStop hStatus STOP = do - setServiceStatus hStatus stopPending - putMVar mStop () - return True - handler _ _ INTERROGATE = return True - handler _ _ _ = return False - . - stopped = SERVICE_STATUS WIN32_OWN_PROCESS STOPPED [] nO_ERROR 0 0 0 - stopPending = stopped { currentState = STOP_PENDING - , waitHint = 3000 } - running = stopped { currentState = RUNNING - , controlsAccepted = [ACCEPT_STOP] } - @ - . - @ - C:\programming\test\>ghc --make -threaded Main.hs - [1 of 1] Compiling Main ( Main.hs, Main.o ) - Linking Main.exe ... - \ - 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. - -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 +cabal-version: >= 1.14 +build-type: Simple +author: Michael Steele +maintainer: Michael Steele +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's now possible 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 + . + 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 + stopPending = running { currentState = STOP_PENDING + , controlsAccepted = [] + , waitHint = 3000 } + @ + . + @ + C:\programming\test\>ghc --make -threaded Main.hs + [1 of 1] Compiling Main ( Main.hs, Main.o ) + Linking Main.exe ... + \ + 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 + . + * 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 diff --git a/examples/official.hs b/examples/official.hs --- a/examples/official.hs +++ b/examples/official.hs @@ -1,50 +1,48 @@ -module Main where - -import Control.Concurrent.MVar -import System.Win32.SystemServices.Services -import System.Win32.Types - -main :: IO () -main = startServiceCtrlDispatcher "Test" svcMain - -svcMain :: ServiceMainFunction -svcMain name _ = do - gState <- newMVar (1, SERVICE_STATUS WIN32_OWN_PROCESS - START_PENDING [] nO_ERROR 0 0 3000) - mStop <- newEmptyMVar - hStatus <- registerServiceCtrlHandlerEx name $ svcCtrlHandler mStop gState - - reportSvcStatus hStatus RUNNING nO_ERROR 0 gState - takeMVar mStop - reportSvcStatus hStatus 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 :: 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 + diff --git a/examples/simple.hs b/examples/simple.hs --- a/examples/simple.hs +++ b/examples/simple.hs @@ -3,12 +3,11 @@ import Control.Concurrent.MVar import System.Win32.SystemServices.Services -main = startServiceCtrlDispatcher "Test" $ \name _ -> do +main = do mStop <- newEmptyMVar - hStatus <- registerServiceCtrlHandlerEx name $ handler mStop - setServiceStatus hStatus running - takeMVar mStop - setServiceStatus hStatus stopped + startServiceCtrlDispatcher "Test" 3000 (handler mStop) $ \_ _ h -> do + setServiceStatus h running + takeMVar mStop handler mStop hStatus STOP = do setServiceStatus hStatus stopPending @@ -17,8 +16,7 @@ handler _ _ INTERROGATE = return True handler _ _ _ = return False -stopped = SERVICE_STATUS WIN32_OWN_PROCESS STOPPED [] nO_ERROR 0 0 0 -stopPending = stopped { currentState = STOP_PENDING +running = SERVICE_STATUS WIN32_OWN_PROCESS RUNNING [ACCEPT_STOP] nO_ERROR 0 0 0 +stopPending = running { currentState = STOP_PENDING + , controlsAccepted = [] , waitHint = 3000 } -running = stopped { currentState = RUNNING - , controlsAccepted = [ACCEPT_STOP] } diff --git a/src/System/Win32/SystemServices/Services.hs b/src/System/Win32/SystemServices/Services.hs --- a/src/System/Win32/SystemServices/Services.hs +++ b/src/System/Win32/SystemServices/Services.hs @@ -1,151 +1,172 @@ -module System.Win32.SystemServices.Services - ( HandlerFunction - , ServiceMainFunction - , SERVICE_ACCEPT (..) - , SERVICE_CONTROL (..) - , SERVICE_STATE (..) - , SERVICE_STATUS (..) - , SERVICE_TYPE (..) - , nO_ERROR - , eRROR_SERVICE_SPECIFIC_ERROR - , registerServiceCtrlHandlerEx - , 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] -> IO () - --- | Register an handler function to be called whenever the operating system --- receives service control messages. --- --- NOTE: This function creates a FunPtr which is never freed. -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 - -- ^ 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 -> - mfix $ \hStatus -> do - -- FIXME: FunPtrs need to be manually freed - fpHandler <- handlerToFunPtr . toHandlerEx hStatus $ handler - failIfNull (unwords ["RegisterServiceCtrlHandlerEx", str]) - $ c_RegisterServiceCtrlHandlerEx lptstr fpHandler nullPtr - --- |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. - -> 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 main = - withTString name $ \lptstr -> - bracket (smfToFunPtr . toSMF $ main) freeHaskellFunPtr $ \fpMain -> - withArray [SERVICE_TABLE_ENTRY lptstr fpMain, nullSTE] $ \pSTE -> - failIfFalse_ (unwords ["StartServiceCtrlDispatcher", name]) - $ c_StartServiceCtrlDispatcher pSTE - -toSMF :: ServiceMainFunction -> SERVICE_MAIN_FUNCTION -toSMF f = \len -> \pLPTSTR -> do - lptstrx <- peekArray (fromIntegral len) pLPTSTR - args <- mapM peekTString lptstrx - -- MSDN guarantees args will have at least 1 member. - f (head args) (tail args) - --- 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 + status <- queryServiceStatus h + setServiceStatus h $ status {currentState = STOPPED, controlsAccepted = []} + 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 diff --git a/src/System/Win32/SystemServices/Services/Raw.hs b/src/System/Win32/SystemServices/Services/Raw.hs --- a/src/System/Win32/SystemServices/Services/Raw.hs +++ b/src/System/Win32/SystemServices/Services/Raw.hs @@ -1,26 +1,33 @@ -{-# 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 - --- 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 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 diff --git a/src/System/Win32/SystemServices/Services/SERVICE_ACCEPT.hs b/src/System/Win32/SystemServices/Services/SERVICE_ACCEPT.hs --- a/src/System/Win32/SystemServices/Services/SERVICE_ACCEPT.hs +++ b/src/System/Win32/SystemServices/Services/SERVICE_ACCEPT.hs @@ -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 diff --git a/src/System/Win32/SystemServices/Services/SERVICE_CONTROL.hs b/src/System/Win32/SystemServices/Services/SERVICE_CONTROL.hs --- a/src/System/Win32/SystemServices/Services/SERVICE_CONTROL.hs +++ b/src/System/Win32/SystemServices/Services/SERVICE_CONTROL.hs @@ -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." diff --git a/src/System/Win32/SystemServices/Services/SERVICE_STATE.hs b/src/System/Win32/SystemServices/Services/SERVICE_STATE.hs --- a/src/System/Win32/SystemServices/Services/SERVICE_STATE.hs +++ b/src/System/Win32/SystemServices/Services/SERVICE_STATE.hs @@ -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 diff --git a/src/System/Win32/SystemServices/Services/SERVICE_STATUS.hs b/src/System/Win32/SystemServices/Services/SERVICE_STATUS.hs --- a/src/System/Win32/SystemServices/Services/SERVICE_STATUS.hs +++ b/src/System/Win32/SystemServices/Services/SERVICE_STATUS.hs @@ -1,84 +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 diff --git a/src/System/Win32/SystemServices/Services/SERVICE_TABLE_ENTRY.hs b/src/System/Win32/SystemServices/Services/SERVICE_TABLE_ENTRY.hs --- a/src/System/Win32/SystemServices/Services/SERVICE_TABLE_ENTRY.hs +++ b/src/System/Win32/SystemServices/Services/SERVICE_TABLE_ENTRY.hs @@ -1,29 +1,29 @@ -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 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 diff --git a/src/System/Win32/SystemServices/Services/SERVICE_TYPE.hs b/src/System/Win32/SystemServices/Services/SERVICE_TYPE.hs --- a/src/System/Win32/SystemServices/Services/SERVICE_TYPE.hs +++ b/src/System/Win32/SystemServices/Services/SERVICE_TYPE.hs @@ -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 diff --git a/src/System/Win32/SystemServices/Services/Types.hs b/src/System/Win32/SystemServices/Services/Types.hs --- a/src/System/Win32/SystemServices/Services/Types.hs +++ b/src/System/Win32/SystemServices/Services/Types.hs @@ -1,10 +1,10 @@ -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 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