diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c)2011, Michael Steele + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Michael Steele nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Win32-services.cabal b/Win32-services.cabal new file mode 100644 --- /dev/null +++ b/Win32-services.cabal @@ -0,0 +1,113 @@ +name: Win32-services +category: System +version: 0.1 +cabal-version: >= 1.14 +build-type: Simple +author: Michael Steele +maintainer: Michael Steele +copyright: Copyright (C) 2011-2013 Michael Steele +homepage: http://github.com/mikesteele81/win32-services +bug-reports: http://github.com/mikesteele81/win32-services/issues +license: BSD3 +license-file: LICENSE +tested-with: GHC == 7.4.2 +stability: provisional +synopsis: Windows service applications +description: + This package provides a partial binding to the Win32 System Services + API. It's now possible to write Windows service applications using + Haskell. + . + The binding is partial. Here are a few ways in which it differs from the + official API: + . + * Only services running within their own process are supported. These are + processes of the 'WIN32_OWN_PROCESS' type. + . + * In cases where multiple versions of the same function exist (for + compatibility), this binding only offers one of them. + . + * None of the extended control codes are supported. Handlers you write will + automatically report this to the operating system when such controls are + received. + . + * Only facilities for writing services are supported; not controlling them. + . + Effort has been made to simplify using the API without hiding what is + happening behind the scenes. Users are encouraged to read Microsoft's + documentation under 'Dev Center - Desktop > Docs > Desktop app development + documentation > System Services > Services'. The official example has been + ported to Haskell. This can be found in the 'examples' directory of the + source tree. + . + /Simple Example and Usage/ + . + @ + module Main where + . + import Control.Concurrent.MVar + import System.Win32.SystemServices.Services + . + main = startServiceCtrlDispatcher \"Test\" $ \name _ -> do + mStop <- newEmptyMVar + hStatus <- registerServiceCtrlHandlerEx name $ handler mStop + setServiceStatus hStatus running + takeMVar mStop + setServiceStatus hStatus stopped + . + handler mStop hStatus STOP = do + setServiceStatus hStatus stopPending + putMVar mStop () + return True + handler _ _ INTERROGATE = return True + handler _ _ _ = return False + . + stopped = SERVICE_STATUS WIN32_OWN_PROCESS STOPPED [] nO_ERROR 0 0 0 + stopPending = stopped { currentState = STOP_PENDING + , waitHint = 3000 } + running = stopped { currentState = RUNNING + , controlsAccepted = [ACCEPT_STOP] } + @ + . + @ + C:\programming\test\>ghc --make -threaded Main.hs + [1 of 1] Compiling Main ( Main.hs, Main.o ) + Linking Main.exe ... + \ + C:\\programming\\test\>copy Main.exe c:\\svc\\Test.exe + 1 file(s) copied. + @ + . + Execute the following from an elevated command prompt to register the + service: + . + @ + C:\\svc\>sc create Test binPath= c:\\svc\\Test.exe + [SC] CreateService SUCCESS + @ + . + The service can now be started and stopped from the services console. + +extra-source-files: examples/*.hs + +source-repository head + type: git + location: git://github.com/mikesteele81/win32-services.git + +library + build-depends: base >= 4.5 && < 4.6 + , errors + , Win32 + default-language: Haskell2010 + ghc-options: -Wall + hs-source-dirs: src + Exposed-Modules: System.Win32.SystemServices.Services + Extra-Libraries: Advapi32 + other-modules: System.Win32.SystemServices.Services.SERVICE_STATUS + , System.Win32.SystemServices.Services.Raw + , System.Win32.SystemServices.Services.SERVICE_TABLE_ENTRY + , System.Win32.SystemServices.Services.Types + , System.Win32.SystemServices.Services.SERVICE_ACCEPT + , System.Win32.SystemServices.Services.SERVICE_CONTROL + , System.Win32.SystemServices.Services.SERVICE_STATE + , System.Win32.SystemServices.Services.SERVICE_TYPE diff --git a/examples/official.hs b/examples/official.hs new file mode 100644 --- /dev/null +++ b/examples/official.hs @@ -0,0 +1,50 @@ +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 diff --git a/examples/simple.hs b/examples/simple.hs new file mode 100644 --- /dev/null +++ b/examples/simple.hs @@ -0,0 +1,24 @@ +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] } diff --git a/src/System/Win32/SystemServices/Services.hs b/src/System/Win32/SystemServices/Services.hs new file mode 100644 --- /dev/null +++ b/src/System/Win32/SystemServices/Services.hs @@ -0,0 +1,151 @@ +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 diff --git a/src/System/Win32/SystemServices/Services/Raw.hs b/src/System/Win32/SystemServices/Services/Raw.hs new file mode 100644 --- /dev/null +++ b/src/System/Win32/SystemServices/Services/Raw.hs @@ -0,0 +1,26 @@ +{-# 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 diff --git a/src/System/Win32/SystemServices/Services/SERVICE_ACCEPT.hs b/src/System/Win32/SystemServices/Services/SERVICE_ACCEPT.hs new file mode 100644 --- /dev/null +++ b/src/System/Win32/SystemServices/Services/SERVICE_ACCEPT.hs @@ -0,0 +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 +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 new file mode 100644 --- /dev/null +++ b/src/System/Win32/SystemServices/Services/SERVICE_CONTROL.hs @@ -0,0 +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." diff --git a/src/System/Win32/SystemServices/Services/SERVICE_STATE.hs b/src/System/Win32/SystemServices/Services/SERVICE_STATE.hs new file mode 100644 --- /dev/null +++ b/src/System/Win32/SystemServices/Services/SERVICE_STATE.hs @@ -0,0 +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 diff --git a/src/System/Win32/SystemServices/Services/SERVICE_STATUS.hs b/src/System/Win32/SystemServices/Services/SERVICE_STATUS.hs new file mode 100644 --- /dev/null +++ b/src/System/Win32/SystemServices/Services/SERVICE_STATUS.hs @@ -0,0 +1,84 @@ +module System.Win32.SystemServices.Services.SERVICE_STATUS where + +import Control.Applicative +import Foreign +import System.Win32.Types + +import Control.Error + +import System.Win32.SystemServices.Services.SERVICE_ACCEPT +import System.Win32.SystemServices.Services.SERVICE_STATE +import System.Win32.SystemServices.Services.SERVICE_TYPE + +-- | Contains status information for a service. +data SERVICE_STATUS = SERVICE_STATUS + { serviceType :: SERVICE_TYPE + -- ^ The type of service. This binding only supports the WIN32_OWN_PROCESS + -- type. + , currentState :: SERVICE_STATE + -- ^ The current state of the service. + , controlsAccepted :: [SERVICE_ACCEPT] + -- ^ See 'SERVICE_ACCEPT' for details on this field. + , win32ExitCode :: DWORD + -- ^ The error code the service uses to report an error that occurs when + -- it is starting or stopping. To return an error code specific to the + -- service, the service must set this value to + -- 'eRROR_SERVICE_SPECIFIC_ERROR' to indicate that the + -- 'serviceSpecificExitCode' member contains the error code. The service + -- should set this value to 'nO_ERROR' when it is running and on normal + -- termination. + , serviceSpecificExitCode :: DWORD + -- ^ A service-specific error code that the service returns when an error + -- occurs while the service is starting or stopping. This value is + -- ignored unless the 'win32ExitCode' member is set to + -- 'eRROR_SERVICE_SPECIFIC_ERROR'. + -- + -- This binding does not support service-specific error codes. + , checkPoint :: DWORD + -- ^ The check-point value the service increments periodically to report + -- its progress during a lengthy start, stop, pause, or continue + -- operation. For example, the service should increment this value as it + -- completes each step of its initialization when it is starting up. The + -- user interface program that invoked the operation on the service uses + -- this value to track the progress of the service during a lengthy + -- operation. This value is not valid and should be zero when the + -- service does not have a start, stop, pause, or continue operation + -- pending. + , waitHint :: DWORD + -- ^ The estimated time required for a pending start, stop, pause, or + -- continue operation, in milliseconds. Before the specified amount of + -- time has elapsed, the service should make its next call to the + -- SetServiceStatus function with either an incremented dwCheckPoint + -- value or a change in 'currentState'. If the amount of time specified + -- by 'waitHint' passes, and 'checkPoint' has not been incremented or + -- 'currentState' has not changed, the service control manager or + -- service control program can assume that an error has occurred and the + -- service should be stopped. However, if the service shares a process + -- with other services, the service control manager cannot terminate the + -- service application because it would have to terminate the other + -- services sharing the process as well. + } deriving (Show) + +instance Storable SERVICE_STATUS where + sizeOf _ = 28 + alignment _ = 4 + peek ptr = SERVICE_STATUS <$> (runScript . peekServiceType) pST + <*> (runScript . peekServiceState) pCS <*> peekServiceAccept pCA + <*> peek pEC <*> peek pSSEC <*> peek pCP <*> peek pWH + where + pST = castPtr ptr + pCS = castPtr ptr `plusPtr` 4 + pCA = castPtr ptr `plusPtr` 8 + pEC = castPtr ptr `plusPtr` 12 + pSSEC = castPtr ptr `plusPtr` 16 + pCP = castPtr ptr `plusPtr` 20 + pWH = castPtr ptr `plusPtr` 24 + poke ptr (SERVICE_STATUS st cs ca ec ssec cp wh) = do + pokeServiceType (castPtr ptr) st + pokeServiceState (castPtr ptr `plusPtr` 4) cs + pokeServiceAccept (castPtr ptr `plusPtr` 8) ca + poke (castPtr ptr `plusPtr` 12) ec + poke (castPtr ptr `plusPtr` 16) ssec + poke (castPtr ptr `plusPtr` 20) cp + poke (castPtr ptr `plusPtr` 24) wh + diff --git a/src/System/Win32/SystemServices/Services/SERVICE_TABLE_ENTRY.hs b/src/System/Win32/SystemServices/Services/SERVICE_TABLE_ENTRY.hs new file mode 100644 --- /dev/null +++ b/src/System/Win32/SystemServices/Services/SERVICE_TABLE_ENTRY.hs @@ -0,0 +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 diff --git a/src/System/Win32/SystemServices/Services/SERVICE_TYPE.hs b/src/System/Win32/SystemServices/Services/SERVICE_TYPE.hs new file mode 100644 --- /dev/null +++ b/src/System/Win32/SystemServices/Services/SERVICE_TYPE.hs @@ -0,0 +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 diff --git a/src/System/Win32/SystemServices/Services/Types.hs b/src/System/Win32/SystemServices/Services/Types.hs new file mode 100644 --- /dev/null +++ b/src/System/Win32/SystemServices/Services/Types.hs @@ -0,0 +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