Техническое задание

• Очередь рассматривается как некая абстрактная структура, то есть кем она реализована, где хранится (в файле, БД или где-то ещё) и как конкретно с ней взаимодействовать (в виде программного кода) – всё это непринципиально и слабо пересекается с темой материала, однако предполагается, что задачи в ней обладают как минимум двумя свойствами:
  
  • Приоритетом, задающим порядок обработки.
  • Статусом, допускающим три значения:
    
    1. Ожидает обработки.
    2. Успешно обработана.
    3. Ошибка (не удалось обработать).
• Служба:
  
  • Сразу после старта принимается за тяжкие труды и начинает, с учётом приоритета, извлекать из очереди задачи с первым статусом (который «ожидающий»), после чего, в зависимости от результата обработки, обновляет статус у каждой из них; работа прекращается после того, как в очереди не осталось необработанных элементов.
  • Если поступает команда на остановку, то обработка текущей задачи прерывается и служба завершается.
  • Во время работы может принять особую (нестандартную) команду от управляющего приложения (УП), суть которой описана чуть ниже.
  • Дабы не наделять службу чрезмерным набором прав, из-за которых может пострадать безопасность всей ОС, вместо обычно применяемого аккаунта LocalSystem станет использоваться специальный пользователь, создаваемый на лету.
  • При установке происходит автоматическое назначение минимально необходимых прав как пользователю самой службы (от имени которого она должна запускаться – о нём шла речь в предыдущем пункте), так и пользователю управляющего приложения.
• Управляющее приложение:
  
  • Подаёт команды на запуск и остановку службы, т. е. примерно то, что вручную делается через Диспетчер служб:
    
    
    
  • Также, когда служба уже активна, может подать ей команду заново обработать «ошибочные» задачи (те, что с третьим статусом) – необходимость в этом обычно возникает после устранения внешних проблем, помешавших штатно справиться с такими задачами в прошлом.

Служба

Установка

interface

uses
  System.SysUtils, Vcl.SvcMgr;

...

implementation

uses
  Winapi.WinSvc;

resourcestring
  ServiceDescription = 'Шаблон (заготовка) службы, обрабатывающей очередь неких задач.';

procedure TQueueService.ServiceAfterInstall(Sender: TService);
var
  ManagerHandle, ServiceHandle: SC_HANDLE;
  Description: SERVICE_DESCRIPTION;
begin
  ManagerHandle := OpenSCManager(nil, nil, 0);

  if ManagerHandle = 0 then
    RaiseLastOSError;

  try
    ServiceHandle := OpenService( ManagerHandle, PChar(Name), SERVICE_CHANGE_CONFIG );

    if ServiceHandle = 0 then
      RaiseLastOSError;

    try
      Description.lpDescription := PChar(ServiceDescription);
      Win32Check( ChangeServiceConfig2(ServiceHandle, SERVICE_CONFIG_DESCRIPTION, @Description) );
    finally
      CloseServiceHandle(ServiceHandle);
    end;
  finally
    CloseServiceHandle(ManagerHandle);
  end;
end;

Пользователь

Svc := CreateService(SvcMgr, PChar(Name), PChar(DisplayName),
  SERVICE_ALL_ACCESS, GetNTServiceType, GetNTStartType, GetNTErrorSeverity,
  PChar(Path), PChar(LoadGroup), PTag, PChar(GetNTDependencies),
  PSSN, PChar(Password));

procedure TQueueService.ServiceAfterInstall(Sender: TService);
const
  VirtualAccountPrefix = 'NT Service\';
var
  ManagerHandle, ServiceHandle: SC_HANDLE;
  Description: SERVICE_DESCRIPTION;
  VirtualAccount: string;
begin
  ...

  Description.lpDescription := PChar(ServiceDescription);
  Win32Check( ChangeServiceConfig2(ServiceHandle, SERVICE_CONFIG_DESCRIPTION, @Description) );

  VirtualAccount := VirtualAccountPrefix + Name;
  Win32Check
    (
    ChangeServiceConfig
      (
      ServiceHandle,
      SERVICE_NO_CHANGE, SERVICE_NO_CHANGE, SERVICE_NO_CHANGE,
      nil, nil, nil, nil,
      PChar(VirtualAccount), nil,
      nil
      )
    );

  ...
end;

Права

