Win32-services 0.1 → 0.2
raw patch · 12 files changed
+797/−742 lines, 12 files
Files
- Win32-services.cabal +145/−113
- examples/official.hs +48/−50
- examples/simple.hs +7/−9
- src/System/Win32/SystemServices/Services.hs +172/−151
- src/System/Win32/SystemServices/Services/Raw.hs +33/−26
- 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/−84
- src/System/Win32/SystemServices/Services/SERVICE_TABLE_ENTRY.hs +29/−29
- src/System/Win32/SystemServices/Services/SERVICE_TYPE.hs +55/−55
- src/System/Win32/SystemServices/Services/Types.hs +10/−10
Win32-services.cabal view
@@ -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 <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'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 ...- \<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.--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 <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'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 ... + \<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 + . + * 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
examples/official.hs view
@@ -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 +
examples/simple.hs view
@@ -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] }
src/System/Win32/SystemServices/Services.hs view
@@ -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
src/System/Win32/SystemServices/Services/Raw.hs view
@@ -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
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,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
src/System/Win32/SystemServices/Services/SERVICE_TABLE_ENTRY.hs view
@@ -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
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
src/System/Win32/SystemServices/Services/Types.hs view
@@ -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