Win32-services 0.3 → 0.4.0.1
raw patch · 8 files changed
Files
- Setup.hs +2/−2
- Win32-services.cabal +40/−10
- changelog +23/−0
- examples/official.hs +7/−7
- examples/simple.hs +4/−3
- src/System/Win32/Services.hs +6/−3
- src/System/Win32/Services/Raw.hs +15/−6
- src/System/Win32/Services/TableEntry.hs +24/−0
Setup.hs view
@@ -1,2 +1,2 @@-import Distribution.Simple -main = defaultMain +import Distribution.Simple+main = defaultMain
Win32-services.cabal view
@@ -1,22 +1,22 @@ name: Win32-services category: System-version: 0.3-cabal-version: >= 1.16+version: 0.4.0.1+cabal-version: 1.16 build-type: Simple author: Michael Steele maintainer: Michael Steele <mikesteele81@gmail.com>-copyright: Copyright 2011-2015 Michael Steele+copyright: Copyright 2011-2018 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.6.3, GHC == 7.8.3, GHC == 7.10.1+tested-with: GHC == 7.6.3, GHC == 7.8.3, GHC == 7.10.1, GHC == 8.2.2, GHC == 8.4.3, GHC == 8.6.5 stability: provisional synopsis: Windows service applications description: This package provides a partial binding to the Win32 System Services API. It makes it easy to write Windows service applications using- Haskell. _Only 32-bit versions of GHC are supported at this time._+ Haskell. This version supports both 32-bit and 64-bit versions of GHC. . The binding is partial. Here are a few ways in which it differs from the official API:@@ -88,8 +88,11 @@ . Installation Notes: .- Depending on which version of Windows and the Windows SDK you are using the- .cabal file will need to be modified before installing. A simple `cabal+ Depending on which version of GHC you are using you may also need to add+ a extra-lib-dirs directive. In GHC version 8.4.3 it works out of the box with+ the libadvapi32.a file in ...\\mingw\\x86_64-w64-mingw32\\lib.+ For older version you need to use a version from a Windows SDK. Your+ .cabal file will then need to be modified before installing. A simple `cabal install Win32-services` may not work. For example, If you are building on Windows 8 64-bit with the Windows 8 SDK the 'extra-lib-dirs' field will need to be changed to read as follows:@@ -97,6 +100,16 @@ @ Extra-Lib-Dirs: \"C:\\\\Program Files (x86)\\\\Windows Kits\\\\8.0\\\\Lib\\\\win8\\\\um\\\\x86\" @+ .+ If building with stack an option is to set it in stack.yaml.+ For example with the Windows 10 SDK installed with Build Tools for Visual Studio 2017:+ .+ @+ extra-lib-dirs:+ - C:\\Program Files (x86)\\Windows Kits\\10\\Lib\\10.0.15063.0\\um\\x64+ @+ .+ extra-source-files: changelog examples/*.hs@@ -106,15 +119,18 @@ location: git://github.com/mikesteele81/win32-services.git library- build-depends: base >= 4.5 && < 4.9- , Win32 >= 2.2 && < 2.4+ build-depends: base >= 4.5 && < 5.0+ , Win32 >= 2.2 && < 2.9 , Win32-errors >= 0.2 && < 0.3 default-language: Haskell2010 ghc-options: -Wall hs-source-dirs: src Exposed-Modules: System.Win32.Services Extra-Libraries: Advapi32- Extra-Lib-Dirs: c:\Windows\System32+ -- Extra-Lib-Dirs: "C:\\Program Files (x86)\\Windows Kits\\8.0\\Lib\\win8\\um\\x86"+ -- Extra-Lib-Dirs: "C:\\Program Files (x86)\\Windows Kits\\8.1\\Lib\\winv6.3\\um\\x64"+ -- Extra-Lib-Dirs: "C:\\Program Files (x86)\\Windows Kits\\10\\Lib\\10.0.15063.0\\um\\x64\\AdvAPI32.Lib"+ -- Extra-Lib-Dirs: c:\Windows\System32 other-modules: Import , System.Win32.Services.Raw@@ -124,3 +140,17 @@ , System.Win32.Services.Status , System.Win32.Services.TableEntry , System.Win32.Services.Type++-- executable SimpleExample+-- hs-source-dirs: examples+-- main-is: simple.hs+-- ghc-options: -threaded -rtsopts -with-rtsopts=-N+-- build-depends: base, Win32-services, Win32-errors+-- default-language: Haskell2010+--+-- executable OfficialExample+-- hs-source-dirs: examples+-- main-is: official.hs+-- ghc-options: -threaded -rtsopts -with-rtsopts=-N -eventlog+-- build-depends: base, Win32-services, Win32, Win32-errors+-- default-language: Haskell2010
changelog view
@@ -1,3 +1,26 @@+# 0.4 series + +## 0.4.0.1 + +* Update library dependencies to support GHC 8.6.5 + +## 0.4 + +* First released version that works for 64-bit GHC. + Before it only worked with 32-bit GHC. + +# 0.3 series + +## 0.3.1 + +* Make it work with 64-bit GHC. + +* Update examples, to use ErrCode and Success from System.Win32.Error + +## 0.3 + +* Bumped the version number. + # 0.2 series ## 0.2.5.1
examples/official.hs view
@@ -3,20 +3,21 @@ import Control.Concurrent.MVar import System.Win32.Services import System.Win32.Types+import qualified System.Win32.Error as E main :: IO () main = do gState <- newMVar (1, ServiceStatus Win32OwnProcess- StartPending [] nO_ERROR 0 0 3000)+ StartPending [] E.Success 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 E.Success 0 gState takeMVar mStop- reportSvcStatus h Stopped nO_ERROR 0 gState+ reportSvcStatus h Stopped E.Success 0 gState -reportSvcStatus :: HANDLE -> ServiceState -> DWORD -> DWORD+reportSvcStatus :: HANDLE -> ServiceState -> E.ErrCode -> DWORD -> MVar (DWORD, ServiceStatus) -> IO () reportSvcStatus hStatus state win32ExitCode waitHint mState = do modifyMVar_ mState $ \(checkPoint, svcStatus) -> do@@ -28,7 +29,7 @@ return state' nextState :: (DWORD, ServiceStatus) -> (DWORD, ServiceStatus)-nextState (checkPoint, svcStatus) = case (currentState svcStatus) of +nextState (checkPoint, svcStatus) = case (currentState svcStatus) of StartPending -> (checkPoint + 1, svcStatus { controlsAccepted = [], checkPoint = checkPoint + 1 }) Running -> (checkPoint, svcStatus@@ -41,9 +42,8 @@ svcCtrlHandler :: MVar () -> MVar (DWORD, ServiceStatus) -> HandlerFunction svcCtrlHandler mStop mState hStatus Stop = do- reportSvcStatus hStatus StopPending nO_ERROR 3000 mState+ reportSvcStatus hStatus StopPending E.Success 3000 mState putMVar mStop () return True svcCtrlHandler _ _ _ Interrogate = return True svcCtrlHandler _ _ _ _ = return False-
examples/simple.hs view
@@ -2,6 +2,7 @@ import Control.Concurrent.MVar import System.Win32.Services+import qualified System.Win32.Error as E main = do mStop <- newEmptyMVar@@ -17,6 +18,6 @@ handler _ _ Interrogate = return True handler _ _ _ = return False -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+running = ServiceStatus Win32OwnProcess Running [AcceptStop] E.Success 0 0 0+stopped = ServiceStatus Win32OwnProcess Stopped [] E.Success 0 0 0+stopPending = ServiceStatus Win32OwnProcess StopPending [AcceptStop] E.Success 0 0 0
src/System/Win32/Services.hs view
@@ -170,15 +170,18 @@ $ 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+toSMF f handler wh = return $ \argc argv -> do+ args <- convertToListOfStrings argc argv -- 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+ where convertToListOfStrings length' pLPTSTR = do+ lptstrx <- peekArray (fromIntegral length') pLPTSTR+ mapM peekTString lptstrx+ -- This was originally written with older style handle functions in mind. -- I'm now using HandlerEx style functions, and need to add support for
src/System/Win32/Services/Raw.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE CPP #-} module System.Win32.Services.Raw where @@ -6,28 +7,36 @@ import System.Win32.Services.Status import System.Win32.Services.TableEntry +#if defined(i386_HOST_ARCH)+# define WINDOWS_CCONV stdcall+#elif defined(x86_64_HOST_ARCH)+# define WINDOWS_CCONV ccall+#else+# error Unknown mingw32 arch+#endif+ type HANDLER_FUNCTION_EX = DWORD -> DWORD -> Ptr () -> Ptr () -> IO DWORD -foreign import stdcall "wrapper"+foreign import WINDOWS_CCONV "wrapper" smfToFunPtr :: SERVICE_MAIN_FUNCTION -> IO (FunPtr SERVICE_MAIN_FUNCTION) -foreign import stdcall "wrapper"+foreign import WINDOWS_CCONV "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"+foreign import WINDOWS_CCONV "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"+foreign import WINDOWS_CCONV "windows.h RegisterServiceCtrlHandlerExW" c_RegisterServiceCtrlHandlerEx :: LPTSTR -> FunPtr HANDLER_FUNCTION_EX -> Ptr () -> IO HANDLE -foreign import stdcall "windows.h SetServiceStatus"+foreign import WINDOWS_CCONV "windows.h SetServiceStatus" c_SetServiceStatus :: HANDLE -> Ptr ServiceStatus -> IO BOOL -foreign import stdcall "windows.h StartServiceCtrlDispatcherW"+foreign import WINDOWS_CCONV "windows.h StartServiceCtrlDispatcherW" c_StartServiceCtrlDispatcher :: Ptr ServiceTableEntry -> IO BOOL
src/System/Win32/Services/TableEntry.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE CPP #-}+ module System.Win32.Services.TableEntry where import Import@@ -9,6 +11,8 @@ , serviceProc :: FunPtr SERVICE_MAIN_FUNCTION } +#if defined(i386_HOST_ARCH)+ instance Storable ServiceTableEntry where sizeOf _ = 8 alignment _ = 4@@ -22,6 +26,26 @@ where pServiceName = castPtr ptr pServiceProc = castPtr ptr `plusPtr` 4++#elif defined(x86_64_HOST_ARCH)++instance Storable ServiceTableEntry where+ sizeOf _ = 16+ alignment _ = 8+ peek ptr = ServiceTableEntry <$> peek pServiceName <*> peek pServiceProc+ where+ pServiceName = castPtr ptr+ pServiceProc = castPtr ptr `plusPtr` 8+ poke ptr ste = do+ poke pServiceName . serviceName $ ste+ poke pServiceProc . serviceProc $ ste+ where+ pServiceName = castPtr ptr+ pServiceProc = castPtr ptr `plusPtr` 8++#else+# error Unsupported architecture+#endif nullSTE :: ServiceTableEntry nullSTE = ServiceTableEntry nullPtr nullFunPtr