depend on Win32-errors

All use of nO_ERROR has been replaced by Success from the Win32-errors
package. The ServiceStatus record type now uses ErrCode from
Win32-errors to keep track of the return code field of a SERVICE_STATUS
struct.

All use of the eRROR_CALL_NOT_IMPLEMENTED has been replaced by
CallNotImplemented from the Win32-errors package.

All use of eRROR_SERVICE_SPECIFIC_ERROR have been replaced by
ServiceSpecificError from the Win32-errors package.

The setServiceStatus function may now throw a Win32Exception depending
on the return value of the internal Win32 call.

The startServiceCtrlDispatcher function may now throw a Win32Exception
depending on the return value of the internal Win32 call.

The queryServiceStatus function may now throw a Win32Exception depending
on the return value of the internal Win32 call.

The registerServiceCtrlHandlerEx function may now throw a Win32Exception
depending on the return value of the internal Win32 call.

Include Win32 and Win32-errors names in Import module

Win32-services.cabal

@@ -108,6 +108,7 @@ source-repository head
 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

src/Import.hs

@@ -11,7 +11,11 @@ import Control.Applicative as X
 #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

@@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 module System.Win32.Services
     ( HandlerFunction
     , ServiceMainFunction
@@ -6,8 +8,6 @@ module System.Win32.Services
     , ServiceState (..)
     , ServiceStatus (..)
     , ServiceType (..)
-    , nO_ERROR
-    , eRROR_SERVICE_SPECIFIC_ERROR
     , queryServiceStatus
     , setServiceStatus
     , startServiceCtrlDispatcher
@@ -51,11 +51,16 @@ queryServiceStatus :: HANDLE
     -- SERVICE_QUERY_STATUS access right. For more information, see Service
     -- Security and Access Rights.
     -> IO ServiceStatus
-    -- ^ This function will raise an exception if the Win32 call returned an
-    -- error condition.
+    -- ^ 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_ (unwords ["QueryServiceStatus"])
-        $ c_QueryServiceStatus h pStatus
+    failIfFalse_ "QueryServiceStatus" $ c_QueryServiceStatus h pStatus
     peek pStatus
 
 -- | Register an handler function to be called whenever the operating system
@@ -74,14 +79,18 @@ registerServiceCtrlHandlerEx :: String
     -- messages. Behind the scenes this is translated into a "HandlerEx" type
     -- handler.
     -> IO (HANDLE, FunPtr HANDLER_FUNCTION_EX)
-    -- ^ The returned handle may be used in calls to SetServiceStatus. For
-    -- convenience Handler functions also receive a handle for the service.
+    -- ^ 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 (unwords ["RegisterServiceCtrlHandlerEx", str])
+    h <- failIfNull "RegisterServiceCtrlHandlerEx"
         $ c_RegisterServiceCtrlHandlerEx lptstr fpHandler nullPtr
     return (h, fpHandler)
 
@@ -95,12 +104,17 @@ setServiceStatus :: HANDLE
     -- ^ 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.
+    -- ^ 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 -> do
-    failIfFalse_ (unwords ["SetServiceStatus", show h, show status])
-        $ c_SetServiceStatus h pStatus
+    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
@@ -132,14 +146,28 @@ startServiceCtrlDispatcher :: String
     -- 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.
+    -- ^ 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_ (unwords ["StartServiceCtrlDispatcher", name]) $ do
-    c_StartServiceCtrlDispatcher pSTE
+    failIfFalse_ "StartServiceCtrlDispatcher"
+    $ c_StartServiceCtrlDispatcher pSTE
 
 toSMF :: ServiceMainFunction -> HandlerFunction -> DWORD -> IO SERVICE_MAIN_FUNCTION
 toSMF f handler wh = return $ \len pLPTSTR -> do
@@ -148,7 +176,7 @@ toSMF f handler wh = return $ \len pLPTSTR -> do
     -- MSDN guarantees args will have at least 1 member.
     let name = head args
     (h, fpHandler) <- registerServiceCtrlHandlerEx name handler
-    setServiceStatus h $ ServiceStatus Win32OwnProcess StartPending [] nO_ERROR 0 0 wh
+    setServiceStatus h $ ServiceStatus Win32OwnProcess StartPending [] Success 0 0 wh
     f name (tail args) h
     freeHaskellFunPtr fpHandler
 
@@ -161,11 +189,11 @@ toHandlerEx h f = \dwControl _ _ _ ->
       Right control -> do
           handled <- f h control
           case control of
-            Interrogate -> return nO_ERROR
+            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 nO_ERROR
-                                     else eRROR_CALL_NOT_IMPLEMENTED
-      Left _ -> return eRROR_CALL_NOT_IMPLEMENTED
+            _ -> return $ if handled then toDWORD Success
+                                     else toDWORD CallNotImplemented
+      Left _ -> return $ toDWORD CallNotImplemented

src/System/Win32/Services/State.hs

@@ -1,23 +1,11 @@
 module System.Win32.Services.State
     ( ServiceState (..)
-    , nO_ERROR
-    , eRROR_CALL_NOT_IMPLEMENTED
-    , eRROR_SERVICE_SPECIFIC_ERROR
     ) 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 ServiceState = ContinuePending | PausePending | Paused | Running
     | StartPending | StopPending | Stopped

src/System/Win32/Services/Status.hs

@@ -16,19 +16,19 @@ data ServiceStatus = ServiceStatus
     -- ^ The current state of the service.
     , controlsAccepted        :: [ServiceAccept]
     -- ^ See 'ServiceAccept' for details on this field.
-    , win32ExitCode           :: DWORD
+    , 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
-    --   'eRROR_SERVICE_SPECIFIC_ERROR' to indicate that the
+    --   'E.ServiceSpecificError' 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
+    --   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
-    -- 'eRROR_SERVICE_SPECIFIC_ERROR'.
+    -- 'E.ServiceSpecificError'.
     --
     -- This binding does not support service-specific error codes.
     , checkPoint              :: DWORD
@@ -76,9 +76,8 @@ instance Storable ServiceStatus where
     poke (pCP ptr) cp
     poke (pWH ptr) wh
 
-pCA, pEC, pSSEC, pCP, pWH :: Ptr ServiceStatus -> Ptr DWORD
+pCA, pSSEC, pCP, pWH :: Ptr ServiceStatus -> Ptr DWORD
 pCA   = (`plusPtr` 8)  . castPtr
-pEC   = (`plusPtr` 12) . castPtr
 pSSEC = (`plusPtr` 16) . castPtr
 pCP   = (`plusPtr` 20) . castPtr
 pWH   = (`plusPtr` 24) . castPtr
@@ -90,3 +89,6 @@ pST = castPtr
 pCS :: Ptr ServiceStatus -> Ptr ServiceState
 {-# INLINE pCS #-}
 pCS = (`plusPtr` 4)  . castPtr
+
+pEC :: Ptr ServiceStatus -> Ptr E.ErrCode
+pEC   = (`plusPtr` 12) . castPtr