Wrapper.hs

{-# LANGUAGE CPP, ForeignFunctionInterface, ScopedTypeVariables
 #-}
module System.Win32.SystemServices.Wrapper
    ( Service(..)
    , defineService
    ) where

-- The 'catch' function from Control.Exception was included in the Prelude
-- until version 4.6
#if MIN_VERSION_base(4,6,0)
#else
import Prelude hiding ( catch )
#endif

import Control.Concurrent ( MVar, newEmptyMVar, putMVar, takeMVar )
import Control.Exception ( catch, throwIO, SomeException )
import System.Directory ( getTemporaryDirectory )
import System.FilePath ( (</>) )
import System.IO
    ( hSetBuffering, BufferMode(NoBuffering)
    , openFile, IOMode(WriteMode)
    , Handle, hPutStrLn
    )
import System.Win32.Services
    ( ServiceStatus(..), ServiceState(..)
    , ServiceControl(..), ServiceAccept(..), ServiceType(..)
    , setServiceStatus, startServiceCtrlDispatcher
    )
import System.Win32.Error ( ErrCode(..))
import System.Win32.Types ( HANDLE, DWORD )

data Service serviceState =
    Service {
          serviceName :: String
        , serviceStart :: Handle -> IO serviceState
        , serviceStop :: serviceState -> IO ()
    }

handler :: MVar () -> HANDLE -> ServiceControl -> IO Bool
handler stopSignal hStatus Stop = do
    setServiceStatus hStatus stopPending
    putMVar stopSignal ()
    return True
handler _ _ Interrogate = return True
handler _ _ _           = return False

running, stopPending, stopped :: ServiceStatus
running = ServiceStatus Win32OwnProcess Running [AcceptStop] Success 0 0 0
stopPending = running { currentState = StopPending
                      , controlsAccepted = []
                      , waitHint = 3000 }
stopped = running { currentState = Stopped
                  , controlsAccepted = []
                  , waitHint = 3000 }

logExceptions :: Handle -> IO a -> IO a
logExceptions h comp =
    comp `catch`
        \(e :: SomeException) -> do
            hPutStrLn h (show e)
            throwIO e

foreign import stdcall "GetCurrentProcessId" getCurrentProcessId :: IO DWORD

defineService :: Service serviceState -> IO ()
defineService svc = do
    pid <- getCurrentProcessId

    temp <- getTemporaryDirectory

    let logFile = temp </> ("service-debug-" ++ serviceName svc ++ "-" ++ show pid ++ ".log")

    debugH <- openFile logFile WriteMode
    hSetBuffering debugH NoBuffering

    stopSignal <- newEmptyMVar

    startServiceCtrlDispatcher
        (serviceName svc)
        3000
        (handler stopSignal)
        (\_ _ h ->
            logExceptions debugH $ do
                state <- serviceStart svc debugH
                setServiceStatus h running
                takeMVar stopSignal
                serviceStop svc state
                setServiceStatus h stopped
        )