QuickLib/Quick.AppService.pas

{ ***************************************************************************

  Copyright (c) 2016-2017 Kike Pérez

  Unit        : Quick.AppService
  Description : Allow run app as console or service
  Author      : Kike Pérez
  Version     : 1.0
  Created     : 14/09/2017
  Modified    : 05/10/2017

  This file is part of QuickLib: https://github.com/exilon/QuickLib

 ***************************************************************************

  Licensed under the Apache License, Version 2.0 (the "License");
  you may not use this file except in compliance with the License.
  You may obtain a copy of the License at

  http://www.apache.org/licenses/LICENSE-2.0

  Unless required by applicable law or agreed to in writing, software
  distributed under the License is distributed on an "AS IS" BASIS,
  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
  See the License for the specific language governing permissions and
  limitations under the License.

 *************************************************************************** }

unit Quick.AppService;

{$i QuickLib.inc}

interface

{$IFNDEF FPC}
{$IFDEF DELPHI2010_UP}
  {$RTTI EXPLICIT METHODS([]) PROPERTIES([]) FIELDS([])}
  {$WEAKLINKRTTI ON}
{$ENDIF}
{$ENDIF}

uses
  {$IFDEF MSWINDOWS}
  Windows,
  {$ENDIF}
  SysUtils,
  {$IFNDEF FPC}
  WinSvc,
  {$ENDIF}
  Quick.Commons;

const
  DEF_SERVICENAME = 'QuickAppService';
  DEF_DISPLAYNAME = 'QuickAppService';
  NUM_OF_SERVICES = 2;

type

  TSvcStatus = (ssStopped = SERVICE_STOPPED,
                ssStopping = SERVICE_STOP_PENDING,
                ssStartPending = SERVICE_START_PENDING,
                ssRunning = SERVICE_RUNNING,
                ssPaused = SERVICE_PAUSED);

  TSvcInitializeEvent = procedure of object;
  {$IFDEF FPC}
  TSvcAnonMethod = procedure of object;
  {$ELSE}
  TSvcAnonMethod = reference to procedure;
  {$ENDIF}
  TSvcRemoveEvent = procedure of object;

  TAppService = class
  private
    fSCMHandle : SC_HANDLE;
    fSvHandle : SC_HANDLE;
    fServiceName : string;
    fDisplayName : string;
    fFileName : string;
    fSilent : Boolean;
    fStatus : TSvcStatus;
    fCanInstallWithOtherName : Boolean;
    fOnInitialize : TSvcInitializeEvent;
    fOnStart : TSvcAnonMethod;
    fOnStop : TSvcAnonMethod;
    fOnExecute : TSvcAnonMethod;
    fAfterRemove : TSvcRemoveEvent;
    procedure ReportSvcStatus(dwCurrentState, dwWin32ExitCode, dwWaitHint: DWORD);
    procedure Execute;
    procedure Help;
    procedure DoStop;
  public
    constructor Create;
    destructor Destroy; override;
    property ServiceName : string read fServiceName write fServiceName;
    property DisplayName : string read fDisplayName write fDisplayName;
    property FileName : string read fFileName write fFileName;
    property Silent : Boolean read fSilent write fSilent;
    property CanInstallWithOtherName : Boolean read fCanInstallWithOtherName write fCanInstallWithOtherName;
    property Status : TSvcStatus read fStatus write fStatus;
    property OnStart : TSvcAnonMethod read fOnStart write fOnStart;
    property OnStop : TSvcAnonMethod read fOnStop write fOnStop;
    property OnExecute : TSvcAnonMethod read fOnExecute write fOnExecute;
    property OnInitialize : TSvcInitializeEvent read fOnInitialize write fOnInitialize;
    property AfterRemove : TSvcRemoveEvent read fAfterRemove write fAfterRemove;
    procedure Install;
    procedure Remove;
    procedure CheckParams;
    class function InstallParamsPresent : Boolean;
    class function ConsoleParamPresent : Boolean;
    class function IsRunningAsService : Boolean;
    class function IsRunningAsConsole : Boolean;
  end;

var
  ServiceStatus : TServiceStatus;
  StatusHandle  : SERVICE_STATUS_HANDLE;
  ServiceTable  : array [0..NUM_OF_SERVICES] of TServiceTableEntry;
  ghSvcStopEvent: Cardinal;
  AppService : TAppService;

implementation

procedure ServiceCtrlHandler(Control: DWORD); stdcall;
begin
  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.DoStop;
      end;
  end;
end;

procedure RegisterService(dwArgc: DWORD; var lpszArgv: PChar); stdcall;
begin
  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;


constructor TAppService.Create;
begin
  inherited;
  fServiceName := DEF_SERVICENAME;
  fDisplayName := DEF_DISPLAYNAME;
  fFileName := ParamStr(0);
  fSilent := True;
  fStatus := TSvcStatus.ssStopped;
  fCanInstallWithOtherName := False;
  fOnExecute := nil;
end;

destructor TAppService.Destroy;
begin
  fOnStart := nil;
  fOnStop := nil;
  fOnExecute := nil;
  if fSCMHandle <> 0 then CloseServiceHandle(fSCMHandle);
  if fSvHandle <> 0 then CloseServiceHandle(fSvHandle);
  inherited;
end;

procedure TAppService.ReportSvcStatus(dwCurrentState, dwWin32ExitCode, dwWaitHint: DWORD);
begin
  //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 TAppService.Execute;
