unit Quick.Core.Extensions.Service.Windows;

System.SysUtils,

Windows,

Quick.Console,

{$IFNDEF FPC}

WinSvc,

{$ENDIF}

Registry,

Quick.Commons,

Quick.Core.Commandline,

Quick.Core.Extensions.Service.Abstractions;

DEF_SERVICENAME = 'QuickCoreService';

DEF_DISPLAYNAME = 'QuickCoreService';

NUM_OF_SERVICES = 2;

TSvcStatus = (ssStopped = SERVICE_STOPPED,

ssStopping = SERVICE_STOP_PENDING,

ssStartPending = SERVICE_START_PENDING,

ssRunning = SERVICE_RUNNING,

ssPaused = SERVICE_PAUSED);

TSvcStartType = (stAuto = SERVICE_AUTO_START,

stManual = SERVICE_DEMAND_START,

stDisabled = SERVICE_DISABLED);

TWindowsHostService = class(THostService)

private

fParameters : TServiceParameters;

fSCMHandle : SC_HANDLE;

fSvHandle : SC_HANDLE;

fServiceName : string;

fDisplayName : string;

fWaitForKeyOnExit : Boolean;

fLoadOrderGroup : string;

fDependencies : string;

fDesktopInteraction : Boolean;

fUserName : string;

fUserPass : string;

fStartType : TSvcStartType;

fFileName : string;

fSilent : Boolean;

fStatus : TSvcStatus;

fCanInstallWithOtherName : Boolean;

fAfterRemove : TSvcRemoveEvent;

procedure Execute;

procedure ReportSvcStatus(dwCurrentState, dwWin32ExitCode, dwWaitHint: DWORD);

procedure AddServiceDescription;

public

constructor Create;

destructor Destroy; override;

property DisplayName : string read fDisplayName write fDisplayName;

property LoadOrderGroup : string read fLoadOrderGroup write fLoadOrderGroup;

property Dependencies : string read fDependencies write fDependencies;

property DesktopInteraction : Boolean read fDesktopInteraction write fDesktopInteraction;

property UserName : string read fUserName write fUserName;

property UserPass : string read fUserPass write fUserPass;

property StartType : TSvcStartType read fStartType write fStartType;

property FileName : string read fFileName;

property Silent : Boolean read fSilent write fSilent;

property CanInstallWithOtherName : Boolean read fCanInstallWithOtherName write fCanInstallWithOtherName;

property Status : TSvcStatus read fStatus write fStatus;

property AfterRemove : TSvcRemoveEvent read fAfterRemove write fAfterRemove;

procedure Install; override;

procedure Remove; override;

function CheckParams : Boolean; override;

function InstallParamsPresent : Boolean;

function ConsoleParamPresent : Boolean;

function IsRunningAsService : Boolean; override;

function IsRunningAsConsole : Boolean;

procedure Start; override;

procedure Stop; override;

end;

ServiceStatus : TServiceStatus;

StatusHandle : SERVICE_STATUS_HANDLE;

ServiceTable : array [0..NUM_OF_SERVICES] of TServiceTableEntry;

ghSvcStopEvent: Cardinal;

AppService : TWindowsHostService;

constructor TWindowsHostService.Create;

i : Integer;

parm : string;

parameters : string;

fParameters := TServiceParameters.Create(False);

fServiceName := DEF_SERVICENAME;

fDisplayName := DEF_DISPLAYNAME;

fWaitForKeyOnExit := False;

fLoadOrderGroup := '';

fDependencies := '';

fDesktopInteraction := False;

UserName := '';

fUserPass := '';

fStartType := TSvcStartType.stAuto;

fFileName := ParamStr(0);

parameters := '';

for i := 1 to ParamCount - 1 do

begin

parm := ParamStr(i);

if (parm.ToLower <> '/install')

and (parm.ToLower <> '/remove')

and (not parm.ToLower.StartsWith('/instance:')) then

begin

parameters := parameters + ' ' + parm;

end;

end;

if not parameters.IsEmpty then fFileName := Format('"%s" %s',[fFilename,parameters]);

fSilent := True;

fStatus := TSvcStatus.ssStopped;

fCanInstallWithOtherName := False;

OnExecute := nil;

IsQuickServiceApp := True;

end;

destructor TWindowsHostService.Destroy;

OnStart := nil;

OnStop := nil;

OnExecute := nil;

if fSCMHandle <> 0 then CloseServiceHandle(fSCMHandle);

if fSvHandle <> 0 then CloseServiceHandle(fSvHandle);

if Assigned(fParameters) then fParameters.Free;

fParameters := nil;

inherited;

end;

procedure ServiceCtrlHandler(Control: DWORD); stdcall;

case Control of

SERVICE_CONTROL_STOP:

begin

AppService.Status := TSvcStatus.ssStopping;

SetEvent(ghSvcStopEvent);

ServiceStatus.dwCurrentState := SERVICE_STOP_PENDING;

SetServiceStatus(StatusHandle, ServiceStatus);

end;

