diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,2 @@ -import Distribution.Simple -main = defaultMain +import Distribution.Simple +main = defaultMain diff --git a/Win32-services.cabal b/Win32-services.cabal --- a/Win32-services.cabal +++ b/Win32-services.cabal @@ -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 -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 diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -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 diff --git a/examples/official.hs b/examples/official.hs --- a/examples/official.hs +++ b/examples/official.hs @@ -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 - diff --git a/examples/simple.hs b/examples/simple.hs --- a/examples/simple.hs +++ b/examples/simple.hs @@ -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 diff --git a/src/System/Win32/Services.hs b/src/System/Win32/Services.hs --- a/src/System/Win32/Services.hs +++ b/src/System/Win32/Services.hs @@ -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 diff --git a/src/System/Win32/Services/Raw.hs b/src/System/Win32/Services/Raw.hs --- a/src/System/Win32/Services/Raw.hs +++ b/src/System/Win32/Services/Raw.hs @@ -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 diff --git a/src/System/Win32/Services/TableEntry.hs b/src/System/Win32/Services/TableEntry.hs --- a/src/System/Win32/Services/TableEntry.hs +++ b/src/System/Win32/Services/TableEntry.hs @@ -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