Программирование, установка и конфигурирование сервисов Windows NT

program ShowServiceDacl;
{$APPTYPE CONSOLE}
uses SysUtils, Windows, WinSVC;

Var scHndl, sHndl: THandle;
 Function toOEM(aStr: String): String; Begin Result := aStr; UniqueString(Result); ANSItoOEM(PChar(Result), PChar(Result)); End;
 Function GetServiceNameByDisplayName(aDispName: String): String; Var bufSize: DWORD; Begin Result := ''; bufSize := 0; GetServiceKeyName(scHndl, PChar(ParamStr(1)), Nil, bufSize); If GetLastError <> ERROR_INSUFFICIENT_BUFFER Then RaiseLastWin32Error; SetLength(Result, bufSize Div 2); If Not GetServiceKeyName(scHndl, PChar(ParamStr(1)), PChar(Result), bufSize) Then RaiseLastWin32Error; End;

//Эти объявления взяты из winnt.h, в станд. библиотеках Delphi этого нет :(
Const ACCESS_ALLOWED_ACE_TYPE = 0; ACCESS_DENIED_ACE_TYPE = 1;
Type _ACE_HEADER = Packed Record AceType, AceFlags: BYTE; AceSize: WORD; End; ACE_HEADER = _ACE_HEADER; PACE_HEADER = ^ACE_HEADER;
 _ACCESS_ALLOWED_ACE = Record Header: ACE_HEADER; Mask: ACCESS_MASK; SidStart: DWORD; End; PACCESS_ALLOWED_ACE = ^_ACCESS_ALLOWED_ACE;
 _SID = Record Revision: BYTE; SubAuthorityCount: BYTE; IdentifierAuthority: SID_IDENTIFIER_AUTHORITY; SubAuthority: DWORD; End; TSID = _SID; PSID = ^TSID;
 Function SidToStr(aSID: PSID): String; Var AuthID: PSidIdentifierAuthority; SubAuthCount: PUCHAR; SubAuth: PDWORD; J: Integer; begin Win32Check(IsValidSID(aSID));
 Result := 'S-' + IntToStr(aSID.Revision) + '-';
 AuthID := GetSidIdentifierAuthority(aSID); Result := Result + IntToStr(AuthID.Value[High(AuthID.Value)]) + '-'; For J := High(AuthID.Value) - 1 DownTo Low(AuthID.Value) Do If AuthID.Value[J] <> 0 Then Result := Result + IntToStr(AuthID.Value[J]) + '-';
 SubAuthCount := GetSIDSubAuthorityCount(aSID); For J := 0 To SubAuthCount^ - 1 Do Begin SubAuth := GetSIDSubAuthority(ASID, J); Result := Result + IntToStr(SubAuth^) + '-'; End;
 J := Length(Result); If J <> 0 Then SetLength(Result, J - 1); End;
 Function GetAccountBySID(ServerName: String; aSID: PSID): String; Var nSize, dSize, pUse: DWORD; aName, dName: PChar; Begin If Not IsValidSID(aSID) Then Begin Result := 'Erroneus SID!'; Exit; End; nSize := 0; dSize := 0; If Not LookupAccountSid(PChar(ServerName), aSID, Nil, nSize, Nil, dSize, pUse) Then If GetLastError <> ERROR_INSUFFICIENT_BUFFER Then If GetLastError <> ERROR_NONE_MAPPED Then RaiseLastWin32Error Else Begin Result := SIDToStr(aSID); Exit; End; aName := StrAlloc(nSize); dName := StrAlloc(dSize); Try Win32Check(LookupAccountSid( PChar(ServerName), aSID, aName, nSize, dName, dSize, pUSE)); Result := aName + ' (' + dName + ')'; Finally StrDispose(aName); StrDispose(dName); End; End;

Var TempStr: String; SD: Pointer; aDACL: PACL; anACE: PACCESS_ALLOWED_ACE; bytesNeeded, tempMask: DWORD; DummyFlag1, DummyFlag2: BOOL; J, I: Integer;