SERVICE_CONTROL_PAUSE:

begin

AppService.Status := TSvcStatus.ssPaused;

ServiceStatus.dwcurrentstate := SERVICE_PAUSED;

SetServiceStatus(StatusHandle, ServiceStatus);

end;

SERVICE_CONTROL_CONTINUE:

begin

AppService.Status := TSvcStatus.ssRunning;

ServiceStatus.dwCurrentState := SERVICE_RUNNING;

SetServiceStatus(StatusHandle, ServiceStatus);

end;

SERVICE_CONTROL_INTERROGATE: SetServiceStatus(StatusHandle, ServiceStatus);

SERVICE_CONTROL_SHUTDOWN:

begin

AppService.Status := TSvcStatus.ssStopped;

AppService.Stop;

end;

end;

end;

procedure RegisterService(dwArgc: DWORD; var lpszArgv: PChar); stdcall;

ServiceStatus.dwServiceType := SERVICE_WIN32_OWN_PROCESS;

ServiceStatus.dwCurrentState := SERVICE_START_PENDING;

ServiceStatus.dwControlsAccepted := SERVICE_ACCEPT_STOP or SERVICE_ACCEPT_PAUSE_CONTINUE;

ServiceStatus.dwServiceSpecificExitCode := 0;

ServiceStatus.dwWin32ExitCode := 0;

ServiceStatus.dwCheckPoint := 0;

ServiceStatus.dwWaitHint := 0;

StatusHandle := RegisterServiceCtrlHandler(PChar(AppService.ServiceName), @ServiceCtrlHandler);

if StatusHandle <> 0 then

begin

AppService.ReportSvcStatus(SERVICE_RUNNING, NO_ERROR, 0);

try

AppService.Status := TSvcStatus.ssRunning;

AppService.Execute;

finally

AppService.ReportSvcStatus(SERVICE_STOPPED, NO_ERROR, 0);

end;

end;

end;

procedure TWindowsHostService.ReportSvcStatus(dwCurrentState, dwWin32ExitCode, dwWaitHint: DWORD);

//fill in the SERVICE_STATUS structure

ServiceStatus.dwCurrentState := dwCurrentState;

ServiceStatus.dwWin32ExitCode := dwWin32ExitCode;

ServiceStatus.dwWaitHint := dwWaitHint;

if dwCurrentState = SERVICE_START_PENDING then ServiceStatus.dwControlsAccepted := 0

else ServiceStatus.dwControlsAccepted := SERVICE_ACCEPT_STOP;

case (dwCurrentState = SERVICE_RUNNING) or (dwCurrentState = SERVICE_STOPPED) of

True: ServiceStatus.dwCheckPoint := 0;

False: ServiceStatus.dwCheckPoint := 1;

end;

//report service status to SCM

SetServiceStatus(StatusHandle,ServiceStatus);

end;

procedure TWindowsHostService.Start;

//initialize as console

if not IsRunningAsService then

begin

if Assigned(OnInitialize) then OnInitialize;

if Assigned(OnStart) then OnStart;

if Assigned(OnExecute) then OnExecute;

if WaitForKeyOnExit then ConsoleWaitForEnterKey;

end

else

begin //initialize as a service

if Assigned(OnInitialize) then OnInitialize;

ServiceTable[0].lpServiceName := PChar(ServiceName);

ServiceTable[0].lpServiceProc := @RegisterService;

ServiceTable[1].lpServiceName := nil;

ServiceTable[1].lpServiceProc := nil;

{$IFDEF FPC}

StartServiceCtrlDispatcher(@ServiceTable[0]);

{$ELSE}

StartServiceCtrlDispatcher(ServiceTable[0]);

{$ENDIF}

end;

end;

procedure TWindowsHostService.Stop;

if Assigned(OnStop) then OnStop;

end;

procedure TWindowsHostService.Execute;

//we have to do something or service will stop

ghSvcStopEvent := CreateEvent(nil,True,False,nil);

if ghSvcStopEvent = 0 then

begin

ReportSvcStatus(SERVICE_STOPPED,NO_ERROR,0);

Exit;

end;

if Assigned(OnStart) then OnStart;

//report running status when initialization is complete

ReportSvcStatus(SERVICE_RUNNING,NO_ERROR,0);

//perform work until service stops

while True do

begin

//external callback process

if Assigned(OnExecute) then OnExecute;

//check whether to stop the service.

WaitForSingleObject(ghSvcStopEvent,INFINITE);

ReportSvcStatus(SERVICE_STOPPED,NO_ERROR,0);

Exit;

end;

end;

procedure TWindowsHostService.Remove;

cRemoveMsg = 'Service "%s" removed successfully!';

SCManager: SC_HANDLE;

Service: SC_HANDLE;

SCManager := OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);

if SCManager = 0 then

Exit;

try

Service := OpenService(SCManager,PChar(ServiceName),SERVICE_ALL_ACCESS);

ControlService(Service,SERVICE_CONTROL_STOP,ServiceStatus);

DeleteService(Service);

