Interactive services in Windows NT.
The aim of my work is to describe some aspects of NT services creation in Delphi. I’m not going to touch upon facts that have been already described by other authors. I’ll cover not evident and not enough described points. That is:

A service start under a user that is distinctive from the internal system account; getting access to a desktop.
Creation of a hybrid application that can be started both as service and as an ordinary process.
Some useful ways of creating NT services.
The start of interactive NT services under any user account.

Here we come across the following problem: Windows grants desktop only for services that are started under built-in system account with “Interact with Desktop” option. For getting desktop with another user you should create it.


const
DefaultWindowStation = 'WinSta0';
DefaultDesktop = 'Default';
var
hwinstaSave: HWINSTA;
hdeskSave: HDESK;
hwinstaUser: HWINSTA;
hdeskUser: HDESK;
function InitServiceDesktop: boolean;
var
dwThreadId: DWORD;
begin
dwThreadId := GetCurrentThreadID;
// Ensure connection to service window station and desktop, and
// save their handles.
hwinstaSave := GetProcessWindowStation;
hdeskSave := GetThreadDesktop(dwThreadId);

hwinstaUser := OpenWindowStation(DefaultWindowStation, FALSE, MAXIMUM_ALLOWED);
if hwinstaUser = 0 then
begin
OutputDebugString(PChar('OpenWindowStation failed' + SysErrorMessage(GetLastError)));
Result := false;
exit;
end;
if not SetProcessWindowStation(hwinstaUser) then
begin
OutputDebugString('SetProcessWindowStation failed');
Result := false;
exit;
end;

hdeskUser := OpenDesktop(DefaultDesktop, 0, FALSE, MAXIMUM_ALLOWED);
if hdeskUser = 0 then
begin
OutputDebugString('OpenDesktop failed');
SetProcessWindowStation(hwinstaSave);
CloseWindowStation(hwinstaUser);
Result := false;
exit;
end;
Result := SetThreadDesktop(hdeskUser);
if not Result then
OutputDebugString(PChar('SetThreadDesktop' + SysErrorMessage(GetLastError)));
end;

This function is to be invoked the first, before any calls of module user32! i.e. it should be placed in a separate module and her call is put in initialization section. Created module should be the first in uses line of the file project. Otherwise VCL will call any function user32 in initialization section herself, e.g. module Forms. After that you can start service under any user that has a right to work with a desktop.

With the help of this technology you can display tray icon of a service. In other cases one would have used a separate application-monitor.

It is also possible to add a call of procedure in finalization section:


procedure DoneServiceDeskTop;
begin
// Restore window station and desktop.
SetThreadDesktop(hdeskSave);
SetProcessWindowStation(hwinstaSave);
if hwinstaUser <> 0 then
CloseWindowStation(hwinstaUser);
if hdeskUser <> 0 then
CloseDesktop(hdeskUser);
end;

Creation of unified executable files for services and standard applications.

For solving this problem it is necessary to understand the process of the file start in NT: 1) a list of initiation services is created; 2) a thread that interacts with SCM by means of StartServiceCtrlDispatcher function is started. At this point we can define whether it was start of application as a service (i.e. it was started by SCM) or as a standard user’s application. Only it is necessary to check the results of a function StartServiceCtrlDispatcher: if GetLastError= ERROR_FAILED_SERVICE_CONTROLLER_ then it was a usual start; if GetLastError=ERROR_CALL_NOT_IMPLEMENTED, then the start was done from OS, Win9x family in which services aren’t supported. It seems everything to be very easy but you need to know some tricks for realization this function in Delphi.

Firstly, it is necessary to create your own class of TServiceApplication that is compatible with a standard class TApplication and that will realize this functionality.

Secondly, an opportunity to continue the fulfilling of the application after its unsuccessful start as a service should present in this class.

unit UniApp;

interface

uses SysUtils, Classes, SvcMgr;

type
ENotService = class(Exception);
TUniApplication = class(TServiceApplication)
private
FEventLogger: TEventLogger;
procedure OnExceptionHandler(Sender: TObject; E: Exception);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Run; override;
procedure ContinueRun;
end;