• Первым из них идёт вышеупомянутый виртуальный, проблема с которым такова: если попробовать запустить службу в текущем виде, то система сообщит об отказе в доступе, ибо только что созданный аккаунт не имеет прав на запуск исполняемого файла службы (их у него вообще кот наплакал – за это и выбран). Другими словами, требуется добавить вот такую запись:
  
  
  
• Вторым пользователем является тот, от имени которого запускается управляющее приложение, – дело в том, что любая команда (запуск, приостановка и т. п.) проверяется на наличие соответствующих прав у её инициатора, пока их, увы, не имеющего. Хотя в общем случае про УП служба может ничего не знать (оно, скажем, создаётся другим программистом на ином ЯП), но ситуация в статье иная и позволяет возложить на службу и данное бремя, а чтобы она знала какому пользователю выдать такие права, добавим новый ключ запуска /ControlUser, где после двоеточия необходимо указать имя; если привести конкретный пример, то теперь установку службы следует производить с такими ключами – /install /ControlUser:SomeUser1.

interface

uses
  System.SysUtils, Winapi.Windows, Vcl.SvcMgr;

...

implementation

uses
  Winapi.WinSvc, Winapi.AccCtrl, Winapi.AclAPI;

procedure TQueueService.ServiceAfterInstall(Sender: TService);

  procedure GrantAccess(const UserName, ObjectName: string; const ObjectType: SE_OBJECT_TYPE; const Rights: ACCESS_MASK);
  begin
    // Реализация процедуры приведена чуть ниже в статье.
    ...
  end;

const
  VirtualAccountPrefix = 'NT Service\';
  ControlUserSwitch = 'ControlUser';
var
  ManagerHandle, ServiceHandle: SC_HANDLE;
  Description: SERVICE_DESCRIPTION;
  VirtualAccount, ControlUserName: string;
begin
  ...

  Description.lpDescription := PChar(ServiceDescription);
  Win32Check( ChangeServiceConfig2(ServiceHandle, SERVICE_CONFIG_DESCRIPTION, @Description) );

  VirtualAccount := VirtualAccountPrefix + Name;
  Win32Check
    (
    ChangeServiceConfig
      (
      ServiceHandle,
      SERVICE_NO_CHANGE, SERVICE_NO_CHANGE, SERVICE_NO_CHANGE,
      nil, nil, nil, nil,
      PChar(VirtualAccount), nil,
      nil
      )
    );
  GrantAccess( VirtualAccount, ParamStr(0), SE_FILE_OBJECT, GENERIC_READ or GENERIC_EXECUTE );

  if FindCmdLineSwitch(ControlUserSwitch, ControlUserName) then
    GrantAccess(ControlUserName, Name, SE_SERVICE, SERVICE_START or SERVICE_STOP or SERVICE_USER_DEFINED_CONTROL);

  ...
end;

procedure GrantAccess(const UserName, ObjectName: string; const ObjectType: SE_OBJECT_TYPE; const Rights: ACCESS_MASK);
var
  SecurityDescriptor: PSECURITY_DESCRIPTOR;
  OldDACL, NewDACL: PACL;
  UserAccess: EXPLICIT_ACCESS;
begin
  CheckOSError
    (
    GetNamedSecurityInfo
      (
      PChar(ObjectName),
      ObjectType,
      DACL_SECURITY_INFORMATION,
      nil,
      nil,
      @OldDACL,
      nil,
      SecurityDescriptor
      )
    );
  try
    BuildExplicitAccessWithName( @UserAccess, PChar(UserName), Rights, SET_ACCESS, NO_INHERITANCE );
    CheckOSError( SetEntriesInAcl(1, @UserAccess, OldDACL, NewDACL) );
    try
      CheckOSError
        (
        SetNamedSecurityInfo
          (
          PChar(ObjectName),
          ObjectType,
          DACL_SECURITY_INFORMATION,
          nil,
          nil,
          NewDACL,
          nil
          )
        );
    finally
      LocalFree( HLOCAL(NewDACL) );
    end;
  finally
    LocalFree( HLOCAL(SecurityDescriptor) );
  end;
end;

Обработка очереди

1. На основе событий OnStart и OnStop, что подразумевает самостоятельное создание потоков, содержащих нужный функционал.
2. На основе события OnExecute, обработчик которого выполняется в заранее заботливо созданном TService потоке, причём служба сразу же остановится после выхода из события; именно данный вариант хорошо подходит под поставленную в статье цель – как только в очереди обработаны все задачи, делать больше нечего и необходимо завершиться.

Основа события

