packages feed

Win32-services (empty) → 0.1

raw patch · 14 files changed

+790/−0 lines, 14 filesdep +Win32dep +basedep +errorssetup-changed

Dependencies added: Win32, base, errors

Files

+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple
+main = defaultMain
+ Win32-services.cabal view
@@ -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 <mikesteele81@gmail.com>+copyright:      Copyright (C) 2011-2013 Michael Steele+homepage:       http://github.com/mikesteele81/win32-services+bug-reports:    http://github.com/mikesteele81/win32-services/issues+license:        BSD3+license-file:   LICENSE+tested-with:    GHC == 7.4.2+stability:      provisional+synopsis:       Windows service applications+description:+  This package provides a partial binding to the Win32 System Services+  API. It's now possible to write Windows service applications using+  Haskell.+  .+  The binding is partial. Here are a few ways in which it differs from the+  official API:+  .+  * Only services running within their own process are supported. These are+  processes of the 'WIN32_OWN_PROCESS' type.+  .+  * In cases where multiple versions of the same function exist (for+  compatibility), this binding only offers one of them.+  .+  * None of the extended control codes are supported. Handlers you write will+  automatically report this to the operating system when such controls are+  received.+  .+  * Only facilities for writing services are supported; not controlling them.+  .+  Effort has been made to simplify using the API without hiding what is+  happening behind the scenes. Users are encouraged to read Microsoft's+  documentation under 'Dev Center - Desktop > Docs > Desktop app development+  documentation > System Services > Services'. The official example has been+  ported to Haskell. This can be found in the 'examples' directory of the+  source tree.+  .+  /Simple Example and Usage/+  .+  @+  module Main where+  .+  import Control.Concurrent.MVar+  import System.Win32.SystemServices.Services+  .+  main = startServiceCtrlDispatcher \"Test\" $ \name _ -> do+  &#x20;   mStop <- newEmptyMVar+  &#x20;   hStatus <- registerServiceCtrlHandlerEx name $ handler mStop+  &#x20;   setServiceStatus hStatus running+  &#x20;   takeMVar mStop+  &#x20;   setServiceStatus hStatus stopped+  .+  handler mStop hStatus STOP = do+  &#x20;   setServiceStatus hStatus stopPending+  &#x20;   putMVar mStop ()+  &#x20;   return True+  handler _ _ INTERROGATE = return True+  handler _ _ _           = return False+  .+  stopped = SERVICE_STATUS WIN32_OWN_PROCESS STOPPED [] nO_ERROR 0 0 0+  stopPending = stopped &#x7b; currentState = STOP_PENDING+  &#x20;                     , waitHint = 3000 &#x7d;+  running = stopped &#x7b; currentState = RUNNING+  &#x20;                 , controlsAccepted = [ACCEPT_STOP] &#x7d;+  @+  .+  @+  C:\programming\test\>ghc --make -threaded Main.hs+  [1 of 1] Compiling Main             ( Main.hs, Main.o )+  Linking Main.exe ...+  \<linker warnings omitted\>+  C:\\programming\\test\>copy Main.exe c:\\svc\\Test.exe+      1 file(s) copied.+  @+  .+  Execute the following from an elevated command prompt to register the+  service:+  .+  @+  C:\\svc\>sc create Test binPath= c:\\svc\\Test.exe+  [SC] CreateService SUCCESS+  @+  .+  The service can now be started and stopped from the services console.++extra-source-files: examples/*.hs++source-repository head+  type: git+  location: git://github.com/mikesteele81/win32-services.git++library+  build-depends: base             >= 4.5 && < 4.6+               , errors+               , Win32+  default-language: Haskell2010+  ghc-options:     -Wall+  hs-source-dirs: src+  Exposed-Modules: System.Win32.SystemServices.Services+  Extra-Libraries: Advapi32+  other-modules: System.Win32.SystemServices.Services.SERVICE_STATUS+               , System.Win32.SystemServices.Services.Raw+               , System.Win32.SystemServices.Services.SERVICE_TABLE_ENTRY+               , System.Win32.SystemServices.Services.Types+               , System.Win32.SystemServices.Services.SERVICE_ACCEPT+               , System.Win32.SystemServices.Services.SERVICE_CONTROL+               , System.Win32.SystemServices.Services.SERVICE_STATE+               , System.Win32.SystemServices.Services.SERVICE_TYPE
+ examples/official.hs view
@@ -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
+ examples/simple.hs view
@@ -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] }
+ src/System/Win32/SystemServices/Services.hs view
@@ -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
+ src/System/Win32/SystemServices/Services/Raw.hs view
@@ -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
+ src/System/Win32/SystemServices/Services/SERVICE_ACCEPT.hs view
@@ -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
+ src/System/Win32/SystemServices/Services/SERVICE_CONTROL.hs view
@@ -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."
+ src/System/Win32/SystemServices/Services/SERVICE_STATE.hs view
@@ -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
+ src/System/Win32/SystemServices/Services/SERVICE_STATUS.hs view
@@ -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+
+ src/System/Win32/SystemServices/Services/SERVICE_TABLE_ENTRY.hs view
@@ -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
+ src/System/Win32/SystemServices/Services/SERVICE_TYPE.hs view
@@ -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
+ src/System/Win32/SystemServices/Services/Types.hs view
@@ -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