Permalink
Browse files

Switched to Win32-services package

  • Loading branch information...
1 parent ec631db commit 82edc20ca548163f48cecc7e77b7cf43ce5105f5 @jystic committed Apr 2, 2013
Showing with 69 additions and 185 deletions.
  1. +0 −14 cbits/service.c
  2. +65 −16 src/Main.hs
  3. +0 −152 src/System/Win32/Service.hs
  4. +4 −3 sudo4win.cabal
View
@@ -1,14 +0,0 @@
-#include <windows.h>
-
-BOOL svc_start_dispatcher(LPTSTR name, LPSERVICE_MAIN_FUNCTION proc)
-{
- SERVICE_TABLE_ENTRY table[2];
-
- table[0].lpServiceName = name;
- table[0].lpServiceProc = proc;
-
- table[1].lpServiceName = NULL;
- table[1].lpServiceProc = NULL;
-
- return StartServiceCtrlDispatcher(table);
-}
View
@@ -1,22 +1,71 @@
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
+
module Main (main) where
import Control.Concurrent
-import Data.IORef
-import System.Win32.Service
+import System.Win32.SystemServices.Services
+import System.Win32.Types
main :: IO ()
main = do
- (loop, stop) <- loopStop go
- service "sudo" loop stop
- where
- go = do appendFile "c:\\test.txt" "whee"
- threadDelay 1000000
-
-loopStop :: IO () -> IO (IO (), IO ())
-loopStop once = do
- ref <- newIORef False
- let stop = writeIORef ref True
- loop = do done <- readIORef ref
- if done then return ()
- else once >> loop
- return (loop, stop)
+ gState <- newMVar (1, SERVICE_STATUS WIN32_OWN_PROCESS
+ START_PENDING [] nO_ERROR 0 0 3000)
+ mStop <- newEmptyMVar
+ startServiceCtrlDispatcher "sudo4win" 3000
+ (svcCtrlHandler mStop gState)
+ (svcMain mStop gState)
+
+
+svcMain :: MVar () -> MVar (DWORD, SERVICE_STATUS) -> ServiceMainFunction
+svcMain mStop gState _ _ h = do
+ reportSvcStatus h RUNNING nO_ERROR 0 gState
+ appendFile "c:\\test.txt" "1"
+ threadDelay 1000000
+ appendFile "c:\\test.txt" "2"
+ threadDelay 1000000
+ appendFile "c:\\test.txt" "3"
+ threadDelay 1000000
+ appendFile "c:\\test.txt" "4"
+ threadDelay 1000000
+ appendFile "c:\\test.txt" "5"
+ takeMVar mStop
+ threadDelay 1000000
+ appendFile "c:\\test.txt" "."
+ threadDelay 1000000
+ appendFile "c:\\test.txt" "."
+ threadDelay 1000000
+ appendFile "c:\\test.txt" "."
+ threadDelay 1000000
+ appendFile "c:\\test.txt" "Stahp\n"
+ reportSvcStatus h STOPPED nO_ERROR 0 gState
+
+reportSvcStatus :: HANDLE -> SERVICE_STATE -> DWORD -> DWORD
+ -> MVar (DWORD, SERVICE_STATUS) -> IO ()
+reportSvcStatus hStatus state win32ExitCode waitHint gState = do
+ modifyMVar_ gState $ \(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 gState hStatus STOP = do
+ reportSvcStatus hStatus STOP_PENDING nO_ERROR 3000 gState
+ putMVar mStop ()
+ return True
+svcCtrlHandler _ _ _ INTERROGATE = return True
+svcCtrlHandler _ _ _ _ = return False
View
@@ -1,152 +0,0 @@
-{-# LANGUAGE ForeignFunctionInterface #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
-module System.Win32.Service (
- service
- ) where
-
-import Control.Applicative
-import Control.Exception
-import Control.Monad
-import Data.IORef
-import Foreign.Marshal
-import Foreign.Ptr
-import Foreign.Storable
-import System.Win32.Types
-
-------------------------------------------------------------------------
--- Types
-
-data Status =
- Stopped
- | StartPending
- | StopPending
- | Running
- | ContinuePending
- | PausePending
- | Paused
- deriving (Eq, Show)
-
-------------------------------------------------------------------------
--- Functions
-
-service :: String -> IO () -> IO () -> IO ()
-service name loop stop =
- withTString name $ \namePtr -> do
- procPtr <- toProcPtr (proc namePtr)
- failIfFalse_ "service" (c'svc_start_dispatcher namePtr procPtr)
- freeHaskellFunPtr procPtr
- where
- proc :: LPCTSTR -> ProcFun
- proc namePtr _ _ = do
- ref <- newIORef nullHANDLE
- handlerPtr <- toHandlerPtr (handler ref)
- h <- c'RegisterServiceCtrlHandler namePtr handlerPtr
- when (h /= nullHANDLE) $ do
- writeIORef ref h
- stopOnError h $ do
- setStatus h 0 Running
- loop
- setStatus h 0 Stopped
- freeHaskellFunPtr handlerPtr
-
- stopOnError h =
- handle (\(_::SomeException) -> setStatus h (-1) Stopped)
-
- handler :: IORef HANDLE -> HandlerFun
- handler ref x
- | x == 0x1 = stop'
- | x == 0x5 = stop'
- | otherwise = return ()
- where
- stop' = do
- h <- readIORef ref
- setStatus h 0 StopPending
- stop
-
-setStatus :: HANDLE -> DWORD -> Status -> IO ()
-setStatus h exitCode status =
- with newStatus $ \ptr -> do
- _ <- c'SetServiceStatus h ptr
- return ()
- where
- statusCode = case status of
- Stopped -> 1
- StartPending -> 2
- StopPending -> 3
- Running -> 4
- ContinuePending -> 5
- PausePending -> 6
- Paused -> 7
-
- newStatus = defaultStatus { dwCurrentState = statusCode
- , dwWin32ExitCode = exitCode }
-
-------------------------------------------------------------------------
--- FFI
-
-foreign import ccall "svc_start_dispatcher"
- c'svc_start_dispatcher :: LPTSTR -> FunPtr ProcFun -> IO Bool
-
--- SERVICE_STATUS_HANDLE RegisterServiceCtrlHandler(
--- LPCTSTR lpServiceName, LPHANDLER_FUNCTION lpHandlerProc);
-foreign import stdcall "windows.h RegisterServiceCtrlHandlerW"
- c'RegisterServiceCtrlHandler :: LPCTSTR -> FunPtr HandlerFun -> IO HANDLE
-
--- BOOL SetServiceStatus(
--- SERVICE_STATUS_HANDLE hServiceStatus, LPSERVICE_STATUS lpServiceStatus);
-foreign import stdcall "windows.h SetServiceStatus"
- c'SetServiceStatus :: HANDLE -> Ptr SERVICE_STATUS -> IO BOOL
-
--- void ServiceMain(DWORD dwArgc, LPTSTR *lpszArgv);
-type ProcFun = DWORD -> Ptr LPTSTR -> IO ()
-foreign import ccall "wrapper"
- toProcPtr :: ProcFun -> IO (FunPtr ProcFun)
-
--- void Handler(DWORD fdwControl);
-type HandlerFun = DWORD -> IO ()
-foreign import ccall "wrapper"
- toHandlerPtr :: HandlerFun -> IO (FunPtr HandlerFun)
-
-------------------------------------------------------------------------
-
-data SERVICE_STATUS = SERVICE_STATUS {
- dwServiceType :: DWORD
- , dwCurrentState :: DWORD
- , dwControlsAccepted :: DWORD
- , dwWin32ExitCode :: DWORD
- , dwServiceSpecificExitCode :: DWORD
- , dwCheckPoint :: DWORD
- , dwWaitHint :: DWORD
- }
-
-defaultStatus :: SERVICE_STATUS
-defaultStatus = SERVICE_STATUS {
- dwServiceType = 0x10 -- SERVICE_WIN32_OWN_PROCESS
- , dwCurrentState = 0x2 -- SERVICE_START_PENDING
- , dwControlsAccepted = 0x5 -- SERVICE_ACCEPT_STOP | SERVICE_ACCEPT_SHUTDOWN
- , dwWin32ExitCode = 0
- , dwServiceSpecificExitCode = 0
- , dwCheckPoint = 0
- , dwWaitHint = 0
- }
-
-instance Storable SERVICE_STATUS where
- sizeOf _ = 28
- alignment _ = 4
- peek ptr = SERVICE_STATUS
- <$> peek (castPtr ptr)
- <*> peek (castPtr ptr `plusPtr` 4)
- <*> peek (castPtr ptr `plusPtr` 8)
- <*> peek (castPtr ptr `plusPtr` 12)
- <*> peek (castPtr ptr `plusPtr` 16)
- <*> peek (castPtr ptr `plusPtr` 20)
- <*> peek (castPtr ptr `plusPtr` 24)
- poke ptr (SERVICE_STATUS a b c d e f g) = do
- poke (castPtr ptr) a
- poke (castPtr ptr `plusPtr` 4) b
- poke (castPtr ptr `plusPtr` 8) c
- poke (castPtr ptr `plusPtr` 12) d
- poke (castPtr ptr `plusPtr` 16) e
- poke (castPtr ptr `plusPtr` 20) f
- poke (castPtr ptr `plusPtr` 24) g
View
@@ -13,10 +13,11 @@ cabal-version: >=1.6
Executable sudo4win
main-is: Main.hs
hs-source-dirs: src
- c-sources: cbits/service.c
build-depends:
- base == 4.5.*
- , Win32 == 2.2.*
+ base == 4.*
+ , Win32 == 2.3.*
+ , Win32-services == 0.2.*
ghc-options: -Wall -threaded
+ ld-options: -enable-stdcall-fixup

0 comments on commit 82edc20

Please sign in to comment.