Wrapper.hs

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

import Prelude hiding ( catch )

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.SystemServices.Services
    ( SERVICE_STATUS(..), SERVICE_STATE(..)
    , SERVICE_CONTROL(..), SERVICE_ACCEPT(..), SERVICE_TYPE(..)
    , setServiceStatus, startServiceCtrlDispatcher
    , nO_ERROR
    )
import System.Win32.Types ( HANDLE, DWORD )

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

handler :: MVar () -> HANDLE -> SERVICE_CONTROL -> IO Bool
handler stopSignal hStatus STOP = do
    setServiceStatus hStatus stopPending
    putMVar stopSignal ()
    return True
handler _ _ INTERROGATE = return True
handler _ _ _           = return False

running, stopPending, stopped :: SERVICE_STATUS
running = SERVICE_STATUS WIN32_OWN_PROCESS RUNNING [ACCEPT_STOP] nO_ERROR 0 0 0
stopPending = running { currentState = STOP_PENDING
                      , 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
        )