procedure TQueueService.ServiceExecute(Sender: TService);
type
  TTask = ...; // Конкретный тип зависит от деталей Вашей реализации.
  TTaskList = array of TTask; // Массив использован лишь для иллюстрации, допустимы любые другие структуры данных (TList<TTask>, например).

  function ExtractTaskPortion(out Tasks: TTaskList): Boolean;
  begin
    // Функция вернёт True в случае, если в очереди ещё есть задачи для обработки (при этом
    // содержаться они будут в параметре Tasks).
    ...

    Result := Length(Tasks) > 0;
  end;

  procedure ProcessTask(const Task: TTask);
  begin
    // После обработки задачи, процедура должна обновить её статус (на 2-й или 3-й).
    ...
  end;

var
  Task: TTask;
  Tasks: TTaskList;
begin
  while ExtractTaskPortion(Tasks) do
    for Task in Tasks do
      ProcessTask(Task);
end;

Прерывание обработки

1. Команда на остановку службы, после которой никакого ожидания обработки текущей задачи быть не должно – она прерывается как можно быстрее, после чего все оставшиеся в порции задачи тоже отбрасываются и служба завершается.
2. Команда на повторную обработку задач с третьим статусом, для чего необходимо прервать работу по текущей (как и в случае команды на остановку), обновить статус всех означенных задач на первый, запросить новую порцию и далее действовать как обычно; надобность прерывать обработку текущей порции связана с тем, что среди задач с только что установленным первым статусом могут иметься обладающие бо́льшим приоритетом.

...

implementation

...

type
  EInterruption = class(Exception)
  public
    type
      TReason = (irStop, irErrorsReset);
  public
    Reason: TReason;
    constructor Create(const Reason: TReason);
  end;

constructor EInterruption.Create(const Reason: TReason);
begin
  inherited Create(string.Empty);
  Self.Reason := Reason;
end;

...

procedure TQueueService.ServiceExecute(Sender: TService);
type
  TTask = ...;
  TTaskList = array of TTask;

  function ExtractTaskPortion(out Tasks: TTaskList): Boolean;
  begin
    ...
  end;

  procedure CheckInterruption;
  begin
    // Отвечает за возбуждение исключения EInterruption.
    ...
  end;

  procedure ProcessTask(const Task: TTask);
  begin
    ...
  end;

  procedure ResetQueueErrors;
  begin
    // Меняет 3-й статус на первый у всех задач в очереди.
    ...
  end;

var
  Task: TTask;
  Tasks: TTaskList;
begin
  while ExtractTaskPortion(Tasks) do
    try
      for Task in Tasks do
        ProcessTask(Task);
    except
      on E: EInterruption do
        case E.Reason of
          irStop: Break;
          irErrorsReset: ResetQueueErrors;
          else raise;
        end;
    end;
end;

procedure ProcessTask(const Task: TTask);
begin
  // Некие действия (например инициализация обработки).
  CheckInterruption;
  ...

  // Ещё какой-то этап.
  CheckInterruption;
  ...

  // Некий этап-цикл.
  for ... to ... do
  begin
    CheckInterruption;
    ...
  end;

  // Обновление статуса задачи.
  CheckInterruption;
  ...
end;

Взаимодействие с Менеджером служб

interface

...

type
  TQueueService = class(TService)
    procedure ServiceAfterInstall(Sender: TService);
    procedure ServiceExecute(Sender: TService);
  private
    FCustomCode: DWORD;
  protected
    function DoCustomControl(CtrlCode: DWord): Boolean; override;
  ...
  end;

...

implementation

...

function TQueueService.DoCustomControl(CtrlCode: DWord): Boolean;
begin
  Result := inherited;
  FCustomCode := CtrlCode;
end;

procedure CheckInterruption;
begin
  ReportStatus;
  FCustomCode := 0;
  ServiceThread.ProcessRequests(False); // Внутри вызывается DoCustomControl.

  if Terminated then
    raise EInterruption.Create(irStop);

  case FCustomCode of
    RESET_QUEUE_ERRORS_CONTROL_CODE: raise EInterruption.Create(irErrorsReset);
  end;
end;

unit Services.Queue.Constants;

interface

const
  RESET_QUEUE_ERRORS_CONTROL_CODE = 128;

implementation

end.

function TQueueService.DoCustomControl(CtrlCode: DWord): Boolean;
begin
  Result := inherited;

  case CtrlCode of
    RESET_QUEUE_ERRORS_CONTROL_CODE: raise EInterruption.Create(irErrorsReset);
  end;
