packages feed

Win32-services 0.2.5.1 → 0.3

raw patch · 21 files changed

+654/−640 lines, 21 filesdep +Win32-errors

Dependencies added: Win32-errors

Files

Win32-services.cabal view
@@ -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   &#x20;   mStop <- newEmptyMVar@@ -55,16 +55,16 @@   &#x20;       takeMVar mStop   &#x20;       setServiceStatus h stopped   .-  handler mStop hStatus STOP = do+  handler mStop hStatus Stop = do   &#x20;   setServiceStatus hStatus stopPending   &#x20;   putMVar mStop ()   &#x20;   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
examples/official.hs view
@@ -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
examples/simple.hs view
@@ -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
src/Import.hs view
@@ -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
+ src/System/Win32/Services.hs view
@@ -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
+ src/System/Win32/Services/Accept.hs view
@@ -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
+ src/System/Win32/Services/Control.hs view
@@ -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."
+ src/System/Win32/Services/Raw.hs view
@@ -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
+ src/System/Win32/Services/State.hs view
@@ -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
+ src/System/Win32/Services/Status.hs view
@@ -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
+ src/System/Win32/Services/TableEntry.hs view
@@ -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
+ src/System/Win32/Services/Type.hs view
@@ -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
− src/System/Win32/SystemServices/Services.hs 
@@ -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
− src/System/Win32/SystemServices/Services/Raw.hs 
@@ -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
− src/System/Win32/SystemServices/Services/SERVICE_ACCEPT.hs 
@@ -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
− src/System/Win32/SystemServices/Services/SERVICE_CONTROL.hs 
@@ -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."
− src/System/Win32/SystemServices/Services/SERVICE_STATE.hs 
@@ -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
− src/System/Win32/SystemServices/Services/SERVICE_STATUS.hs 
@@ -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
− src/System/Win32/SystemServices/Services/SERVICE_TABLE_ENTRY.hs 
@@ -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
− src/System/Win32/SystemServices/Services/SERVICE_TYPE.hs 
@@ -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
− src/System/Win32/SystemServices/Services/Types.hs 
@@ -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