Const AccessMaskStringMap: Array[0..31] Of String = ( 'Query Service Config', 'Change Service Config', 'Query Service Status', 'Enumerate Dependent Services', 'Start Service', 'Stop Service', 'Pause\Continue Service', 'Interrogate Service', 'User Defined Service Control', '', '', '', '', '', '', '', 'Delete Service', 'Read DACL', 'Write DACL', 'Write Owner', '', '', '', '', 'Access System ACL', '', '', '', '', '', '', '' );

begin Try If ParamCount < 1 Then Raise Exception.Create('Service DisplayName must be first input parameter!');
 scHndl := OpenSCManager(Nil, Nil, SC_MANAGER_CONNECT); Try TempStr := GetServiceNameByDisplayName(ParamStr(1));
 sHndl := OpenService(scHndl, PChar(TempStr), READ_CONTROL); If sHndl = 0 Then RaiseLastWin32Error; Try GetMem(SD, 1024); If Not QueryServiceObjectSecurity( sHndl, DACL_SECURITY_INFORMATION, SD, 1024, bytesNeeded) Then RaiseLastWin32Error;
 //На этом этапе имеем Security Descriptor (в SD). Начинаем его "ковырять" //Получаем указатель на DACL If Not GetSecurityDescriptorDACL(SD, DummyFlag1, aDACL, DummyFlag2) Then RaiseLastWin32Error;
 WriteLn('DACL information for Service "', ParamStr(1), '"'); WriteLn('ACE''s count: ', aDACL.AceCount);
 If aDACL.AceCount = 0 Then Begin WriteLn('Nothing to show!'); Exit; End;
 WriteLn('Start dumping...'); WriteLn;
 //Вытаскиваем ACE's... For J := 0 To aDACL.AceCount - 1 Do Begin If Not GetACE(aDACL^, J, Pointer(anACE)) Then RaiseLastWin32Error;
 Case anACE.Header.AceType Of ACCESS_ALLOWED_ACE_TYPE: TempStr := 'Allowed'; ACCESS_DENIED_ACE_TYPE: TempStr := 'Denied'; else TempStr := 'Unknown'; End;
 //Выводим пользователя в этом ACE... Writeln( 'Access ', TempStr, ' Ace (at index ', J, ') for user "', toOEM(GetAccountBySID('', @anACE.SidStart)), '"' );
 WriteLn('Access mask:'); //Выводим AccessRights для ACE: For I := 0 To 31 Do Begin //Проверяем каждый бит в 32-битной маске доступа... TempMask := 1 shl I; If (anACE.Mask And TempMask) = TempMask Then WriteLn(' ', AccessMaskStringMap[I]); //Выводим описание бита в маске End; WriteLn; End;
 Writeln('Information for ', aDACL.AceCount, ' ACE''s printed successfully!'); Writeln(toOEM('Благодарности слать на alex_wh@mail.ru')); Write(toOEM('Можно пивом! ;-) Нажмите Enter для выхода...')); ReadLN; Finally CloseServiceHandle(sHndl); End; Finally CloseServiceHandle(scHndl); End; Except On E: Exception Do If Not (E is EAbort) Then Begin WriteLn('Exception Class ' + E.ClassName + ' occured.'); WriteLn('Error message: "' + toOEM(E.Message) + '"'); WriteLn('Program terminated.'); End; End;
end.

program SimpleServ;
{$APPTYPE CONSOLE}
uses Windows, WinSVC; //Не используем SysUtils - размер *.exe будет ~25 Kb

Const ServicesCount = 1; ServiceName = 'SimpleServ'; DisplayName = 'Simple Service'; ServiceType = SERVICE_WIN32_OWN_PROCESS; ServiceDescription = 'SimpleServ by HandleX... This sample program will help ' + 'you to understand Windows NT Services. ' + 'Mail to alex_wh@mail.ru.';