end;

Окончательный вариант

procedure TQueueService.ServiceExecute(Sender: TService);

  ...

  procedure ResetQueueErrors;
  begin
    // Меняет 3-й статус на первый у всех задач в очереди.
    ...
  end;

var
  I: Integer;
  Task: TTask;
  Tasks: TTaskList;
begin
  for I := 0 to ParamCount - 1 do
    if Param[I] = ResetQueueErrorsParam then
    begin
      ResetQueueErrors;
      Break;
    end;

  while ExtractTaskPortion(Tasks) do
    try
      for Task in Tasks do
        ProcessTask(Task);
    except
      on E: EInterruption do
        case E.Reason of
          irStop: Break;
          irErrorsReset: ResetQueueErrors;
          else raise;
        end;
    end;
end;

unit Services.Queue.Constants;

interface

const
  RESET_QUEUE_ERRORS_CONTROL_CODE = 128;

  ResetQueueErrorsParam = 'ResetErrors';

implementation

end.

Управляющее приложение

1. Запуск без изысков (как будто через Диспетчер служб).
2. Аналогично первой кнопке, но с параметром, отвечающим за предварительный сброс у задач третьего статуса.
3. Передача службе специальной команды (см. константу RESET_QUEUE_ERRORS_CONTROL_CODE).
4. Остановка службы (как будто через Диспетчер служб).

Предварительные действия

interface

uses
  Winapi.Windows, System.SysUtils, ..., Winapi.WinSvc;

type
  TForm1 = class(TForm)
    ...
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    FSCMHandle: SC_HANDLE;

    function OpenService(const Access: DWORD): SC_HANDLE;
  end;

...

implementation

procedure TForm1.FormCreate(Sender: TObject);
begin
  FSCMHandle := OpenSCManager(nil, nil, 0);
  if FSCMHandle = 0 then
    RaiseLastOSError;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  CloseServiceHandle(FSCMHandle);
end;

function TForm1.OpenService(const Access: DWORD): SC_HANDLE;
begin
  Result := Winapi.WinSvc.OpenService( FSCMHandle, PChar('QueueService'), Access );
  if Result = 0 then
    RaiseLastOSError;
end;

Основной код

interface

...

type
  TForm1 = class(TForm)
    ...
  private
    ...
    procedure RunService(const Parameters: array of string);
  end;

...

implementation

...

procedure TForm1.RunService(const Parameters: array of string);
var
  ServiceHandle: SC_HANDLE;
  Arguments: array of PChar;
  I: Integer;
begin
  ServiceHandle := OpenService(SERVICE_START);
  try
    if Length(Parameters) = 0 then
      Win32Check( StartService(ServiceHandle, 0, PPChar(nil)^) )
    else
    begin
      SetLength( Arguments, Length(Parameters) );

      for I := Low(Parameters) to High(Parameters) do
        Arguments[I] := PChar(Parameters[I]);

      Win32Check( StartService(ServiceHandle, Length(Arguments), Arguments[0]) );
    end;
  finally
    CloseServiceHandle(ServiceHandle);
  end;
end;

...

implementation

uses
  Services.Queue.Constants;

...

procedure TForm1.bStartClick(Sender: TObject);
begin
  RunService([]);
end;

procedure TForm1.bStartAndResetErrorsClick(Sender: TObject);
begin
  RunService([ResetQueueErrorsParam]);
end;

interface

...

type
  TForm1 = class(TForm)
    ...
  private
    ...
    procedure SendCommandToService(const Access, ControlCode: DWORD);
  end;

...

implementation

...

procedure TForm1.SendCommandToService(const Access, ControlCode: DWORD);
var
  ServiceHandle: SC_HANDLE;
  ServiceStatus: TServiceStatus;
begin
  ServiceHandle := OpenService(Access);
  try
    Win32Check( ControlService(ServiceHandle, ControlCode, ServiceStatus) );
  finally
    CloseServiceHandle(ServiceHandle);
  end;
end;

...

implementation

...

procedure TForm1.bResetErrorsClick(Sender: TObject);
begin
  SendCommandToService(SERVICE_USER_DEFINED_CONTROL, RESET_QUEUE_ERRORS_CONTROL_CODE);
end;

procedure TForm1.bStopClick(Sender: TObject);
begin
  SendCommandToService(SERVICE_STOP, SERVICE_CONTROL_STOP);
end;