begin
  //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(fOnStart) then fOnStart;

  //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(fOnExecute) then fOnExecute;
    //check whether to stop the service.
    WaitForSingleObject(ghSvcStopEvent,INFINITE);
    ReportSvcStatus(SERVICE_STOPPED,NO_ERROR,0);
    Exit;
  end;
end;

procedure TAppService.DoStop;
begin
   if Assigned(fOnStop) then fOnStop;
end;

procedure TAppService.Remove;
const
  cRemoveMsg = 'Service "%s" removed successfully!';
var
  SCManager: SC_HANDLE;
  Service: SC_HANDLE;
begin
  SCManager := OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);
  if SCManager = 0 then
    Exit;
  try
    Service := OpenService(SCManager,PChar(fServiceName),SERVICE_ALL_ACCESS);
    ControlService(Service,SERVICE_CONTROL_STOP,ServiceStatus);
    DeleteService(Service);
    CloseServiceHandle(Service);
    if fSilent then Writeln(Format(cRemoveMsg,[fServiceName]))
      else MessageBox(0,cRemoveMsg,PChar(fServiceName),MB_ICONINFORMATION or MB_OK or MB_TASKMODAL or MB_TOPMOST);
  finally
    CloseServiceHandle(SCManager);
    if Assigned(fAfterRemove) then fAfterRemove;
  end;
end;

procedure TAppService.Install;
const
  cInstallMsg = 'Service "%s" installed successfully!';
  cSCMError = 'Error trying to open SC Manager (you need admin permissions)';
begin
  fSCMHandle := OpenSCManager(nil,nil,SC_MANAGER_ALL_ACCESS);

  if fSCMHandle = 0 then
  begin
    if fSilent then Writeln(cSCMError)
      else MessageBox(0,cSCMError,PChar(fServiceName),MB_ICONERROR or MB_OK or MB_TASKMODAL or MB_TOPMOST);
    Exit;
  end;
  fSvHandle := CreateService(fSCMHandle,
                              PChar(fServiceName),
                              PChar(fDisplayName),
                              SERVICE_ALL_ACCESS,
                              SERVICE_WIN32_OWN_PROCESS,
                              SERVICE_AUTO_START,
                              SERVICE_ERROR_IGNORE,
                              PChar(fFileName),
                              'System Reserved',
                              nil,
                              nil,
                              nil, //user
                              nil); //password

  if fSvHandle <> 0 then
  begin
    if fSilent then Writeln(Format(cInstallMsg,[fServiceName]))
      else MessageBox(0,cInstallMsg,PChar(fServiceName),MB_ICONINFORMATION or MB_OK or MB_TASKMODAL or MB_TOPMOST);
  end;
end;

procedure TAppService.Help;
begin
  Writeln('HELP:');
  if fCanInstallWithOtherName then
  begin
    Writeln(Format('%s [/instance:<Service name>] [/console] [/install] [/remove] [/h] [/help]',[ExtractFileName(ParamStr(0))]));
    WriteLn(' [/instance:<service name>]'+#9+'Install service with a custom name');
  end
  else Writeln(Format('%s [/console] [/install] [/remove] [/h] [/help]',[ExtractFileName(ParamStr(0))]));
  WriteLn(' [/console]'+#9#9#9+'Run as a console application');
  WriteLn(' [/install]'+#9#9#9+'Install as a service');
  WriteLn(' [/remove]'+#9#9#9+'Remove service');
  WriteLn(' [/h /help]'+#9#9#9+'This help');
end;

procedure TAppService.CheckParams;
var
  svcname : string;
begin

  if ParamCount > 0 then
  begin
    if (ParamFindSwitch('h')) or (ParamFindSwitch('help')) then Self.Help
      else if ParamFindSwitch('install') then
      begin
        if (fCanInstallWithOtherName) and (ParamGetSwitch('instance',svcname)) then
        begin
          fServiceName := svcname;
          fDisplayName := svcname;
        end;
        Self.Install;
      end
      else if ParamFindSwitch('remove') then
      begin
        if (fCanInstallWithOtherName) and (ParamGetSwitch('instance',svcname)) then
        begin
          fServiceName := svcname;
          fDisplayName := svcname;
        end;
        Self.Remove;
      end
      else Writeln('Unknow parameter specified!');
  end
  else
  begin
    //initialize as a service
    if Assigned(fOnInitialize) then fOnInitialize;
    ServiceTable[0].lpServiceName := PChar(fServiceName);
    ServiceTable[0].lpServiceProc := @RegisterService;
    ServiceTable[1].lpServiceName := nil;
    ServiceTable[1].lpServiceProc := nil;
    {$IFDEF FPC}
    StartServiceCtrlDispatcher(@ServiceTable[0]);
    {$ELSE}
    StartServiceCtrlDispatcher(ServiceTable[0]);
    {$ENDIF}
  end;
end;

class function TAppService.ConsoleParamPresent : Boolean;
begin
  Result := ParamFindSwitch('console');
end;

class function TAppService.InstallParamsPresent : Boolean;
begin
  Result := (ParamFindSwitch('install') or ParamFindSwitch('remove') or ParamFindSwitch('help') or ParamFindSwitch('h'));  
end;

class function TAppService.IsRunningAsService : Boolean;
begin
  Result := (IsService and not ConsoleParamPresent) or InstallParamsPresent;
end;

class function TAppService.IsRunningAsConsole : Boolean;
begin
  Result := (not IsService) or (ConsoleParamPresent);
end;

initialization
AppService := TAppService.Create;

finalization
AppService.Free;

end.