Var ServThrHndl: THandle = 0; StopEvent: THandle = 0; aServHndl: DWord = 0; aServStatus: SERVICE_STATUS;
 Function IntToStr(Value: Integer): String; //Included we don't use SysUtils Var aSign: Bool; Begin Result := '';
 aSign := Value >= 0; If Not aSign Then Value := -Value;
 Repeat Result := Char(Value - (Value Div 10) * 10 + Byte('0')) + Result; Value := Value Div 10; Until Value = 0;
 If Not aSign Then Result := '-' + Result; End;
 // Helper function for windows error strings //Included because we don't use SysUtils function SysErrorMessage(ErrorCode: Integer): string; var Len: Integer; Buffer: array[0..255] of Char; begin Len := FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM or FORMAT_MESSAGE_ARGUMENT_ARRAY, nil, ErrorCode, 0, Buffer, SizeOf(Buffer), nil); while (Len > 0) and (Buffer[Len - 1] in [#0..#32]) do Dec(Len); SetString(Result, Buffer, Len); UniqueString(Result); ANSItoOEM(PChar(Result), PChar(Result)); If Result <> '' Then Result := IntToStr(ErrorCode) + ' ' + Result; end;
 Procedure ShowInfo; Begin WriteLn; WriteLn(' -=* SIMPLE TRAINING SERVICE BY HandleX *=-'); End;
 Procedure ProcessStartupParams; //Реакция на install, uninstall
 //Устанавливает "описание" для службы, под Win2k и выше Function SetServiceDescription(aSHndl: THandle; aDesc: String): Bool; Const SERVICE_CONFIG_DESCRIPTION: DWord = 1; Var DynChangeServiceConfig2: Function( hService: SC_HANDLE; // handle to service dwInfoLevel: DWORD; // information level lpInfo: Pointer): Bool; StdCall; // new data aLibHndl: THandle; TempP: PChar; Begin aLibHndl := GetModuleHandle(advapi32); Result := aLibHndl <> 0; If Not Result Then Exit; DynChangeServiceConfig2 := GetProcAddress(aLibHndl, 'ChangeServiceConfig2A'); Result := @DynChangeServiceConfig2 <> Nil; If Not Result Then Exit; TempP := PChar(aDesc); //ChangeServiceConfig2 хочет указатель на указатель строки Result := DynChangeServiceConfig2(aSHndl, SERVICE_CONFIG_DESCRIPTION, @TempP); End;
 Type TToDo = (tdError, tdInstall, tdUninstall); TToDo_s = Set of TToDo; Const ParamStrings: Array[tdInstall..tdUninstall] of String = ('install', 'uninstall');
 Function MapParam(aParam: String): TToDo; //Узнаёт из параметра о вашем желании ;-) Var J: TToDo; TempStr: String; Begin Result := tdError; TempStr := aParam; If TempStr[1] In ['/', '-'] Then TempStr := Copy(TempStr, 2, Length(TempStr) - 1); UniqueString(TempStr); CharLower(PChar(TempStr)); For J := Low(ParamStrings) to High(ParamStrings) Do If ParamStrings[J] = TempStr Then Begin Result := J; Exit; End; End;
 Var J: Integer; scHndl, sHndl: THandle; aStatus: TServiceStatus; toDo: TTodo_s; Begin toDo := []; For J := 1 to ParamCount Do Begin Include(ToDo, MapParam(ParamStr(J))); If tdError in toDo Then Begin ExitCode := ERROR_INVALID_PARAMETER; WriteLn('Unknown parameter - ' + ParamStr(J) + '. RTFM, please...'); Exit; End; End;
 If [tdInstall, tdUninstall] <= toDo Then Begin ExitCode := ERROR_INVALID_PARAMETER; WriteLn('Error: you can not install and uninstall service simultaniosly. Check params.'); Exit; End;
 If tdInstall in toDo Then //Устанавливаем сервис Begin Write('Connecting Service Control Manager...'); scHndl := OpenSCManager(Nil, Nil, SC_MANAGER_CREATE_SERVICE); If scHndl = 0 Then Begin ExitCode := GetLastError; WriteLn('Failed!'); WriteLn('Error: ', SysErrorMessage(ExitCode)); Exit; End; Try WriteLn('Ok'); Write('Creating service database record...'); sHndl := CreateService( SCHndl, ServiceName, DisplayName, SERVICE_QUERY_CONFIG Or SERVICE_CHANGE_CONFIG, ServiceType, SERVICE_DEMAND_START, SERVICE_ERROR_NORMAL, PChar(ParamStr(0)), Nil, Nil, Nil, Nil, Nil);
 If sHndl = 0 Then Begin ExitCode := GetLastError; WriteLn('Failed!'); WriteLn('Error: ', SysErrorMessage(ExitCode)); Exit; End; Try WriteLn('Ok');
 If ServiceDescription <> '' Then Begin Write('Setting service description...'); If Not SetServiceDescription(sHndl, ServiceDescription) Then Begin WriteLn('Failed!'); WriteLn('Warning: ', SysErrorMessage(GetLastError)); WriteLn('Warning: SetServiceDesc() failed, but service is installed!'); End Else WriteLn('Ok'); End; Finally CloseServiceHandle(sHndl); End; Finally CloseServiceHandle(SCHndl); End; WriteLn('Service "', DisplayName, '" install success.'); End;
 If tdUninstall in toDo Then //Удаляем сервис... Begin Write('Connecting Service Control Manager...'); scHndl := OpenSCManager(Nil, Nil, GENERIC_EXECUTE); If scHndl = 0 Then Begin ExitCode := GetLastError; WriteLn('Failed!'); WriteLn('Error: ', SysErrorMessage(ExitCode)); Exit; End; Try WriteLn('Ok');
 Write('Opening and Quering Service...'); sHndl := OpenService(SCHndl, ServiceName, STANDARD_RIGHTS_REQUIRED Or SERVICE_QUERY_STATUS Or SERVICE_STOP); If sHndl = 0 Then Begin ExitCode := GetLastError; WriteLn('Failed!'); WriteLn('Error: ', SysErrorMessage(ExitCode)); Exit; End; Try If Not QueryServiceStatus(sHndl, aStatus) Then Begin ExitCode := GetLastError; WriteLn('Failed!'); WriteLn('Error: ', SysErrorMessage(ExitCode)); Exit; End; WriteLn('Ok');
 If aStatus.dwCurrentState <> SERVICE_STOPPED Then Begin Write('Service is running, wait until stopped...'); If Not ControlService(sHndl, SERVICE_CONTROL_STOP, aStatus) Then Begin ExitCode := GetLastError; WriteLn('Failed!'); WriteLn('Error: ', SysErrorMessage(ExitCode)); Exit; End; While aStatus.dwCurrentState <> SERVICE_STOPPED Do Begin Sleep(250); Write('.'); If Not QueryServiceStatus(sHndl, aStatus) Then Begin ExitCode := GetLastError; WriteLn('Failed!'); WriteLn('Error: ', SysErrorMessage(ExitCode)); Exit; End; End; WriteLn('Stopped'); End;
 Write('Deleting Service...'); If Not DeleteService(sHndl) Then Begin ExitCode := GetLastError; WriteLn('Failed!'); WriteLn('Error: ', SysErrorMessage(ExitCode)); Exit; End; WriteLn('Ok'); Finally CloseServiceHandle(sHndl); End; Finally CloseServiceHandle(SCHndl); End; WriteLn('Service uninstall success.'); End;
 End;
 Function SetState(aState: DWORD): DWORD; Begin aServStatus.dwCurrentState := aState; If aServHndl <> 0 Then SetServiceStatus(aServHndl, aServStatus); Result := aServStatus.dwCurrentState; End;
 Procedure ServiceHandler(fdwControl: DWORD); StdCall; Begin Case fdwControl Of //Requests the service to stop. SERVICE_CONTROL_STOP: Begin SetState(SERVICE_STOP_PENDING); SetEvent(StopEvent); //Если сервис был в паузе, то рабочий поток надо возобновить ResumeThread(ServThrHndl); End; //Requests the service to pause. SERVICE_CONTROL_PAUSE: Begin SetState(SERVICE_PAUSE_PENDING); SuspendThread(ServThrHndl); //Останавливаем рабочий поток сервиса SetState(SERVICE_PAUSED); End; //Requests the paused service to resume. SERVICE_CONTROL_CONTINUE: Begin SetState(SERVICE_CONTINUE_PENDING); ResumeThread(ServThrHndl); //Восстанавливаем рабочий поток сервиса SetState(SERVICE_RUNNING); End; //Requests the service to update immediately its current status //information to the service control manager. SERVICE_CONTROL_INTERROGATE: Begin //Говорим SCM о том, в каком состоянии находится наша служба SetState(aServStatus.dwCurrentState); End; //Протяжно пищим в спикер - кто-то послал USER DEFINED CONTROL CODE. //В реальных применениях может использоваться для подачи различных сигналов //самописным службам. Удобны тем, что передаются даже удалённым хостам //при помощи ControlService() и соотв. дескриптора удалённого SCM. 128..255: Begin SuspendThread(ServThrHndl); Windows.Beep(1000, 500); //Возвращать результаты можно вызовом SetServiceStatus(). aServStatus.dwWin32ExitCode := ERROR_SUCCESS; SetState(aServStatus.dwCurrentState); ResumeThread(ServThrHndl); End; End; End;
 Procedure MainServiceProc( // Каждая служба может иметь параметры запуска... dwArgc: DWORD; // Кол-во параметров - у нас не используется lpszArgv: Pointer); StdCall // Массив параметров - у нас не используется Begin aServHndl := RegisterServiceCtrlHandler(ServiceName, @ServiceHandler); If aServHndl = 0 Then Begin ExitCode := GetLastError; Exit; //Какая-то ошибка, выходим, SCM будет ругаться, но сообщить мы ему ничего не можем... End; ZeroMemory(@aServStatus, SizeOf(aServStatus)); aServStatus.dwServiceType := ServiceType; aServStatus.dwControlsAccepted := SERVICE_ACCEPT_STOP Or SERVICE_ACCEPT_PAUSE_CONTINUE; //Здесь может быть подсказка для небыстрых служб о том, как долго она реагирует на команды //aServStatus.dwWaitHint := 500;
 //Извещаем SCM, что начинается старт службы... SetState(SERVICE_START_PENDING);
 //Пошла процедура инициализации...
 //Получаем реальный дескриптор потока службы... If Not DuplicateHandle( GetCurrentProcess, GetCurrentThread, GetCurrentProcess, @ServThrHndl, 0, FALSE, DUPLICATE_SAME_ACCESS) Then Begin aServStatus.dwWin32ExitCode := GetLastError; SetState(SERVICE_STOPPED); Exit; End;
 //Создаём unnamed event для остановки службы по сигналу из Handler... StopEvent := CreateEvent(Nil, True, False, Nil); If StopEvent = 0 Then //Ошибка создания Event'а - выходим... Begin aServStatus.dwWin32ExitCode := GetLastError; SetState(SERVICE_STOPPED); Exit; End;
 SetState(SERVICE_RUNNING); //Инит прошёл, работаем!
 //Крутим цикл, бипаем по таймауту, если срабатывает event - выходим... //В реальной службе именно здесь может быть конкретная полезная работа While WaitForSingleObject(StopEvent, 500) = WAIT_TIMEOUT Do Windows.Beep(10000, 10); 
 //Выполняем остановку сервиса, вычищаемся... CloseHandle(ServThrHndl); ServThrHndl := 0; CloseHandle(StopEvent); StopEvent := 0;
 SetState(SERVICE_STOPPED); //Извещаем, SCM, что работа службы остановлена... End; //Поток ЭТОЙ службы завершил свою работу.

Var ServTableEntryArray: Array[0..ServicesCount] Of TServiceTableEntryA;

begin
 //Старт программы...
 If ParamCount > 0 Then //От нас что-то хотят... Begin ShowInfo; ProcessStartupParams; //Выясняем что и выходим... Exit; End;
 //Готовимся к вызову StartServiceCtrlDispatcher ZeroMemory(@ServTableEntryArray, SizeOf(ServTableEntryArray)); ServTableEntryArray[0].lpServiceName := ServiceName; ServTableEntryArray[0].lpServiceProc := @MainServiceProc;
 If Not StartServiceCtrlDispatcher(ServTableEntryArray[0]) Then Begin ExitCode := GetLastError; ShowInfo; //Какая-то ошибка, выводим в консоль сообщение и выходим... WriteLn('Error: ', SysErrorMessage(ExitCode)); WriteLn('This program is Windows NT Service, so it CAN NOT be run from command prompt.'); WriteLn('You can install it with "/install" parameter.'); WriteLn('If this service is already installed, you can run it with "net start" command.'); End; //Процесс службы завершает работу, всем до свидания... //Если вы разместили в своём *.exe несколько служб, то здесь //вы окажетесь только после остановки ВСЕХ служб процесса.
end.