CloseServiceHandle(Service);

if fSilent then Writeln(Format(cRemoveMsg,[ServiceName]))

else MessageBox(0,PChar(Format(cRemoveMsg,[ServiceName])),PChar(ServiceName),MB_ICONINFORMATION or MB_OK or MB_TASKMODAL or MB_TOPMOST);

finally

CloseServiceHandle(SCManager);

if Assigned(fAfterRemove) then fAfterRemove;

end;

end;

procedure TWindowsHostService.Install;

cInstallMsg = 'Service "%s" installed successfully!';

cSCMError = 'Error trying to open SC Manager (you need admin permissions?)';

servicetype : Cardinal;

svcloadgroup : PChar;

svcdependencies : PChar;

svcusername : PChar;

svcuserpass : PChar;

fSCMHandle := OpenSCManager(nil,nil,SC_MANAGER_ALL_ACCESS);

if fSCMHandle = 0 then

begin

if fSilent then Writeln(cSCMError)

else MessageBox(0,cSCMError,PChar(ServiceName),MB_ICONERROR or MB_OK or MB_TASKMODAL or MB_TOPMOST);

Exit;

end;

//service interacts with desktop

if fDesktopInteraction then servicetype := SERVICE_WIN32_OWN_PROCESS and SERVICE_INTERACTIVE_PROCESS

else servicetype := SERVICE_WIN32_OWN_PROCESS;

//service load order

if fLoadOrderGroup.IsEmpty then svcloadgroup := nil

else svcloadgroup := PChar(fLoadOrderGroup);

//service dependencies

if fDependencies.IsEmpty then svcdependencies := nil

else svcdependencies := PChar(fDependencies);

//service user name

if UserName.IsEmpty then svcusername := nil

else svcusername := PChar(UserName);

//service user password

if fUserPass.IsEmpty then svcuserpass := nil

else svcuserpass := PChar(fUserPass);

fSvHandle := CreateService(fSCMHandle,

PChar(ServiceName),

PChar(fDisplayName),

SERVICE_ALL_ACCESS,

servicetype,

Cardinal(fStartType),

SERVICE_ERROR_NORMAL,

PChar(fFileName),

svcloadgroup,

nil,

svcdependencies,

svcusername, //user

svcuserpass); //password

if fSvHandle <> 0 then

begin

AddServiceDescription;

if fSilent then Writeln(Format(cInstallMsg,[ServiceName]))

else MessageBox(0,PChar(Format(cInstallMsg,[ServiceName])),PChar(ServiceName),MB_ICONINFORMATION or MB_OK or MB_TASKMODAL or MB_TOPMOST);

end

else

begin

if fSilent then Writeln(cSCMError)

else MessageBox(0,cSCMError,PChar(ServiceName),MB_ICONERROR or MB_OK or MB_TASKMODAL or MB_TOPMOST);

Exit;

end;

end;

procedure TWindowsHostService.AddServiceDescription;

reg : TRegistry;

reg := TRegistry.Create(KEY_READ or KEY_WRITE);

try

reg.RootKey := HKEY_LOCAL_MACHINE;

if reg.OpenKey('\SYSTEM\CurrentControlSet\Services\' + ServiceName,False) then

begin

reg.WriteString('Description',Description);

reg.CloseKey;

end;

finally

reg.Free;

end;

end;

function TWindowsHostService.CheckParams : Boolean;

Result := False;

fParameters.Description := Description;

if ParamCount > 0 then

begin

fSilent := fParameters.Silent;

if fParameters.Install then

begin

if fCanInstallWithOtherName then

begin

if fParameters.ExistsParam('instance') then

begin

if fParameters.Instance.IsEmpty then raise Exception.Create('Service instance name not defined!');

ServiceName := fParameters.Instance;

fDisplayName := fParameters.Instance;

end;

end;

Install;

Result := True;

end

else if fParameters.Remove then

begin

if fCanInstallWithOtherName then

begin

if fParameters.ExistsParam('instance') then

begin

if fParameters.Instance.IsEmpty then raise Exception.Create('Service instance name not defined!');

ServiceName := fParameters.Instance;

fDisplayName := fParameters.Instance;

end;

end;

Remove;

Result := True;

end

else if fParameters.Console then Writeln('Forced console mode');

end;

//if fSkipRun then

//begin

// if Assigned(OnStop) then OnStop;

//Halt;

//end;

end;

function TWindowsHostService.ConsoleParamPresent : Boolean;

Result := fParameters.Console;

end;

function TWindowsHostService.InstallParamsPresent : Boolean;

Result := (fParameters.Install or fParameters.Remove or fParameters.Help);

end;

function TWindowsHostService.IsRunningAsService : Boolean;

Result := (IsService and not ConsoleParamPresent) and (not InstallParamsPresent);

end;

function TWindowsHostService.IsRunningAsConsole : Boolean;

Result := (not IsService) or (ConsoleParamPresent);

end;

AppService := TWindowsHostService.Create;

//if Assigned(AppService) then AppService.Free;

end.