// Function replaces variable Application
function Application: TUniApplication;

implementation

uses
Windows, Messages, WinSvc, Forms;

type
TServiceTableEntryArray = array of TServiceTableEntry;

TServiceStartThread = class(TThread)
private
FServiceStartTable: TServiceTableEntryArray;
protected
procedure DoTerminate; override;
procedure Execute; override;
public
constructor Create(Services: TServiceTableEntryArray);
end;

constructor TServiceStartThread.Create(Services: TServiceTableEntryArray);
begin
FreeOnTerminate := False;
ReturnValue := 0;
FServiceStartTable := Services;
inherited Create(False);
end;

var
FContinueHandlingMessages: boolean = true;

const
UM_BREAKWAIT = WM_USER+5;
procedure TServiceStartThread.DoTerminate;
begin
inherited DoTerminate;

if (ReturnValue = ERROR_FAILED_SERVICE_CONTROLLER_) or
(ReturnValue = ERROR_CALL_NOT_IMPLEMENTED)
then
begin
// in order to exit a loop
FContinueHandlingMessages := false;
// Send a fake message Application, for exiting from a function WaitMessage
PostMessage(Forms.Application.Handle, UM_BREAKWAIT, 0, 0);
end
else
PostMessage(Forms.Application.Handle, WM_QUIT, 0, 0);
end;

procedure TServiceStartThread.Execute;
begin
if StartServiceCtrlDispatcher(FServiceStartTable[0]) then
ReturnValue := 0 else
ReturnValue := GetLastError;
end;

procedure DoneServiceApplication;
begin
with Forms.Application do
begin
if Handle <> 0 then ShowOwnedPopups(Handle, False);
ShowHint := False;
Destroying;
DestroyComponents;
end;
with Application do
begin
Destroying;
DestroyComponents;
end;
end;

{ TUniApplication }
constructor TUniApplication.Create(AOwner: TComponent);
begin
FEventLogger := TEventLogger.Create(ExtractFileName(ParamStr(0)));
inherited Create(AOwner);
end;

destructor TUniApplication.Destroy;
begin
inherited Destroy;
FEventLogger.Free;
end;

procedure TUniApplication.OnExceptionHandler(Sender: TObject;
E: Exception);
begin
DoHandleException(E);
end;

procedure ServiceMain(Argc: DWord; Argv: PLPSTR); stdcall;
begin
TUniApplication(Application).DispatchServiceMain(Argc, Argv);
end;

procedure TUniApplication.Run;
function FindSwitch(const Switch: string): Boolean;
begin
Result := FindCmdLineSwitch(Switch, ['-', '/'], True);
end;
var
ServiceStartTable: TServiceTableEntryArray;
ServiceCount, i, J: Integer;
StartThread: TServiceStartThread;
begin
AddExitProc(DoneServiceApplication);
if FindSwitch('INSTALL') then
RegisterServices(True, FindSwitch('SILENT')) else
if FindSwitch('UNINSTALL') then
RegisterServices(False, FindSwitch('SILENT')) else
begin
Forms.Application.OnException := OnExceptionHandler;
ServiceCount := 0;
for i := 0 to ComponentCount - 1 do
if Components[i] is TService then Inc(ServiceCount);
SetLength(ServiceStartTable, ServiceCount + 1);
FillChar(ServiceStartTable[0], SizeOf(TServiceTableEntry) * (ServiceCount + 1), 0);
J := 0;
for i := 0 to ComponentCount - 1 do
if Components[i] is TService then
begin
ServiceStartTable[J].lpServiceName := PChar(Components[i].Name);
ServiceStartTable[J].lpServiceProc := @ServiceMain;
Inc(J);
end;
StartThread := TServiceStartThread.Create(ServiceStartTable);
try
while (not Forms.Application.Terminated) and FContinueHandlingMessages do
Forms.Application.HandleMessage;
// Does application start not as service?
if ((StartThread.ReturnValue = ERROR_FAILED_SERVICE_CONTROLLER_) or
(StartThread.ReturnValue = ERROR_CALL_NOT_IMPLEMENTED)) and (not Forms.Application.Terminated)
then
begin
raise ENotService.Create('Not as service');
end
else if StartThread.ReturnValue <> 0 then
begin
FEventLogger.LogMessage(SysErrorMessage(GetLastError));
end;
finally
StartThread.Free;
end;
end;
end;

