diff --git a/Win32-services.cabal b/Win32-services.cabal --- a/Win32-services.cabal +++ b/Win32-services.cabal @@ -1,6 +1,6 @@ name: Win32-services category: System -version: 0.2.5.1 +version: 0.3 cabal-version: >= 1.16 build-type: Simple author: Michael Steele @@ -46,7 +46,7 @@ module Main where . import Control.Concurrent.MVar - import System.Win32.SystemServices.Services + import System.Win32.Services . main = do mStop <- newEmptyMVar @@ -55,16 +55,16 @@ takeMVar mStop setServiceStatus h stopped . - handler mStop hStatus STOP = do + handler mStop hStatus Stop = do setServiceStatus hStatus stopPending putMVar mStop () return True - handler _ _ INTERROGATE = return True + handler _ _ Interrogate = return True handler _ _ _ = return False . - running = SERVICE_STATUS WIN32_OWN_PROCESS RUNNING [ACCEPT_STOP] nO_ERROR 0 0 0 - stopped = SERVICE_STATUS WIN32_OWN_PROCESS STOPPED [] nO_ERROR 0 0 0 - stopPending = SERVICE_STATUS WIN32_OWN_PROCESS STOP_PENDING [ACCEPT_STOP] nO_ERROR 0 0 0 + running = ServiceStatus Win32OwnProcess Running [AcceptStop] nO_ERROR 0 0 0 + stopped = ServiceStatus Win32OwnProcess Stopped [] nO_ERROR 0 0 0 + stopPending = ServiceStatus Win32OwnProcess StopPending [AcceptStop] nO_ERROR 0 0 0 @ . @ @@ -108,19 +108,19 @@ library build-depends: base >= 4.5 && < 4.9 , Win32 >= 2.2 && < 2.4 + , Win32-errors >= 0.2 && < 0.3 default-language: Haskell2010 ghc-options: -Wall hs-source-dirs: src - Exposed-Modules: System.Win32.SystemServices.Services + Exposed-Modules: System.Win32.Services Extra-Libraries: Advapi32 Extra-Lib-Dirs: c:\Windows\System32 other-modules: Import - , System.Win32.SystemServices.Services.SERVICE_STATUS - , System.Win32.SystemServices.Services.Raw - , System.Win32.SystemServices.Services.SERVICE_TABLE_ENTRY - , System.Win32.SystemServices.Services.Types - , System.Win32.SystemServices.Services.SERVICE_ACCEPT - , System.Win32.SystemServices.Services.SERVICE_CONTROL - , System.Win32.SystemServices.Services.SERVICE_STATE - , System.Win32.SystemServices.Services.SERVICE_TYPE + , System.Win32.Services.Raw + , System.Win32.Services.Accept + , System.Win32.Services.Control + , System.Win32.Services.State + , System.Win32.Services.Status + , System.Win32.Services.TableEntry + , System.Win32.Services.Type diff --git a/examples/official.hs b/examples/official.hs --- a/examples/official.hs +++ b/examples/official.hs @@ -1,23 +1,23 @@ module Main where import Control.Concurrent.MVar -import System.Win32.SystemServices.Services +import System.Win32.Services import System.Win32.Types main :: IO () main = do - gState <- newMVar (1, SERVICE_STATUS WIN32_OWN_PROCESS - START_PENDING [] nO_ERROR 0 0 3000) + gState <- newMVar (1, ServiceStatus Win32OwnProcess + StartPending [] 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 + reportSvcStatus h Running nO_ERROR 0 gState takeMVar mStop - reportSvcStatus h STOPPED nO_ERROR 0 gState + reportSvcStatus h Stopped nO_ERROR 0 gState -reportSvcStatus :: HANDLE -> SERVICE_STATE -> DWORD -> DWORD - -> MVar (DWORD, SERVICE_STATUS) -> IO () +reportSvcStatus :: HANDLE -> ServiceState -> DWORD -> DWORD + -> MVar (DWORD, ServiceStatus) -> IO () reportSvcStatus hStatus state win32ExitCode waitHint mState = do modifyMVar_ mState $ \(checkPoint, svcStatus) -> do let state' = nextState (checkPoint, svcStatus @@ -27,23 +27,23 @@ setServiceStatus hStatus (snd state') return state' -nextState :: (DWORD, SERVICE_STATUS) -> (DWORD, SERVICE_STATUS) +nextState :: (DWORD, ServiceStatus) -> (DWORD, ServiceStatus) nextState (checkPoint, svcStatus) = case (currentState svcStatus) of - START_PENDING -> (checkPoint + 1, svcStatus + StartPending -> (checkPoint + 1, svcStatus { controlsAccepted = [], checkPoint = checkPoint + 1 }) - RUNNING -> (checkPoint, svcStatus - { controlsAccepted = [ACCEPT_STOP], checkPoint = 0 }) - STOPPED -> (checkPoint, svcStatus + Running -> (checkPoint, svcStatus + { controlsAccepted = [AcceptStop], checkPoint = 0 }) + Stopped -> (checkPoint, svcStatus { controlsAccepted = [], checkPoint = 0 }) _ -> (checkPoint + 1, svcStatus { controlsAccepted = [], checkPoint = checkPoint + 1 }) -svcCtrlHandler :: MVar () -> MVar (DWORD, SERVICE_STATUS) +svcCtrlHandler :: MVar () -> MVar (DWORD, ServiceStatus) -> HandlerFunction -svcCtrlHandler mStop mState hStatus STOP = do - reportSvcStatus hStatus STOP_PENDING nO_ERROR 3000 mState +svcCtrlHandler mStop mState hStatus Stop = do + reportSvcStatus hStatus StopPending nO_ERROR 3000 mState putMVar mStop () return True -svcCtrlHandler _ _ _ INTERROGATE = 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 @@ -1,7 +1,7 @@ module Main where import Control.Concurrent.MVar -import System.Win32.SystemServices.Services +import System.Win32.Services main = do mStop <- newEmptyMVar @@ -10,13 +10,13 @@ takeMVar mStop setServiceStatus h stopped -handler mStop hStatus STOP = do +handler mStop hStatus Stop = do setServiceStatus hStatus stopPending putMVar mStop () return True -handler _ _ INTERROGATE = return True +handler _ _ Interrogate = return True handler _ _ _ = return False -running = SERVICE_STATUS WIN32_OWN_PROCESS RUNNING [ACCEPT_STOP] nO_ERROR 0 0 0 -stopped = SERVICE_STATUS WIN32_OWN_PROCESS STOPPED [] nO_ERROR 0 0 0 -stopPending = SERVICE_STATUS WIN32_OWN_PROCESS STOP_PENDING [ACCEPT_STOP] nO_ERROR 0 0 0 +running = ServiceStatus Win32OwnProcess Running [AcceptStop] nO_ERROR 0 0 0 +stopped = ServiceStatus Win32OwnProcess Stopped [] nO_ERROR 0 0 0 +stopPending = ServiceStatus Win32OwnProcess StopPending [AcceptStop] nO_ERROR 0 0 0 diff --git a/src/Import.hs b/src/Import.hs --- a/src/Import.hs +++ b/src/Import.hs @@ -11,7 +11,11 @@ #endif import Foreign as X +import System.Win32.Error as X +import System.Win32.Error.Foreign as X import System.Win32.Types as X + hiding ( ErrCode, failIfNull, failWith, failUnlessSuccess + , failIfFalse_, failIf, errorWin) -- | Suppress the 'Left' value of an 'Either' -- taken from the errors package diff --git a/src/System/Win32/Services.hs b/src/System/Win32/Services.hs new file mode 100644 --- /dev/null +++ b/src/System/Win32/Services.hs @@ -0,0 +1,199 @@ +{-# LANGUAGE OverloadedStrings #-} + +module System.Win32.Services + ( HandlerFunction + , ServiceMainFunction + , ServiceAccept (..) + , ServiceControl (..) + , ServiceState (..) + , ServiceStatus (..) + , ServiceType (..) + , queryServiceStatus + , setServiceStatus + , startServiceCtrlDispatcher + ) where + +import Control.Exception +import Control.Monad.Fix + +import Import +import System.Win32.Services.Raw +import System.Win32.Services.Accept +import System.Win32.Services.Control +import qualified System.Win32.Services.Control as SC +import System.Win32.Services.State +import System.Win32.Services.Status +import System.Win32.Services.TableEntry +import System.Win32.Services.Type + +-- | 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 -> ServiceControl -> 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 'StartPending', 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 ServiceStatus + -- ^ This function will throw an 'Win32Exception' when the internal + -- Win32 call returnes an error condition. MSDN lists the following + -- exceptions, but others might be thrown as well: + -- + -- [@'AccessDenied'@] The handle does not have the + -- SERVICE_QUERY_STATUS access right. + -- + -- [@'InvalidHandle'@] The handle is invalid. +queryServiceStatus h = alloca $ \pStatus -> do + failIfFalse_ "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 'Win32OwnProcess' 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, FunPtr HANDLER_FUNCTION_EX) + -- ^ This function will throw an 'Win32Exception' when the internal + -- Win32 call returnes an error condition. MSDN lists the following + -- exceptions, but others might be thrown as well: + -- + -- [@'ServiceNotInExe'@] The service entry was specified incorrectly + -- when the process called 'startServiceCtrlDispatcher'. +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 "RegisterServiceCtrlHandlerEx" + $ 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. + -> ServiceStatus + -- ^ MSDN documentation: A pointer to the SERVICE_STATUS structure the + -- contains the latest status information for the calling service. + -> IO () + -- ^ This function will throw an 'Win32Exception' when the internal Win32 + -- call returnes an error condition. MSDN lists the following exceptions, + -- but others might be thrown as well: + -- + -- [@'InvalidData'@] The specified service status structure is invalid. + -- + -- [@'InvalidHandle'@] The specified handle is invalid. +setServiceStatus h status = + with status $ \pStatus -> + failIfFalse_ "SetServiceStatus" + $ 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 'Win32OwnProcess' 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 + -- ^ + -- [@waitHint@] The estimated time required for a pending start, stop, + -- pause, or continue operation, in milliseconds. + -> 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 () + -- ^ This function will throw an 'Win32Exception' when the internal Win32 + -- call returnes an error condition. MSDN lists the following exceptions, + -- but others might be thrown as well: + -- + -- ['FailedServiceControllerConnect'] + -- This error is returned if the program is being run as a console + -- application rather than as a service. If the program will be run as + -- a console application for debugging purposes, structure it such that + -- service-specific code is not called when this error is returned. + -- + -- ['InvalidData'] The specified dispatch table contains entries + -- that are not in the proper format. + -- + -- ['ServiceAlreadyRunning'] The process has already called + -- @startServiceCtrlDispatcher@. Each process can call + -- @startServiceCtrlDispatcher@ only one time. +startServiceCtrlDispatcher name wh handler main = + withTString name $ \lptstr -> + bracket (toSMF main handler wh >>= smfToFunPtr) freeHaskellFunPtr $ \fpMain -> + withArray [ServiceTableEntry lptstr fpMain, nullSTE] $ \pSTE -> + failIfFalse_ "StartServiceCtrlDispatcher" + $ 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 $ ServiceStatus Win32OwnProcess StartPending [] Success 0 0 wh + f name (tail args) h + freeHaskellFunPtr fpHandler + +-- This was originally written with older style handle functions in mind. +-- I'm now using HandlerEx style functions, and need to add support for +-- the extra parameters here. +toHandlerEx :: HANDLE -> HandlerFunction -> HANDLER_FUNCTION_EX +toHandlerEx h f = \dwControl _ _ _ -> + case SC.marshIn dwControl of + Right control -> do + handled <- f h control + case control of + Interrogate -> return $ toDWORD Success + -- 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 toDWORD Success + else toDWORD CallNotImplemented + Left _ -> return $ toDWORD CallNotImplemented diff --git a/src/System/Win32/Services/Accept.hs b/src/System/Win32/Services/Accept.hs new file mode 100644 --- /dev/null +++ b/src/System/Win32/Services/Accept.hs @@ -0,0 +1,97 @@ +-- We refer to otherwise unused modules in documentation. +{-# OPTIONS_GHC -fno-warn-unused-imports #-} + +module System.Win32.Services.Accept + ( ServiceAccept (..) + , pokeServiceAccept + , peekServiceAccept + ) where + +import Data.Bits +import Data.Maybe +import Text.Printf + +import Import + +-- Imported for haddocks +import qualified System.Win32.Services.Control as C + +-- | The control codes the service accepts and processes in its handler +-- function (See 'HandlerFunction'). By default, all services accept the +-- 'C.Interrogate' value. To accept the 'DEVICEEVENT' value, the service must +-- register to receive device events by using the +-- 'registerDeviceNotification' function. +data ServiceAccept + -- | 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 'C.NetBindAdd', 'C.NetBindRemove', + -- 'C.NetBindEnable', and 'C.NetBindDisable' notifications. + = AcceptNetBindChange + -- | The service can reread its startup parameters without being stopped + -- and restarted. This control code allows the service to receive + -- 'C.ParamChange' notifications. + | AcceptParamChange + -- | The service can be paused and continued. This control code allows the + -- service to receive 'C.Pause' and 'C.Continue' notifications. + | AcceptPauseContinue + -- | 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 'C.Preshutdown' notifications. + -- Note that only the system can send it. + | AcceptPreshutdown + -- | The service is notified when system shutdown occurs. This control + -- code allows the service to receive 'C.Shutdown' notifications. Note + -- that only the system can send it. + | AcceptShutdown + -- | The service can be stopped. This control code allows the service to + -- receive 'C.Stop' notifications. + | AcceptStop + deriving (Show) + +peekServiceAccept :: Ptr DWORD -> IO [ServiceAccept] +peekServiceAccept ptr = unflag <$> peek ptr + +pokeServiceAccept :: Ptr DWORD -> [ServiceAccept] -> IO () +pokeServiceAccept ptr sas = poke ptr . flag $ sas + +-- | Marshal a ServiceAccept "out" to be used in C-land +marshOut :: ServiceAccept -> DWORD +marshOut AcceptNetBindChange = 0x00000010 +marshOut AcceptParamChange = 0x00000008 +marshOut AcceptPauseContinue = 0x00000002 +marshOut AcceptPreshutdown = 0x00000100 +marshOut AcceptShutdown = 0x00000004 +marshOut AcceptStop = 0x00000001 + +-- | Marshall a DWORD "in" to be used in Haskell-land as a ServiceAccept +marshIn :: DWORD -> Either String ServiceAccept +marshIn 0x00000010 = Right AcceptNetBindChange +marshIn 0x00000008 = Right AcceptParamChange +marshIn 0x00000002 = Right AcceptPauseContinue +marshIn 0x00000100 = Right AcceptPreshutdown +marshIn 0x00000004 = Right AcceptShutdown +marshIn 0x00000001 = Right AcceptStop +marshIn 0x00000020 = unsupported "SERVICE_ACCEPT_HARDWAREPROFILECHANGE" +marshIn 0x00000040 = unsupported "SERVICE_ACCEPT_POWEREVENT" +marshIn 0x00000080 = unsupported "SERVICE_ACCEPT_SESSIONCHANGE" +marshIn 0x00000200 = unsupported "SERVICE_ACCEPT_TIMECHANGE" +marshIn 0x00000400 = unsupported "SERVICE_ACCEPT_TRIGGEREVENT" +marshIn 0x00000800 = unsupported "SERVICE_ACCEPT_USERMODEREBOOT" +marshIn 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 -> [ServiceAccept] +unflag f = mapMaybe (hush . marshIn . (.&. f)) masks + where + masks = take 32 $ iterate (`shiftL` 1) 1 + +flag :: [ServiceAccept] -> DWORD +flag fs = foldl (\flag' f -> flag' .|. marshOut f) 0 fs diff --git a/src/System/Win32/Services/Control.hs b/src/System/Win32/Services/Control.hs new file mode 100644 --- /dev/null +++ b/src/System/Win32/Services/Control.hs @@ -0,0 +1,66 @@ +module System.Win32.Services.Control + ( ServiceControl (..) + , peekServiceControl + , pokeServiceControl + , marshIn + ) where + +import Text.Printf + +import Import + +-- | A ServiceControl 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 'ServiceControl' to a 'DWORD'. +-- Use 'convertAttempt' to translate from a 'DWORD' to a 'ServiceControl'. +data ServiceControl = Continue | Interrogate | NetBindAdd | NetBindDisable + | NetBindEnable | NetBindRemove | ParamChange | Pause + | PreShutdown | Shutdown | Stop + deriving (Show) + +peekServiceControl :: Ptr DWORD -> IO (Either String ServiceControl) +peekServiceControl ptr = marshIn <$> peek ptr + +pokeServiceControl :: Ptr DWORD -> ServiceControl -> IO () +pokeServiceControl ptr sc = poke ptr . marshOut $ sc + +-- | Marshal a ServiceAccept "out" to be used in C-land +marshOut :: ServiceControl -> DWORD +marshOut Continue = 0x00000003 +marshOut Interrogate = 0x00000004 +marshOut NetBindAdd = 0x00000007 +marshOut NetBindDisable = 0x0000000A +marshOut NetBindEnable = 0x00000009 +marshOut NetBindRemove = 0x00000008 +marshOut ParamChange = 0x00000006 +marshOut Pause = 0x00000002 +marshOut PreShutdown = 0x0000000F +marshOut Shutdown = 0x00000005 +marshOut Stop = 0x00000001 + +-- | Marshall a DWORD "in" to be used in Haskell-land as a ServiceAccept +marshIn :: DWORD -> Either String ServiceControl +marshIn 0x00000003 = Right Continue +marshIn 0x00000004 = Right Interrogate +marshIn 0x00000007 = Right NetBindAdd +marshIn 0x0000000A = Right NetBindDisable +marshIn 0x00000009 = Right NetBindEnable +marshIn 0x00000008 = Right NetBindRemove +marshIn 0x00000006 = Right ParamChange +marshIn 0x00000002 = Right Pause +marshIn 0x0000000F = Right PreShutdown +marshIn 0x00000005 = Right Shutdown +marshIn 0x00000001 = Right Stop +marshIn 0x0000000B = unsupported "SERVICE_CONTROL_DEVICEEVENT" +marshIn 0x0000000C = unsupported "SERVICE_CONTROL_HARDWAREPROFILECHANGE" +marshIn 0x0000000D = unsupported "SERVICE_CONTROL_POWEREVENT" +marshIn 0x0000000E = unsupported "SERVICE_CONTROL_SESSIONCHANGE" +marshIn 0x00000010 = unsupported "SERVICE_CONTROL_TIMECHANGE" +marshIn 0x00000020 = unsupported "SERVICE_CONTROL_TRIGGEREVENT" +marshIn 0x00000040 = unsupported "SERVICE_CONTROL_USERMODEREBOOT" +marshIn 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/Services/Raw.hs b/src/System/Win32/Services/Raw.hs new file mode 100644 --- /dev/null +++ b/src/System/Win32/Services/Raw.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + +module System.Win32.Services.Raw where + +import Import +import System.Win32.Services.Status +import System.Win32.Services.TableEntry + +type HANDLER_FUNCTION_EX = DWORD -> DWORD -> Ptr () -> Ptr () -> IO DWORD + +foreign import stdcall "wrapper" + smfToFunPtr :: SERVICE_MAIN_FUNCTION -> IO (FunPtr SERVICE_MAIN_FUNCTION) + +foreign import stdcall "wrapper" + handlerToFunPtr :: HANDLER_FUNCTION_EX -> IO (FunPtr HANDLER_FUNCTION_EX) + +-- BOOL WINAPI QueryServiceStatus( +-- _In_ SC_HANDLE hService, +-- _Out_ LPSERVICE_STATUS lpServiceStatus +-- ); +foreign import stdcall "windows.h QueryServiceStatus" + c_QueryServiceStatus :: HANDLE -> Ptr ServiceStatus -> 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 -> FunPtr HANDLER_FUNCTION_EX -> Ptr () -> IO HANDLE + +foreign import stdcall "windows.h SetServiceStatus" + c_SetServiceStatus :: HANDLE -> Ptr ServiceStatus -> IO BOOL + +foreign import stdcall "windows.h StartServiceCtrlDispatcherW" + c_StartServiceCtrlDispatcher :: Ptr ServiceTableEntry -> IO BOOL diff --git a/src/System/Win32/Services/State.hs b/src/System/Win32/Services/State.hs new file mode 100644 --- /dev/null +++ b/src/System/Win32/Services/State.hs @@ -0,0 +1,44 @@ +module System.Win32.Services.State + ( ServiceState (..) + ) where + +import Text.Printf + +import Import + +-- | The current state of a service. +data ServiceState = ContinuePending | PausePending | Paused | Running + | StartPending | StopPending | Stopped + deriving (Eq, Show) + +-- |State is stored as a DWORD value in memory. If an undocument value is +-- encountered during a 'peek', there isn't any reasonable way to respond, so +-- an 'ErrorCall' exception will be thrown. +instance Storable ServiceState where + sizeOf _ = sizeOf (undefined :: DWORD) + alignment _ = alignment (undefined :: DWORD) + peek ptr = marshIn <$> (peek . pDWORD) ptr + poke ptr state = poke (pDWORD ptr) (marshOut state) + +pDWORD :: Ptr ServiceState -> Ptr DWORD +{-# INLINE pDWORD #-} +pDWORD = castPtr + +marshIn :: DWORD -> ServiceState +marshIn 5 = ContinuePending +marshIn 6 = PausePending +marshIn 7 = Paused +marshIn 4 = Running +marshIn 2 = StartPending +marshIn 3 = StopPending +marshIn 1 = Stopped +marshIn x = error $ printf "%x is not a valid SERVICE_STATE value." x + +marshOut :: ServiceState -> DWORD +marshOut Stopped = 0x00000001 +marshOut StartPending = 0x00000002 +marshOut StopPending = 0x00000003 +marshOut Running = 0x00000004 +marshOut ContinuePending = 0x00000005 +marshOut PausePending = 0x00000006 +marshOut Paused = 0x00000007 diff --git a/src/System/Win32/Services/Status.hs b/src/System/Win32/Services/Status.hs new file mode 100644 --- /dev/null +++ b/src/System/Win32/Services/Status.hs @@ -0,0 +1,94 @@ +module System.Win32.Services.Status where + +import qualified System.Win32.Error as E + +import Import +import System.Win32.Services.Accept +import System.Win32.Services.State +import System.Win32.Services.Type + +-- | Contains status information for a service. +data ServiceStatus = ServiceStatus + { serviceType :: ServiceType + -- ^ The type of service. This binding only supports the 'Win32OwnProcess' + -- type. + , currentState :: ServiceState + -- ^ The current state of the service. + , controlsAccepted :: [ServiceAccept] + -- ^ See 'ServiceAccept' for details on this field. + , win32ExitCode :: E.ErrCode + -- ^ 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 + -- 'E.ServiceSpecificError' to indicate that the + -- 'serviceSpecificExitCode' member contains the error code. The service + -- should set this value to 'E.Success' 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 + -- 'E.ServiceSpecificError'. + -- + -- 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 ServiceStatus where + sizeOf _ = 28 + alignment _ = 4 + peek ptr = ServiceStatus + <$> (peek . pST) ptr + <*> (peek . pCS) ptr + <*> (peekServiceAccept . pCA) ptr + <*> (peek . pEC) ptr + <*> (peek . pSSEC) ptr + <*> (peek . pCP) ptr + <*> (peek . pWH) ptr + poke ptr (ServiceStatus st cs ca ec ssec cp wh) = do + poke (pST ptr) st + poke (pCS ptr) cs + pokeServiceAccept (pCA ptr) ca + poke (pEC ptr) ec + poke (pSSEC ptr) ssec + poke (pCP ptr) cp + poke (pWH ptr) wh + +pCA, pSSEC, pCP, pWH :: Ptr ServiceStatus -> Ptr DWORD +pCA = (`plusPtr` 8) . castPtr +pSSEC = (`plusPtr` 16) . castPtr +pCP = (`plusPtr` 20) . castPtr +pWH = (`plusPtr` 24) . castPtr + +pST :: Ptr ServiceStatus -> Ptr ServiceType +{-# INLINE pST #-} +pST = castPtr + +pCS :: Ptr ServiceStatus -> Ptr ServiceState +{-# INLINE pCS #-} +pCS = (`plusPtr` 4) . castPtr + +pEC :: Ptr ServiceStatus -> Ptr E.ErrCode +pEC = (`plusPtr` 12) . castPtr diff --git a/src/System/Win32/Services/TableEntry.hs b/src/System/Win32/Services/TableEntry.hs new file mode 100644 --- /dev/null +++ b/src/System/Win32/Services/TableEntry.hs @@ -0,0 +1,27 @@ +module System.Win32.Services.TableEntry where + +import Import + +type SERVICE_MAIN_FUNCTION = DWORD -> Ptr LPTSTR -> IO () + +data ServiceTableEntry = ServiceTableEntry + { serviceName :: LPWSTR + , serviceProc :: FunPtr SERVICE_MAIN_FUNCTION + } + +instance Storable ServiceTableEntry where + sizeOf _ = 8 + alignment _ = 4 + peek ptr = ServiceTableEntry <$> 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 :: ServiceTableEntry +nullSTE = ServiceTableEntry nullPtr nullFunPtr diff --git a/src/System/Win32/Services/Type.hs b/src/System/Win32/Services/Type.hs new file mode 100644 --- /dev/null +++ b/src/System/Win32/Services/Type.hs @@ -0,0 +1,52 @@ +module System.Win32.Services.Type + ( ServiceType (..) + ) where + +import Text.Printf + +import Import + +-- | Win32 defines many types of services, but this binding only supports +-- Win32OwnProcess. +data ServiceType + -- | The service is a file system driver. + = FileSystemDriver + -- | The service is a device driver. + | KernelDriver + -- | The service runs in its own process. + | Win32OwnProcess + -- | The service shares a process with other services. + | Win32ShareProcess + -- | Do no write your own services of this type. Windows Vista and above + -- prevent service processes from directly interacting with users. + -- + -- A 'ServiceInteractiveProcess' is either a 'Win32OwnProcess' or a + -- 'Win32ShareProcess' running in the context of the LocalSystem + -- account which is allowed to directly interact with users. + | ServiceInteractiveProcess + deriving (Show) + +instance Storable ServiceType where + sizeOf _ = sizeOf (undefined :: DWORD) + alignment _ = alignment (undefined :: DWORD) + peek ptr = marshIn <$> (peek . pDWORD) ptr + poke ptr t = poke (pDWORD ptr) (marshOut t) + +pDWORD :: Ptr ServiceType -> Ptr DWORD +{-# INLINE pDWORD #-} +pDWORD = castPtr + +marshOut :: ServiceType -> DWORD +marshOut FileSystemDriver = 0x00000002 +marshOut KernelDriver = 0x00000001 +marshOut Win32OwnProcess = 0x00000010 +marshOut Win32ShareProcess = 0x00000020 +marshOut ServiceInteractiveProcess = 0x00000100 + +marshIn :: DWORD -> ServiceType +marshIn 0x00000002 = FileSystemDriver +marshIn 0x00000001 = KernelDriver +marshIn 0x00000010 = Win32OwnProcess +marshIn 0x00000020 = Win32ShareProcess +marshIn 0x00000100 = ServiceInteractiveProcess +marshIn x = error $ printf "Invalid SERVICE_TYPE: %x" x diff --git a/src/System/Win32/SystemServices/Services.hs b/src/System/Win32/SystemServices/Services.hs deleted file mode 100644 --- a/src/System/Win32/SystemServices/Services.hs +++ /dev/null @@ -1,172 +0,0 @@ -module System.Win32.SystemServices.Services - ( HandlerFunction - , ServiceMainFunction - , SERVICE_ACCEPT (..) - , SERVICE_CONTROL (..) - , SERVICE_STATE (..) - , SERVICE_STATUS (..) - , SERVICE_TYPE (..) - , nO_ERROR - , eRROR_SERVICE_SPECIFIC_ERROR - , queryServiceStatus - , setServiceStatus - , startServiceCtrlDispatcher - ) where - -import Control.Exception -import Control.Monad.Fix - -import Import -import System.Win32.SystemServices.Services.Raw -import System.Win32.SystemServices.Services.SERVICE_ACCEPT -import System.Win32.SystemServices.Services.SERVICE_CONTROL -import qualified System.Win32.SystemServices.Services.SERVICE_CONTROL as SC -import System.Win32.SystemServices.Services.SERVICE_STATE -import System.Win32.SystemServices.Services.SERVICE_STATUS -import System.Win32.SystemServices.Services.SERVICE_TABLE_ENTRY -import System.Win32.SystemServices.Services.SERVICE_TYPE -import System.Win32.SystemServices.Services.Types - --- | A handler function is registered with the service dispatcher thread --- from a 'ServiceMainFunction'. The first argument is a 'HANDLE' returned --- from calling 'registerServiceCtrlHandler'. The second argument represents --- the command this service has been directed to perform. -type HandlerFunction = HANDLE -> SERVICE_CONTROL -> IO Bool - --- | The service dispatcher thread will call each function of this type that --- you provide. The first argument will be the name of the service. Any --- additional command-line parameters will appear in the second argument. --- --- Each of these functions should call 'registerServiceCtrlHandler' to --- register a function to handle incoming commands. It should then set --- the service's status to 'START_PENDING', and specify that no controls --- will be accepted. At this point the function may perform any other --- initialization steps before setting the service's status to --- 'RUNNING'. All of this should take no more than 100ms. -type ServiceMainFunction = String -> [String] -> HANDLE -> IO () - --- |Retrieves the current status of the specified service. -queryServiceStatus :: HANDLE - -- ^ MSDN documentation: A handle to the service. This handle is returned - -- by the OpenService or the CreateService function, and it must have the - -- SERVICE_QUERY_STATUS access right. For more information, see Service - -- Security and Access Rights. - -> IO SERVICE_STATUS - -- ^ This function will raise an exception if the Win32 call returned an - -- error condition. -queryServiceStatus h = alloca $ \pStatus -> do - failIfFalse_ (unwords ["QueryServiceStatus"]) - $ c_QueryServiceStatus h pStatus - peek pStatus - --- | Register an handler function to be called whenever the operating system --- receives service control messages. -registerServiceCtrlHandlerEx :: String - -- ^ The name of the service. According to MSDN documentation this - -- argument is unused in WIN32_OWN_PROCESS type services, which is the - -- only type supported by this binding. Even so, it is recommended - -- that the name of the service be used. - -- - -- MSDN description: The name of the service run by the calling thread. - -- This is the service name that the service control program specified in - -- the CreateService function when creating the service. - -> HandlerFunction - -- ^ A Handler function to be called in response to service control - -- messages. Behind the scenes this is translated into a "HandlerEx" type - -- handler. - -> IO (HANDLE, LPHANDLER_FUNCTION_EX) - -- ^ The returned handle may be used in calls to SetServiceStatus. For - -- convenience Handler functions also receive a handle for the service. -registerServiceCtrlHandlerEx str handler = - withTString str $ \lptstr -> - -- use 'ret' instead of (h', _) to avoid divergence. - mfix $ \ret -> do - fpHandler <- handlerToFunPtr $ toHandlerEx (fst ret) handler - h <- failIfNull (unwords ["RegisterServiceCtrlHandlerEx", str]) - $ c_RegisterServiceCtrlHandlerEx lptstr fpHandler nullPtr - return (h, fpHandler) - --- |Updates the service control manager's status information for the calling --- service. -setServiceStatus :: HANDLE - -- ^ MSDN documentation: A handle to the status information structure for - -- the current service. This handle is returned by the - -- RegisterServiceCtrlHandlerEx function. - -> SERVICE_STATUS - -- ^ MSDN documentation: A pointer to the SERVICE_STATUS structure the - -- contains the latest status information for the calling service. - -> IO () - -- ^ This function will raise an exception if the Win32 call returned an - -- error condition. -setServiceStatus h status = - with status $ \pStatus -> do - failIfFalse_ (unwords ["SetServiceStatus", show h, show status]) - $ c_SetServiceStatus h pStatus - --- |Register a callback function to initialize the service, which will be --- called by the operating system immediately. startServiceCtrlDispatcher --- will block until the provided callback function returns. --- --- MSDN documentation: Connects the main thread of a service process to the --- service control manager, which causes the thread to be the service control --- dispatcher thread for the calling process. -startServiceCtrlDispatcher :: String - -- ^ The name of the service. According to MSDN documentation this - -- argument is unused in WIN32_OWN_PROCESS type services, which is the - -- only type supported by this binding. Even so, it is recommended - -- that the name of the service be used. - -- - -- MSDN description: The name of the service run by the calling thread. - -- This is the service name that the service control program specified in - -- the CreateService function when creating the service. - -> DWORD - -- ^ - -- [@waitHint@] The estimated time required for a pending start, stop, - -- pause, or continue operation, in milliseconds. - -> HandlerFunction - -> ServiceMainFunction - -- ^ This is a callback function that will be called by the operating - -- system whenever the service is started. It should perform service - -- initialization including the registration of a handler function. - -- MSDN documentation gives conflicting advice as to whether this function - -- should return before the service has entered the stopped state. - -- In the official example the service main function blocks until the - -- service is ready to stop. - -> IO () - -- ^ An exception will be raised if the underlying Win32 call returns an - -- error condition. -startServiceCtrlDispatcher name wh handler main = - withTString name $ \lptstr -> - bracket (toSMF main handler wh >>= smfToFunPtr) freeHaskellFunPtr $ \fpMain -> - withArray [SERVICE_TABLE_ENTRY lptstr fpMain, nullSTE] $ \pSTE -> - failIfFalse_ (unwords ["StartServiceCtrlDispatcher", name]) $ do - c_StartServiceCtrlDispatcher pSTE - -toSMF :: ServiceMainFunction -> HandlerFunction -> DWORD -> IO SERVICE_MAIN_FUNCTION -toSMF f handler wh = return $ \len pLPTSTR -> do - lptstrx <- peekArray (fromIntegral len) pLPTSTR - args <- mapM peekTString lptstrx - -- MSDN guarantees args will have at least 1 member. - let name = head args - (h, fpHandler) <- registerServiceCtrlHandlerEx name handler - setServiceStatus h $ SERVICE_STATUS WIN32_OWN_PROCESS START_PENDING [] nO_ERROR 0 0 wh - f name (tail args) h - freeHaskellFunPtr fpHandler - --- This was originally written with older style handle functions in mind. --- I'm now using HandlerEx style functions, and need to add support for --- the extra parameters here. -toHandlerEx :: HANDLE -> HandlerFunction -> HANDLER_FUNCTION_EX -toHandlerEx h f = \dwControl _ _ _ -> - case SC.fromDWORD dwControl of - Right control -> do - handled <- f h control - case control of - INTERROGATE -> return nO_ERROR - -- If we ever support extended control codes this will have to - -- change. see "Dev Center - Desktop > Docs > Desktop app - -- development documentation > System Services > Services > - -- Service Reference > Service Functions > HandlerEx". - _ -> return $ if handled then nO_ERROR - else eRROR_CALL_NOT_IMPLEMENTED - Left _ -> return eRROR_CALL_NOT_IMPLEMENTED diff --git a/src/System/Win32/SystemServices/Services/Raw.hs b/src/System/Win32/SystemServices/Services/Raw.hs deleted file mode 100644 --- a/src/System/Win32/SystemServices/Services/Raw.hs +++ /dev/null @@ -1,31 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface #-} - -module System.Win32.SystemServices.Services.Raw where - -import Import -import System.Win32.SystemServices.Services.SERVICE_STATUS -import System.Win32.SystemServices.Services.SERVICE_TABLE_ENTRY -import System.Win32.SystemServices.Services.Types - -foreign import stdcall "wrapper" - smfToFunPtr :: SERVICE_MAIN_FUNCTION -> IO LPSERVICE_MAIN_FUNCTION - -foreign import stdcall "wrapper" - handlerToFunPtr :: HANDLER_FUNCTION_EX -> IO LPHANDLER_FUNCTION_EX - --- BOOL WINAPI QueryServiceStatus( --- _In_ SC_HANDLE hService, --- _Out_ LPSERVICE_STATUS lpServiceStatus --- ); -foreign import stdcall "windows.h QueryServiceStatus" - c_QueryServiceStatus :: HANDLE -> Ptr SERVICE_STATUS -> IO BOOL - --- I've not been able to get RegisterServiceCtrlHandler to work on Windows 7 64-bit. -foreign import stdcall "windows.h RegisterServiceCtrlHandlerExW" - c_RegisterServiceCtrlHandlerEx :: LPTSTR -> LPHANDLER_FUNCTION_EX -> Ptr () -> IO HANDLE - -foreign import stdcall "windows.h SetServiceStatus" - c_SetServiceStatus :: HANDLE -> Ptr SERVICE_STATUS -> IO BOOL - -foreign import stdcall "windows.h StartServiceCtrlDispatcherW" - c_StartServiceCtrlDispatcher :: Ptr SERVICE_TABLE_ENTRY -> IO BOOL diff --git a/src/System/Win32/SystemServices/Services/SERVICE_ACCEPT.hs b/src/System/Win32/SystemServices/Services/SERVICE_ACCEPT.hs deleted file mode 100644 --- a/src/System/Win32/SystemServices/Services/SERVICE_ACCEPT.hs +++ /dev/null @@ -1,95 +0,0 @@ --- We refer to otherwise unused modules in documentation. -{-# OPTIONS_GHC -fno-warn-unused-imports #-} - -module System.Win32.SystemServices.Services.SERVICE_ACCEPT - ( SERVICE_ACCEPT (..) - , pokeServiceAccept - , peekServiceAccept - ) where - -import Data.Bits -import Data.Maybe -import Text.Printf - -import Import - --- Imported for haddocks -import qualified System.Win32.SystemServices.Services.SERVICE_CONTROL as C - --- | The control codes the service accepts and processes in its handler --- function (See 'HandlerFunction'). By default, all services accept the --- 'C.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 'C.NETBINDADD', 'C.NETBINDREMOVE', - -- 'C.NETBINDENABLE', and 'C.NETBINDDISABLE' notifications. - = ACCEPT_NETBINDCHANGE - -- | The service can reread its startup parameters without being stopped - -- and restarted. This control code allows the service to receive - -- 'C.PARAMCHANGE' notifications. - | ACCEPT_PARAMCHANGE - -- | The service can be paused and continued. This control code allows the - -- service to receive 'C.PAUSE' and 'C.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 'C.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 'C.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 'C.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 deleted file mode 100644 --- a/src/System/Win32/SystemServices/Services/SERVICE_CONTROL.hs +++ /dev/null @@ -1,64 +0,0 @@ -module System.Win32.SystemServices.Services.SERVICE_CONTROL - ( SERVICE_CONTROL (..) - , peekServiceControl - , pokeServiceControl - , fromDWORD - ) where - -import Text.Printf - -import Import - --- | A SERVICE_CONTROL is used in Handler functions. All control codes are --- defined here, but some can only be used with a 'HandlerEx' callback. --- Use 'convertSuccess' to translate from a 'SERVICE_CONTROL' to a 'DWORD'. --- Use 'convertAttempt' to translate from a 'DWORD' to a 'SERVICE_CONTROL'. -data SERVICE_CONTROL = CONTINUE | INTERROGATE | NETBINDADD | NETBINDDISABLE - | NETBINDENABLE | NETBINDREMOVE | PARAMCHANGE | PAUSE - | PRESHUTDOWN | SHUTDOWN | STOP - deriving (Show) - -peekServiceControl :: Ptr DWORD -> IO (Either String SERVICE_CONTROL) -peekServiceControl ptr = fromDWORD <$> peek ptr - -pokeServiceControl :: Ptr DWORD -> SERVICE_CONTROL -> IO () -pokeServiceControl ptr sc = poke ptr . toDWORD $ sc - -toDWORD :: SERVICE_CONTROL -> DWORD -toDWORD CONTINUE = 0x00000003 -toDWORD INTERROGATE = 0x00000004 -toDWORD NETBINDADD = 0x00000007 -toDWORD NETBINDDISABLE = 0x0000000A -toDWORD NETBINDENABLE = 0x00000009 -toDWORD NETBINDREMOVE = 0x00000008 -toDWORD PARAMCHANGE = 0x00000006 -toDWORD PAUSE = 0x00000002 -toDWORD PRESHUTDOWN = 0x0000000F -toDWORD SHUTDOWN = 0x00000005 -toDWORD STOP = 0x00000001 - -fromDWORD :: DWORD -> Either String SERVICE_CONTROL -fromDWORD 0x00000003 = Right CONTINUE -fromDWORD 0x00000004 = Right INTERROGATE -fromDWORD 0x00000007 = Right NETBINDADD -fromDWORD 0x0000000A = Right NETBINDDISABLE -fromDWORD 0x00000009 = Right NETBINDENABLE -fromDWORD 0x00000008 = Right NETBINDREMOVE -fromDWORD 0x00000006 = Right PARAMCHANGE -fromDWORD 0x00000002 = Right PAUSE -fromDWORD 0x0000000F = Right PRESHUTDOWN -fromDWORD 0x00000005 = Right SHUTDOWN -fromDWORD 0x00000001 = Right STOP -fromDWORD 0x0000000B = unsupported "SERVICE_CONTROL_DEVICEEVENT" -fromDWORD 0x0000000C = unsupported "SERVICE_CONTROL_HARDWAREPROFILECHANGE" -fromDWORD 0x0000000D = unsupported "SERVICE_CONTROL_POWEREVENT" -fromDWORD 0x0000000E = unsupported "SERVICE_CONTROL_SESSIONCHANGE" -fromDWORD 0x00000010 = unsupported "SERVICE_CONTROL_TIMECHANGE" -fromDWORD 0x00000020 = unsupported "SERVICE_CONTROL_TRIGGEREVENT" -fromDWORD 0x00000040 = unsupported "SERVICE_CONTROL_USERMODEREBOOT" -fromDWORD x - | x >= 128 && x <= 255 = Left "user defined control codes are unsupported by this binding." - | otherwise = Left $ "The " ++ printf "%x" x ++ " control code is undocumented." - -unsupported :: String -> Either String a -unsupported name = Left $ "The " ++ name ++ " control code is unsupported by this binding." diff --git a/src/System/Win32/SystemServices/Services/SERVICE_STATE.hs b/src/System/Win32/SystemServices/Services/SERVICE_STATE.hs deleted file mode 100644 --- a/src/System/Win32/SystemServices/Services/SERVICE_STATE.hs +++ /dev/null @@ -1,52 +0,0 @@ -module System.Win32.SystemServices.Services.SERVICE_STATE - ( SERVICE_STATE (..) - , nO_ERROR - , eRROR_CALL_NOT_IMPLEMENTED - , eRROR_SERVICE_SPECIFIC_ERROR - , peekServiceState - , pokeServiceState - ) where - -import Text.Printf - -import Import - -nO_ERROR :: ErrCode -nO_ERROR = 0 - -eRROR_CALL_NOT_IMPLEMENTED :: ErrCode -eRROR_CALL_NOT_IMPLEMENTED = 0x78 - -eRROR_SERVICE_SPECIFIC_ERROR :: ErrCode -eRROR_SERVICE_SPECIFIC_ERROR = 0x42a - --- | The current state of a service. -data SERVICE_STATE = CONTINUE_PENDING | PAUSE_PENDING | PAUSED | RUNNING - | START_PENDING | STOP_PENDING | STOPPED - deriving (Eq, Show) - -fromDWORD :: DWORD -> Either String SERVICE_STATE -fromDWORD 5 = Right CONTINUE_PENDING -fromDWORD 6 = Right PAUSE_PENDING -fromDWORD 7 = Right PAUSED -fromDWORD 4 = Right RUNNING -fromDWORD 2 = Right START_PENDING -fromDWORD 3 = Right STOP_PENDING -fromDWORD 1 = Right STOPPED -fromDWORD x = Left $ "Unable to interpret " ++ printf "%x" x - ++ " as a SERVICE_STATE." - -toDWORD :: SERVICE_STATE -> DWORD -toDWORD STOPPED = 0x00000001 -toDWORD START_PENDING = 0x00000002 -toDWORD STOP_PENDING = 0x00000003 -toDWORD RUNNING = 0x00000004 -toDWORD CONTINUE_PENDING = 0x00000005 -toDWORD PAUSE_PENDING = 0x00000006 -toDWORD PAUSED = 0x00000007 - -peekServiceState :: Ptr DWORD -> IO (Either String SERVICE_STATE) -peekServiceState ptr = fromDWORD <$> peek ptr - -pokeServiceState :: Ptr DWORD -> SERVICE_STATE -> IO () -pokeServiceState ptr sc = poke ptr . toDWORD $ sc diff --git a/src/System/Win32/SystemServices/Services/SERVICE_STATUS.hs b/src/System/Win32/SystemServices/Services/SERVICE_STATUS.hs deleted file mode 100644 --- a/src/System/Win32/SystemServices/Services/SERVICE_STATUS.hs +++ /dev/null @@ -1,103 +0,0 @@ -module System.Win32.SystemServices.Services.SERVICE_STATUS where - --- These two imports are here to preserve existing behavior now that --- the dependency on "errors" has been dropped. -import System.Exit -import System.IO - -import Import -import System.Win32.SystemServices.Services.SERVICE_ACCEPT -import System.Win32.SystemServices.Services.SERVICE_STATE -import System.Win32.SystemServices.Services.SERVICE_TYPE - --- | Contains status information for a service. -data SERVICE_STATUS = SERVICE_STATUS - { serviceType :: SERVICE_TYPE - -- ^ The type of service. This binding only supports the WIN32_OWN_PROCESS - -- type. - , currentState :: SERVICE_STATE - -- ^ The current state of the service. - , controlsAccepted :: [SERVICE_ACCEPT] - -- ^ See 'SERVICE_ACCEPT' for details on this field. - , win32ExitCode :: DWORD - -- ^ The error code the service uses to report an error that occurs when - -- it is starting or stopping. To return an error code specific to the - -- service, the service must set this value to - -- 'eRROR_SERVICE_SPECIFIC_ERROR' to indicate that the - -- 'serviceSpecificExitCode' member contains the error code. The service - -- should set this value to 'nO_ERROR' when it is running and on normal - -- termination. - , serviceSpecificExitCode :: DWORD - -- ^ A service-specific error code that the service returns when an error - -- occurs while the service is starting or stopping. This value is - -- ignored unless the 'win32ExitCode' member is set to - -- 'eRROR_SERVICE_SPECIFIC_ERROR'. - -- - -- This binding does not support service-specific error codes. - , checkPoint :: DWORD - -- ^ The check-point value the service increments periodically to report - -- its progress during a lengthy start, stop, pause, or continue - -- operation. For example, the service should increment this value as it - -- completes each step of its initialization when it is starting up. The - -- user interface program that invoked the operation on the service uses - -- this value to track the progress of the service during a lengthy - -- operation. This value is not valid and should be zero when the - -- service does not have a start, stop, pause, or continue operation - -- pending. - , waitHint :: DWORD - -- ^ The estimated time required for a pending start, stop, pause, or - -- continue operation, in milliseconds. Before the specified amount of - -- time has elapsed, the service should make its next call to the - -- SetServiceStatus function with either an incremented dwCheckPoint - -- value or a change in 'currentState'. If the amount of time specified - -- by 'waitHint' passes, and 'checkPoint' has not been incremented or - -- 'currentState' has not changed, the service control manager or - -- service control program can assume that an error has occurred and the - -- service should be stopped. However, if the service shares a process - -- with other services, the service control manager cannot terminate the - -- service application because it would have to terminate the other - -- services sharing the process as well. - } deriving (Show) - -instance Storable SERVICE_STATUS where - sizeOf _ = 28 - alignment _ = 4 - peek ptr = do - -- This block is not ideal. It is here to preserve backwards - -- compatibility with former behavior, and will be replaced in a future - -- version. We used to wrap peekServiceType and peekServiceState in - -- calls to runScript from the "errors" package. This results in a - -- line being printed to stderr and process termination on a left value. - -- Service applications do not have stderr. - est <- peekServiceType (pST ptr) - ecs <- peekServiceState (pCS ptr) - case (,) <$> est <*> ecs of - Left e -> do - -- runScript would call this on error. - hPutStrLn stderr e - exitFailure - Right (st, cs) -> SERVICE_STATUS st cs - <$> (peekServiceAccept . pCA) ptr - <*> (peek . pEC) ptr - <*> (peek . pSSEC) ptr - <*> (peek . pCP) ptr - <*> (peek . pWH) ptr - poke ptr (SERVICE_STATUS st cs ca ec ssec cp wh) = do - pokeServiceType (pST ptr) st - pokeServiceState (pCS ptr) cs - pokeServiceAccept (pCA ptr) ca - poke (pEC ptr) ec - poke (pSSEC ptr) ssec - poke (pCP ptr) cp - poke (pWH ptr) wh - -pST, pCS, pCA, pEC, pSSEC, pCP, pWH - :: Ptr SERVICE_STATUS -> Ptr DWORD - -pST = castPtr -pCS = (`plusPtr` 4) . castPtr -pCA = (`plusPtr` 8) . castPtr -pEC = (`plusPtr` 12) . castPtr -pSSEC = (`plusPtr` 16) . castPtr -pCP = (`plusPtr` 20) . castPtr -pWH = (`plusPtr` 24) . castPtr diff --git a/src/System/Win32/SystemServices/Services/SERVICE_TABLE_ENTRY.hs b/src/System/Win32/SystemServices/Services/SERVICE_TABLE_ENTRY.hs deleted file mode 100644 --- a/src/System/Win32/SystemServices/Services/SERVICE_TABLE_ENTRY.hs +++ /dev/null @@ -1,26 +0,0 @@ -module System.Win32.SystemServices.Services.SERVICE_TABLE_ENTRY where - -import Import -import System.Win32.SystemServices.Services.Types - -data SERVICE_TABLE_ENTRY = SERVICE_TABLE_ENTRY - { serviceName :: LPWSTR - , serviceProc :: FunPtr SERVICE_MAIN_FUNCTION - } - -instance Storable SERVICE_TABLE_ENTRY where - sizeOf _ = 8 - alignment _ = 4 - peek ptr = SERVICE_TABLE_ENTRY <$> peek pServiceName <*> peek pServiceProc - where - pServiceName = castPtr ptr - pServiceProc = castPtr ptr `plusPtr` 4 - poke ptr ste = do - poke pServiceName . serviceName $ ste - poke pServiceProc . serviceProc $ ste - where - pServiceName = castPtr ptr - pServiceProc = castPtr ptr `plusPtr` 4 - -nullSTE :: SERVICE_TABLE_ENTRY -nullSTE = SERVICE_TABLE_ENTRY nullPtr nullFunPtr diff --git a/src/System/Win32/SystemServices/Services/SERVICE_TYPE.hs b/src/System/Win32/SystemServices/Services/SERVICE_TYPE.hs deleted file mode 100644 --- a/src/System/Win32/SystemServices/Services/SERVICE_TYPE.hs +++ /dev/null @@ -1,50 +0,0 @@ -module System.Win32.SystemServices.Services.SERVICE_TYPE - ( SERVICE_TYPE (..) - , peekServiceType - , pokeServiceType - ) where - -import Text.Printf - -import Import - --- | Win32 defines many types of services, but this binding only supports --- WIN32_OWN_PROCESS. -data SERVICE_TYPE - -- | The service is a file system driver. - = FILE_SYSTEM_DRIVER - -- | The service is a device driver. - | KERNEL_DRIVER - -- | The service runs in its own process. - | WIN32_OWN_PROCESS - -- | The service shares a process with other services. - | WIN32_SHARE_PROCESS - -- | Do no write your own services of this type. Windows Vista and above - -- prevent service processes from directly interacting with users. - -- - -- A 'SERVICE_INTERACTIVE_PROCESS' is either a 'WIN32_OWN_PROCESS' or a - -- 'WIN32_SHARE_PROCESS' running in the context of the LocalSystem - -- account which is allowed to directly interact with users. - | SERVICE_INTERACTIVE_PROCESS - deriving (Show) - -toDWORD :: SERVICE_TYPE -> DWORD -toDWORD FILE_SYSTEM_DRIVER = 0x00000002 -toDWORD KERNEL_DRIVER = 0x00000001 -toDWORD WIN32_OWN_PROCESS = 0x00000010 -toDWORD WIN32_SHARE_PROCESS = 0x00000020 -toDWORD SERVICE_INTERACTIVE_PROCESS = 0x00000100 - -fromDWORD :: DWORD -> Either String SERVICE_TYPE -fromDWORD 0x00000002 = Right FILE_SYSTEM_DRIVER -fromDWORD 0x00000001 = Right KERNEL_DRIVER -fromDWORD 0x00000010 = Right WIN32_OWN_PROCESS -fromDWORD 0x00000020 = Right WIN32_SHARE_PROCESS -fromDWORD 0x00000100 = Right SERVICE_INTERACTIVE_PROCESS -fromDWORD x = Left $ "Invalid SERVICE_TYPE: " ++ printf "%x" x - -peekServiceType :: Ptr DWORD -> IO (Either String SERVICE_TYPE) -peekServiceType ptr = fromDWORD <$> peek ptr - -pokeServiceType :: Ptr DWORD -> SERVICE_TYPE -> IO () -pokeServiceType ptr x = poke ptr . toDWORD $ x diff --git a/src/System/Win32/SystemServices/Services/Types.hs b/src/System/Win32/SystemServices/Services/Types.hs deleted file mode 100644 --- a/src/System/Win32/SystemServices/Services/Types.hs +++ /dev/null @@ -1,9 +0,0 @@ -module System.Win32.SystemServices.Services.Types where - -import Import - -type HANDLER_FUNCTION_EX = DWORD -> DWORD -> Ptr () -> Ptr () -> IO DWORD -type LPHANDLER_FUNCTION_EX = FunPtr HANDLER_FUNCTION_EX - -type SERVICE_MAIN_FUNCTION = DWORD -> Ptr LPTSTR -> IO () -type LPSERVICE_MAIN_FUNCTION = FunPtr SERVICE_MAIN_FUNCTION