// This method gives an opportunity to continue running of application
// after unsuccessful start as a service
procedure TUniApplication.ContinueRun;
begin
while not Forms.Application.Terminated do
Forms.Application.HandleMessage;
Forms.Application.Terminate;
end;

procedure InitApplication;
begin
SvcMgr.Application.Free;
SvcMgr.Application := TUniApplication.Create(nil);
end;

function Application: TUniApplication;
begin
Result := TUniApplication(SvcMgr.Application);
end;

initialization
InitApplication;
end.
In TServiceStartThread a user’s message UM_BREAKWAIT is sent to a main configuration of application after unsuccessful service start. It is done only for finishing WaitMessage function in TApplication.Idle. Otherwise the loop of message processing will not hold and application will “freeze”.

In case of unsuccessful service start an object TUniApplication raise an exception EnotService. It should be processed in a project module. Then you continue to fulfill the application as a standard by ContinueRun:

begin
...
UniApp.Application.Initialize;
UniApp.Application.Title := 'Serv demo';
ROrdService := TROrdService.CreateNew(UniApp.Application, 0);
if not Installing then
begin
UniApp.Application.CreateForm(TfmMain, fmMain);
try
UniApp.Application.Run;
except on E: ENotService do
begin
try
fmMain.Initialize(false);
UniApp.Application.ContinueRun; // continue running as simple application
except
on E: Exception do ErrorDlg(E.Message);
end;
end;
end;
end
else
UniApp.Application.Run;
end.


Some useful snippets of creating services.

When working with interactive services we should take into account the fact that they can work without user’s entrance in a system. Accordingly these services won’t have access to a desktop for displaying tray-icon. Meantime it is necessary to display it after the entrance. I’ve taken the solution from Borland socket server and improved it by a constant monitoring of presence of a window coverage:

...
procedure TfmMain.FormCreate(Sender: TObject);
begin
...
Application.OnIdle := AppOnIdle;
end;
...
procedure TfmMain.AppOnIdle(Sender: TObject;
var Done: Boolean);
begin
if ROrdService.Status = csRunning then
TrayIcon.Active := (FindWindow('Progman', nil) <> 0);
Done := true;
end;
...

For stopping a service TService class doesn’t offer you any SCM reporting facilities telling you that service is still in a stop-process. After a standard time-out SCM thinks that the service doesn’t answer. That is why it stops displaying the service status. This problem is solved by creating a special thread for stopping the service and reporting SCM by means of ReportStatus function in a main thread of application.

type
// A special thread that is started during stopping
// of service for sending status to SCM that service is active
TTerminationThread = class(TThread)
procedure Execute; override;
end;
...
implementation
...
procedure TTerminationThread.Execute;
begin
try
fmMain.Termination;
except
LogFile.Write('Error in stopping services');
end;
end;

procedure TROrdService.Stop(Sender: TService; var Stopped: Boolean);
var
TerminationThread: TTerminationThread;
begin
PostMessage(fmMain.Handle, SERVICE_SHUTDOWN, 0, 0);
TerminationThread := TTerminationThread.Create(false);
try
while WaitForSingleObject(TerminationThread.Handle, WaitHint-1000) =
WAIT_TIMEOUT do
ReportStatus; // send a message to SCM that we have not finished yet
finally
TerminationThread.Free;
end;
PostMessage(fmMain.Handle, WM_QUIT, 0, 0);
end;


An example that demonstrates all above-mentioned technologies is applied. It was created on the basis of a real project, but this example doesn’t include any functionality except a display of current connections. The program running in tray, listens to port 215 protocol TCP and displays current connections. For installing it as a service - run program with /INSTALL switch, for removing /UNINSTALL switch. The program also demonstrates the work with UI in threads by sending user’s message, i.e. without using Synchronize that freeze the main thread of application.

Michael Jastrebtsoff (C) 2002