пятница, 14 апреля 2017 г.

Как встроить в приложение службу

Некоторое время назад (как же быстро оно пролетает!) вдруг оказалось, что только я (ленивый из поговорки) не писал служб, а вот практически все мои немногочисленные знакомые уже давным давно это делали. Так давно, что им даже трудно было припомнить для меня что-нибудь интересное кроме того факта, что у служб нет пользовательского интерфейса - для ввода параметров нужна отдельная программа. А когда я интересовался, можно ли программу пользовательского интерфейса совместить с самой службой в одном EXE, мне говорили, что это мысль, конечно, интересная, и только желали удачи. И тогда, странно ощущая себя первопроходцем на давно истоптанной территории, я решил додумать свою мысль до получения практического результата. И сделал это. А как - я сейчас расскажу.



Раньше я думал, что службы - это что-то такое либо сугубо серверное, когда требуется нести большую и тяжёлую нагрузку, либо что-то глубоко системное, связанное с безопасностью или доступом к каким-то специальным устройствам. Я и не думал, что мне, простому прикладному программисту, когда-нибудь придётся самому этим заниматься.



Но когда в один прекрасный день ко мне обратились с предложением переделать моё приложение в службу, вдруг оказалось, что смысл будущей трансформации вовсе не в том, чтобы повысить какую-то производительность процесса, а в том, чтобы понизить стоимость обслуживания.

Главным образом службы отличаются от простых приложений тем, что службы могут работать с момента запуска системы, не требуя  для своего запуска вхождения в систему какого-либо пользователя. Благодаря этому, как меня уверяли системные администраторы нашей компании, службы очень хорошо себя чувствуют в каких-то там кластерах. Это странное обстоятельство почему-то настолько по душе администраторам, что ради того, чтобы служба работала без пользователя, они готовы были вообще отказаться от графического интерфейса!
 

В принципе, графический интерфейс как средство ввода и валидации параметров для функционирования службы - вещь нужная. И желательно бы иметь под рукой также ещё и как средства управления запуском и остановкой службы, так и средства мониторинга состояния - актуальную информацию и архив.

Интернет сообщил мне, что в старые времена (ничего нового я не нашёл) программисты для этих целей создавали особые DLL с расширением CPL для панели управления (шаблон "Control Panel Application" в Делфи) и даже специальные такие открываемые в майкрософтовской консоли древообразные MSC-штуки, рецепт создания которых утерян делфянами лет 10 тому назад. А для мониторинга Великая Сеть рекомендовала использовать Журнал событий системы, чему первым делом посвящалось очень много страниц в литературе по созданию служб. Я читал эти главы с большим удовольствием.

Но первое, что мне объяснили наши системные администраторы - им совершенно не хочется работать с мелкомягким журналом. Для мониторинга им был нужен простой текстовый файл. А второе - не нужно им консолей и панелей, достаточно самого обычного приложения. Прямо гора с плеч!

Особо меня порадовало, что не обязательно выкидывать созданный непосильным трудом, являющий собой образчик тонкого вкуса, гениального озарения и строго научного подхода прекрасный графический пользовательский интерфейс моего прекрасного приложения. Но, разумеется, выбрасывать и постепенно переделывать кое-что пришлось.

Особенно в интерфейсе пострадали всяческие "ничегометры", призванные развлекать запустившего программу пользователя разноцветной демонстрацией кипучей внутренней деятельности. Беда этих милых мигающих и переливающихся штучек в том, что они были сделаны у меня через синхронизацию между основным пользовотельскоинтерфейсным потоком и фоновым, исполняющим работу. В случае же выполнения работы службой синхронизацию надо заменять механизмами межпроцессного взаимодействия - а это уже совсем другая песня, для которой тогда у меня совершенно не было настроения. Но я не сильно жалею об их потере: на всю эту красоту всё равно месяцы напролёт совершенно никто не смотрел.
 

Также значительно пришлось перестроить и внутренний мир приложения. Чтобы выделить рабочий процесс в отдельное приложение пришлось сильно причесать связи между процессом и интерфейсом - убрать глобальные переменные и прямые обращения к свойствам и методам, выделить общий функционал (чтение/сохранение параметров, запись/чтение журнала и т.п.) в отдельные модули, вынести в фоновый поток всё, что можно, оставив снаружи только Пуск/Стоп и для особого случая ещё "Ты там закончил?" Рефакторинг, когда он необходим - только в радость.
 

Выделенный таким образом "процесс" приложения я вставил в службу, которую делает Дельфи по шаблону "Service Application". Как ни странно на не вооружённый знаниями первый взгляд, создаваемое служебное приложение - это ещё не сама служба, а лишь контейнер для (возможно нескольких!) служб, одна из которых сразу в виде наследника от TService создаётся в отдельном модуле, чтобы мы его (её?) настроили под собственные нужды. Что интересно, TService - потомок обычного модуля данных, и вполне спокойно может обитать внутри даже самых обычных приложений.



Текст служебного проекта выглядит как самое обычное приложение. Если, конечно, не обращать внимание на огромный комментарий.

program Project13;
uses
  Vcl.SvcMgr,
  Unit13 in 'Unit13.pas' {Service13: TService};

  {$R *.RES}

begin
  // Windows 2003 Server requires StartServiceCtrlDispatcher to be
  // called before CoRegisterClassObject, which can be called indirectly
  // by Application.Initialize. TServiceApplication.DelayInitialize allows
  // Application.Initialize to be called from TService.Main (after
  // StartServiceCtrlDispatcher has been called).
  //
  // Delayed initialization of the Application object may affect
  // events which then occur prior to initialization, such as
  // TService.OnCreate. It is only recommended if the ServiceApplication
  // registers a class object with OLE and is intended for use with
  // Windows 2003 Server.
  //
  // Application.DelayInitialize := True;
  //
  if not Application.DelayInitialize or Application.Installing then
    Application.Initialize;
  Application.CreateForm(TService13, Service13);
  Application.Run;
end.

После недолгого ознакомления оказалось, что ничего страшного в этом служебном приложении нет. Это действительно почти обычное приложение, которое даже использует обычное Vcl.Forms.Application для регистрации всех форм и модулей данных, которые не унаследованы от TService. Более того, никто извне, кроме самого приложения, не может зарегистрировать службу в системе, т.к. нет никаких особо экспортируемых функций, специально скомпилированных разделов, манифестов и прочей подобной ерунды. А регистрируется (и удаляется) служба самим приложением по сигналу из командной строки параметрами /INSTALL и /UNINSTALL. Т.е. служебный EXE изначально задуман с одной стороны как служба, а с другой - как приложение управления службой. А я-то думал, что первый до этого догадался!

И вот, подключив в старый проект только что созданный служебный модуль и взяв кусок исходника нового служебного проекта я получил примерно (сами понимаете, что переделывая разные приложения получаешь некоторые разности) это: 

program gsm2gd;
{$R 'elm0.res' 'elm0.rc'} //EventLog message patern
uses
  Vcl.Forms,
  uMain in 'uMain.pas' {gsm2gdMain},
  adoutils,
  uProcess in 'uProcess.pas',
  uSettings in 'uSettings.pas',
  uCalendar in 'uCalendar.pas' {frmCalendar},
  uWildCards in 'uWildCards.pas' {WildCardsEditor},
  uGetVersion in 'uGetVersion.pas',
  uPrevInst in 'uPrevInst.pas',
  uWindowPlacement in 'uWindowPlacement.pas',
  Vcl.SvcMgr,
  uSvc in 'uSvc.pas',
  uService in 'uService.pas' {gsm2gd_Service: TService},
  uLog in 'uLog.pas';

{$R *.res}

begin
  if uSvc.IsService or Application.Installing then begin
    // Windows 2003 Server requires StartServiceCtrlDispatcher to be
    // called before CoRegisterClassObject, which can be called indirectly
    // by Application.Initialize. TServiceApplication.DelayInitialize allows
    // Application.Initialize to be called from TService.Main (after
    // StartServiceCtrlDispatcher has been called).
    //
    // Delayed initialization of the Application object may affect
    // events which then occur prior to initialization, such as
    // TService.OnCreate. It is only recommended if the ServiceApplication
    // registers a class object with OLE and is intended for use with
    // Windows 2003 Server.
    //
    // Application.DelayInitialize := True;
    //
    if not Application.DelayInitialize or Application.Installing then
      Application.Initialize;
    Application.CreateForm(Tgsm2gd_Service, gsm2gd_Service);
    Application.Run;
  end
  else begin
    Vcl.Forms.Application.Initialize;
    Vcl.Forms.Application.MainFormOnTaskbar := True;
    Vcl.Forms.Application.Title := '';
    //
    Application.CreateForm(Tgsm2gd_Service, gsm2gd_Service);
    //
    Vcl.Forms.Application.CreateForm(Tgsm2gdMain, gsm2gdMain);
    if PreviousInstanceFound then
      Exit;
    Vcl.Forms.Application.Run;
  end;
end.

Так как Vcl.SvcMgr перекрывает Vcl.Forms.Application, приходится указывать полную спецификацию. Это не сложно. Сложно понять, запущено приложение как служба системой или как приложение пользователем. Я решил переключать режим ЕХЕ по параметру командной строки, который укажу в пути к приложению при регистрации службы.


unit uSvc;
...
function IsService: Boolean;
...
implementation
...
function IsService: Boolean;
begin
  Result := FindCmdLineSwitch( 'svc', ['-', '/'], True);
end;

Сначала я хотел использовать параметр /SERVICE, но просматривая зарегистрированные в системе службы заметил, что Корпорация Добра использует именно "svc". Они тоже используют параметр командной строки и даже назвали его практически так же, как я свой модуль! Боже, как я неоригинален! Ну, значит, мы на верном пути.

В материалах интернета, что я при этом читал, про DelayInitialize ничего на глаза не попалось. Зато достаточно написано про то, что Дельфи не предоставляет возможность при регистрации службы добавить описание, которое должно отображаться в списке служб Windows. А ещё Делфи не генерирует специальный шаблон сообщений для Журнала событий Windows и никак  в Журнал событий не прописывает службу, без чего при Просмотре событий Windows показывает непристойные сообщения о недоступности источника шаблонов из-за вашей (вот, что особенно возмущает!) коррумпированности. Я не силён в английском, но понятно, что это всё никуда не годится.

Кроме того, мне же ещё нужно указать в регистрационной информации о службе тот самый параметр-переключатель "svc". Хотя реализованная в Делфи регистрация про параметры командной строки службы ничего знать не хочет, я не стал переписывать штатный метод регистрации из Vcl.SvcMgr, а, как учили предшественники,  использовал стандартные события служебного модуля, который, кстати говоря, сохранил как uService.pas. 

unit uService;
...
type
  Tgsm2gd_Service = class(TService)
...
implementation
...
uses
  uSvc, uProcess;
...
procedure Tgsm2gd_Service.ServiceAfterInstall(Sender: TService);
begin
  SvcAfterInstall( 'Загрузка телефонных разговоров в базу ГранДока.' );
end;

procedure Tgsm2gd_Service.ServiceAfterUninstall(Sender: TService);
begin
  SvcAfterUninstall;
end;

Вы видите, что теперь у меня после регистрации/разрегистрации службы проводится дополнительная работа. Как и что при этом делается можно увидеть ниже.

unit uSvc;
...
procedure SvcAfterInstall( const ADescription: String );
procedure SvcAfterUninstall;
...
implementation
...
procedure SetDescriptionAndPath( const ADescription, APath: String );
var
  SvcMgr     : SC_HANDLE;
  Svc        : SC_HANDLE;
begin
  SvcMgr := OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);
  if SvcMgr <> 0 then
  try
    Svc := OpenService(SvcMgr, PChar( GetInstance.Name ), SERVICE_ALL_ACCESS);
    if Svc <> 0 then
    try
      ChangeServiceConfig( Svc,
        SERVICE_NO_CHANGE, SERVICE_NO_CHANGE, SERVICE_NO_CHANGE,
        PChar( APath ),
        nil, nil, nil, nil, nil, nil );
      ChangeServiceConfig2( Svc, SERVICE_CONFIG_DESCRIPTION, @ADescription );
    finally CloseServiceHandle(Svc);
    end;
  finally CloseServiceHandle(SvcMgr);
  end;
end;

const
  KeyLog = '\SYSTEM\CurrentControlSet\Services\Eventlog\Application\';
//  KeyCfg = '\SYSTEM\CurrentControlSet\Services\';

procedure SvcAfterInstall( const ADescription: String );
var
  FilePath: String;
begin
  FilePath := ParamStr(0);
  with TRegistry.Create(KEY_ALL_ACCESS) do
  try
    RootKey := HKEY_LOCAL_MACHINE;
    // Создаём системный лог для себя
    OpenKey( KeyLog + GetInstance.Name, True);
    WriteString( 'EventMessageFile', FilePath );
    WriteInteger('TypesSupported', 7);
    // Прописываем себе описание и параметр
//    OpenKey( KeyCfg + Sender.Name, True);
//    WriteString( 'Description', ADescription );
//    WriteString( 'ImagePath', '"' + FilePath + '" /svc' );
    SetDescriptionAndPath( ADescription, '"' + FilePath + '" /svc' );
  finally Free;
  end;
end;

procedure SvcAfterUninstall;
begin
  with TRegistry.Create(KEY_ALL_ACCESS) do
  try
    RootKey := HKEY_LOCAL_MACHINE;
    // Удалим свой системный лог
    DeleteKey( KeyLog + GetInstance.Name );
  finally Free;
  end;
end;

Хочу сказать, что старая школа программирования для тюнинга регистрационных данных использовала исключительно правку реестра. И это работало и у меня даже спустя десятилетия после изобретения чудо-метода. Но мой антивирус так стонал каждый раз при изменении информации о службе после её регистрации, а регистрировал я службу при отладке приложения так часто, что мне это достаточно быстро надоело, и я по материалам MSDN написал SetDescriptionAndPath, которая использует исключительно специально для этого предусмотренный API. Он какой-то странный этот API, но работает, и антивирус меня больше не дёргает по пустякам. А на относящиеся к Журналу событий остальные манипуляции в реестре моему антивирусу фиолетово.


Красота! Разглядывая результат своей деятельности я подумал: а не пишет ли Cisco System, Inc. некоторые свои службы на Delphi? Ведь именно так - без описания - выглядела и моя служба до модернизации процесса её регистрации.

Но с журналом событий чтобы работать одной регистрации в реестре недостаточно. Нужен ещё очень особый специальный подключаемый к приложению ресурс, получаемый из особого специального скрипта, компилируемого не менее особенной и не менее специальной программой. Это у меня как раз "elm0.res", подключение которого вы могли заметить в исходниках проекта сразу после строки заголовка.

Суть этого ресурса проста - шаблоны сообщений. Вы пишете на разных языках общие фразы, снабжаете их форматированием параметров и указываете в журнале событий только идентификаторы этих фраз и параметры. А когда пользователь читает журнал, он видит развёрнутые сообщения, которые журнал ему собирает из своих записей по шаблону, взятому из файла вашей программы. И даже можно не из вашей, если вы зарегистрируете ещё какой-нибудь источник шаблонов. Например, можно брать сообщения о системных ошибках из User32.exe.

Я - не международная корпорация, мне эти все хитрости ни к чему. Но Делфи, хоть и не имеет никаких шаблонов сообщений, всё же при возникновении исключений пишет в журнал событий, используя 0(ноль) как идентификатор шаблона сообщений. Представьте, как я весь такой заинтригованный вопросом "что же там интересного случилось?", открываю Просмотр событий, нахожу свою службу, смотрю и вижу, что там - какая-то (прошу прощения) скверна. Обидно!

 Чтобы такого не было, я, начитавшись разного, написал следующий текстовый файл в кодировке UTF-16LE, который назвал elm0.mc (Even Log Message with id=0, for Message Compiller). 

 elm0.mc
LanguageNames=(English=0x409:MSG00001)
MessageId=0x0
Language=English
%1


.

NB! После точки есть возврат строки.

 Я не сразу пришёл к такому аскетизму - долго тренировался, пробовал разные слова писать в различных кодировках (ANSI, UTF-8, UTF-32 и пр.). И в итоге остановился на этом простом варианте. Но с кодировками - это я разбирался уже потом. А если по хронологии, то... 

Потом я искал у себя на компе компилятор MC.EXE, которых нашёл на диске в разных SDK пол-десятка. Всякие х64 я побоялся трогать, взял скромно из C:\Program Files (x86)\Microsoft SDKs\Windows\v7.0A\Bin, запустил MC -u -U elm0.mc и... Тут у меня промашка вышла, т.к. я не хотел писать длинные пути в командной строке, и поэтому скопировал скрипт прямо в BIN, не смотря на окрик системы о каких-то там администраторских правах. Вот когда я увидел сообщение о том, что файл скомпилирован, а никаких новых файлов не увидел, я поступил иначе - скопировал MC.EXE в свою папку со скриптом. 

И теперь у меня кроме  новенького ненужного elm0.h есть нужный elm0.rc и просто необходимый MSG00001.bin.

elm0.rc
LANGUAGE 0x9,0x1
1 11 "MSG00001.bin"

MSG00001.bin
01 00 00 00 00 00 00 00 00 00 00 00 10 00 00 00
10 00 01 00 25 00 31 00 0D 00 0A 00 00 00 00 00

Эти .rc и .bin я теперь вставляю во все свои служебные приложения. Можно для подключения использовать менеджер проекта, а можно прописать и вручную. Строку подключения к проекту - {$R 'elm0.res' 'elm0.rc'} - вы видели.



Но зарегистрировать службу - это ещё не всё. Надо же её запустить! И, при желании, остановить не помешало бы. Сама регистрация даже со свойством служебного модуля StartType=stAuto (не забудьте проверить, что установлено так) ещё не приводит к запуску. Странно?

Приходится идти в Панель управления, Администрирование, Службы, искать свою службу и запускать. Или останавливать. Ну, это не дело! Поэтому мой модуль uSvc.pas включает в себя ещё несколько вещей, которые отвечают за пуск, остановку и, что очень важно при работе со службами - получение текущего состояния службы. А состояний у неё может быть много.


unit uSvc;


interface
...
type
  TSvcStatus = (
    UNKNOWN,//                = 0
    STOPPED,//                = $00000001;
    START_PENDING,//          = $00000002;
    STOP_PENDING,//           = $00000003;
    RUNNING,//                = $00000004;
    CONTINUE_PENDING,//       = $00000005;
    PAUSE_PENDING,//          = $00000006;
    PAUSED, //                = $00000007;
    ACCESS_DENIED);//         = $00000008;
const
  SvcStatusName: array[ TSvcStatus ] of String = (
    'Не зарегистрирована'
    , 'Остановлена'
    , 'Стартует'
    , 'Останавливается'
    , 'Работает'
    , 'Снимается с паузы'
    , 'Приостанавливается'
    , 'Приостановлена'
    , 'Нужны права администратора!');

Состояния с 1-7 - это то, что описано в API. Состояние 0 - это неудача при попытке открыть службу, а 8 - неудача открытия менеджера служб (при отладке запускайте Делфи от имени администратора). 

unit uSvc;
...
var
  SvcStatus: TSvcStatus;
...
function SvcGetStatus: TSvcStatus;
...
implementation
...
function SvcGetStatus: TSvcStatus;
var
  SvcMgr     : SC_HANDLE;
  Svc        : SC_HANDLE;
  LStatus    : SERVICE_STATUS_PROCESS;
  StatusSize : DWORD;
begin
  Result := TSvcStatus.UNKNOWN;
  try
    SvcMgr := OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);
    if SvcMgr = 0 then
      Exit( TSvcStatus.ACCESS_DENIED );
    try
      Svc := OpenService(SvcMgr, PChar( GetInstance.Name ), SERVICE_ALL_ACCESS);
      if Svc = 0 then
        Exit;
      try
        if not QueryServiceStatusEx( Svc, SC_STATUS_PROCESS_INFO, @LStatus, SizeOf( LStatus ), StatusSize ) then
          Exit;
        Result := TSvcStatus( LStatus.dwCurrentState );
      finally CloseServiceHandle(Svc);
      end;
    finally CloseServiceHandle(SvcMgr);
    end;
  finally SvcStatus := Result;
  end;
end;

Кто-то, возможно, спросит, зачем я завёл в uSvc.pas глобальную переменную SvcStatus. Это чтобы не заводить локальную переменную там, где состояние службы нужно оценить более одного раза за один раз. Ну, вы понимаете.

Кстати, пришла, наверно, пора рассказать о GetInstance. Я подразумеваю, что в моих EXE не будет более чем одной службы, т.е. более чем одного служебного модуля. И не менее. Поэтому мне достаточно одной ссылки на экземпляр наследника TService.

 
unit uSvc;
...
implementation
...
var
  Reference: TService;

function GetInstance: TService;
var
  C: TComponent;
begin
  if not Assigned( Reference ) then
  for C in Vcl.SvcMgr.Application do
  if C is TService then begin
    Reference := TService( C );
    Break;
  end;
  Result := Reference;
end;


Вообще, разглядывая uSvc.pas может показаться, что от потомка TService ничего не нужно, кроме имени. Наверно, можно было бы просто в глобальную переменную положить это имя при инициализации служебного модуля и отказаться от создания экземпляра при работе в режиме пользовательского интерфейса. Но нет, нельзя: экземпляр службы обязательно нужен при регистрации, что происходит именно в режиме пользовательского интерфейса.

Пора перейти к методу запуска/остановки службы:

unit uSvc;
...
procedure SvcRun(StartStop: Boolean);
...
implementation
...
type
  TMyServiceApplication = class(TServiceApplication)
  end;

procedure SvcRun(StartStop: Boolean);
//
  procedure Start;
  var
    SvcMgr     : SC_HANDLE;
    Svc        : SC_HANDLE;
    Args       : LPCWSTR;
  begin
    SvcMgr := OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);
    if SvcMgr <> 0 then
    try
      Svc := OpenService(SvcMgr, PChar( GetInstance.Name ), SERVICE_ALL_ACCESS);
      if Svc <> 0 then
      try
        Args := nil;
        if not StartService( Svc, 0, Args ) then
          MessageBox( 0, PChar( SysErrorMessage(GetLastError) ), 'StartService', MB_ICONEXCLAMATION );
      finally CloseServiceHandle(Svc);
      end;
    finally CloseServiceHandle(SvcMgr);
    end;
  end;
//
  procedure Stop;
  var
    SvcMgr     : SC_HANDLE;
    Svc        : SC_HANDLE;
    LStatus    : SERVICE_STATUS;
  begin
    SvcMgr := OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);
    if SvcMgr <> 0 then
    try
      Svc := OpenService(SvcMgr, PChar( GetInstance.Name ), SERVICE_ALL_ACCESS);
      if Svc <> 0 then
      try
        ControlService( Svc, SERVICE_CONTROL_STOP, LStatus )
      finally CloseServiceHandle(Svc);
      end;
    finally CloseServiceHandle(SvcMgr);
    end;
    TMyServiceApplication( Vcl.SvcMgr.Application ).RegisterServices( False, True );
  end;
//
  function WaitFor(const AStatus: TSvcStatus ): Boolean;
  var
    I: Integer;
  begin
    for I := 1 to 10 do begin
      if SvcGetStatus = AStatus then
        Exit( True );
      Sleep( 500 )
    end;
    Result := False;
  end;
//
begin
  if SvcGetStatus = TSvcStatus.ACCESS_DENIED then
    Exit;
  if StartStop then begin
    if SvcGetStatus <> TSvcStatus.UNKNOWN then begin
      Stop;
      if not WaitFor( TSvcStatus.UNKNOWN ) then
        Exit;
    end;
    TMyServiceApplication( Vcl.SvcMgr.Application ).RegisterServices( True, True );
    WaitFor( TSvcStatus.STOPPED );
    Start;
  end
  else
    Stop;
end;

Во-первых замечу, что я использую штатный метод  RegisterServices, который protected. Для этого я объявил класс-обманщик TMyServiceApplication. Во-вторых, и это главное - мысль, которую я держал в голове при разработке: иметь только самое простое управление при помощи двух кнопок Старт/Стоп. Или даже одной.

Поэтому перед стартом службы надо проверить наличие регистрации и зарегистрировать её, если нужно. А если Старт нажали, когда служба уже запущена, то надо сделать рестарт - остановить и запустить заново. Таким образом осуществляется загрузка обновлённых параметров из пользовательского приложения в службу.

Остановка у меня подразумевает сразу и удаление службы. Благодаря этому можно без лишних опасений спокойно поменять версию или расположение приложения.

Я не вижу смысла делать у службы паузу (у меня везде AllowPause=false), но считаю, что остановка (AllowStop=True) - это очень важно: кроме того, что администратор может через панель управления остановить вашу службу, вы ещё и сами сможете посылать в свою службу команду SERVICE_CONTROL_STOP. В противном случае AllowStop не только отключит команду в системной панели управления, но и не позволит остановить службу через API. 

 Вообще команды в службу приходят как wParam Windows-сообщения CM_SERVICE_CONTROL_CODE. Но обработчик сообщений в Делфи ставит заглушку на всё, что не является командой. Я пробовал обойти это ограничение, отправляя службе для остановки SERVICE_CONTROL_SHUTDOWN, но этот трюк не сработал. В принципе, если очень хочется, можно изобрести какие-то свои флаги в системе, за которыми будет следить ваша служба. Но лично я без этого пока прекрасно обхожусь.

Подробно рассмотрев модуль uSvc.pas, перейдём к вопросу, как заключённую в  нём мощную силу применить на практике. Вот, например, главная форма приложения, исходники которого служат мне сейчас примером для написания статьи (заметки? поста? хвастливого опуса?).



Всё довольно просто. Во-первых есть таймер, который раз в секунду делает следующее: 

procedure Tgsm2gdMain.Timer1Timer(Sender: TObject);
//
  function LastInfo(ALM: TGetLastMsg; APrefix, ADefault: String): String;
  begin
    if ALM.Msg <> '' then
      Result := Format( '%s: %s'#13'%s', [
        APrefix, DateTimeToStr( ALM.dt ), ALM.Msg ] )
    else
      Result := ADefault;
  end;
//
var
  Waiting: Boolean;
begin
  laLastNews.Caption := Format( '%s'#13'%s', [
    LastInfo( uLog.GetLastFail, 'Последняя ошибка', 'Сбоев не зафиксировано.' ),
    LastInfo( uLog.GetLastFile, 'Последний файл', 'Сведения о загруженных файлах отсутствуют.' )
  ]);
  Waiting := SvcGetStatus in [ START_PENDING, STOP_PENDING, CONTINUE_PENDING, PAUSE_PENDING, ACCESS_DENIED];
  pbStartStop.Enabled := not Waiting;
  Screen.Cursor := WaitCurs[ Waiting and (SvcStatus <> ACCESS_DENIED)];
  if uSettings.bOneDay and ( SvcStatus = RUNNING ) then
    StatusBar1.SimpleText := Format('Выполнено: %.2f%%', [ uLog.GetPercent * 100 ] )
  else
    StatusBar1.SimpleText := 'Служба: ' + SvcStatusName[ SvcStatus ];
end;

Функции GetLastХХХ из модуля uLog читают из реестра записанные туда процессом службы значения, чтобы открыв приложение можно было лишний раз не заглядывать в его журнал. Также во время ожидания смены состояния службы кнопка "Пуск/Стоп" выключается, чтобы, например, не запускать уже запускаемую, но ещё незапущенную службу. В конце заполняется строка состояния.

 Особенностью данного приложения является возможность работы по-старому, под непосредственным управлением пользователя. Жизнь такая штука, что приходится иногда выключать автопилот, и брать штурвал в свои руки. У нас это редко, но случается, когда надо занести в базу данных какие-то документы задним числом. Тогда начальник(!) отдела сопровождения запускает приложение, устанавливает дату для обработки, и нажимает кнопку Пуск. В таком ручном режиме служба, обработав один раз каталог файлов, прекращает дальнейшее слежение, завершает работу, и можно её запустить на другую дату, или пустить снова в бесконечность и закрыв приложение уйти, оставив службу самостоятельно трудиться на благо компании. 

 Плохо, если пользователь не знает, как скоро он может закрыть, уйти или просто выйти. Поэтому процесс пишет в реестр процент отработанного списка файлов, а приложение раз в секунду показывает это пользователю. После того, как я вернул приложению процентики, мне сказали, что "программа стала работать значительно быстрее". Не вру, так всё и было.

const
  WaitCurs: array[Boolean] of TCursor = ( crDefault, crHourGlass );

procedure Tgsm2gdMain.pbStartStopClick(Sender: TObject);
var
  DoStart: Boolean;
begin
  DoStart := SvcGetStatus <> TSvcStatus.RUNNING;
  if DoStart then
  try FSettingsCache := uSettings.Store( uSettings.Check( vle.Strings ) ).Text;
  except on E: Exception do begin
    vle.Col := 1;
    vle.Row := E.HelpContext;
    vle.SetFocus;
    ShowMessage( E.Message );
    Exit;
  end; end;
  Screen.Cursor := WaitCurs[ True ];
  try  SvcRun( DoStart );
  finally Screen.Cursor := WaitCurs[ False ];
  end;
end;

А код выше - кнопка Пуск/Стоп. Перед запуском я проверяю и сохраняю параметры, которые у меня находятся в строках компонента vle: TValueListEditor. Если проверка покажет что-то неправильное, я установлю фокус на нужную строчку в таблице и покажу объявление. А если всё хорошо, то запущу службу. Заметьте - запущу не процесс обработки файлов, как это было раньше, а службу. Или остановлю. А процесс будет запущен или остановлен уже в самой службе. Вот так:

procedure Tgsm2gd_Service.ServiceExecute(Sender: TService);
begin
  uProcess.Run;
  repeat
    if uProcess.IsDead then
      Exit;
    Sleep(1000);
    ServiceThread.ProcessRequests( False );
    If Terminated then
      uProcess.Stop;
  until Terminated;
end;

Это событие OnExecute в служебном модуле. Мы здесь видим запуск процесса, который есть параллельный поток, а потом идёт цикл, в котором каждую секунду мы проверяем, не закончилось ли выполнение процесса обработки (uProcess.IsDead) и не пришла ли от нашего приложения или Менеджера служб (ProcessRequests...If Terminated then...) команда остановить службу.

 Если у службы не определён обработчик OnExecute, что вполне возможно, если вы используете только событие OnStart, то для обработки событий просто запускается ProcessRequests с включённым флагом WaitForMessage. Флаг влияет на выборку Windows-сообщений из очереди. Если никакого события пока нет, то GetMessage будет его ждать, а альтернативная PeekMessage в этом случае просто вернёт False, и произойдёт выход из процедуры.

 
procedure TServiceThread.ProcessRequests(WaitForMessage: Boolean);
var
...
begin
  while True do
  begin
    if Terminated and WaitForMessage then break;
    if WaitForMessage then
      Rslt := GetMessage(msg, 0, 0, 0)
    else
      Rslt := PeekMessage(msg, 0, 0, 0, PM_REMOVE);
    if not Rslt then break;
...

Странный, конечно, while True с тут же следующим if...Break. Но не суть. Вернёмся к Tgsm2gd_Service.ServiceExecute.

Если пришла пора остановится из-за просьбы приложения или выключения системы, одним из обработчиков команд будет поднят флаг Terminated, увидев который, мы скажем Stop и процессу. uProcess.Stop - это уже не проходной метод, это метод, который дожидается завершения потока процесса.

unit uProcess;
interface

  procedure Run;
  procedure Stop;
  function IsDead: Boolean;

implementation
uses
  System.Classes, System.SysUtils, Data.Win.ADODB,
  System.IOUtils, System.Types, System.StrUtils, Winapi.ActiveX,
  System.DateUtils,
  ADOUtils,
  uSettings, uLog;
...
type
  TProcess = class(TThread)
...
    FSettings: TStringList;
...
    procedure Execute; override;
...
  end;
...
var
  T: TThread;

procedure Run;
begin
  if T = nil then
    T := TProcess.Create;
end;

procedure Stop;
begin
  If T<>nil then
    T.Terminate;
  while T<>nil do 
    Sleep(100);
end;

function IsDead: Boolean;
begin
  Result := T = nil;
end;
...
procedure TProcess.Execute;
...
begin
  try //  T := nil;
    FSettings := TStringList.Create;
    try
      try
        FStatus := 'Проверка параметров...';
        CoInitialize(nil);
        uSettings.Check( uSettings.Restore( FSettings ) );
      except on E: EArgumentException do begin
        Fail( E.Message );
        Exit;
      end; end;
...
      repeat
...
       if Terminated then
         Exit;
...
      until False
...
    finally FreeAndNil( FSettings );
    end;
  finally T := nil;
    uLog.Debug( 'Конец выполнения' );
  end;
end;

В своё время модуль uProcess было просто сгенерирован Делфи по шаблону Thread Object. Чтобы исключить неконтролируемые связи, я перенёс декларацию класса в секцию реализации, оставив снаружи в интерфейсной части всего три команды, которые, я думаю, в особых комментариях не нуждаются. Вот разве что вопрос почему я обнуляю T не в Destroy, а в finally - я отвечу, что так мне удобнее. Да.

В завершение рассказа о встраивании службы в это приложение приведу метод запроса на завершение приложения.

procedure Tgsm2gdMain.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
  CanClose := ( vle.Strings.Text = FSettingsCache )  or (
  Application.MessageBox(
    'Игнорировать изменения и закрыть программу?','Закрыть gsm2gd',
    MB_YESNO + MB_DEFBUTTON2 ) = IDYES);
  if CanClose and (SvcGetStatus = TSvcStatus.STOPPED) then
  case  Application.MessageBox(
    'Удалить остановленную службу из Windows?','Закрыть gsm2gd',
    MB_YESNOCANCEL + MB_DEFBUTTON1 ) of
  IDYES: uSvc.SvcRun( False );
  IDCANCEL: CanClose := False;
  end;
end;

Первое. Перед выходом я информирую пользователя, если то, что он видит в форме не соответствует тому, что было записано в конфигурацию перед запуском службы. Возможно, ему захочется вернуться и перезапустить службу с новыми параметрами.

Второе. Закрывая приложение мы (я и пользователь приложения) подразумеваем, что запущенная служба будет продолжать работать в фоновом режиме. Если служба не работает, но осталась зарегистрированной, то скорее всего имело место использование односуточного режима, выполнение которого уже закончилось. И возможно, что пользователь просто забыл запустить службу в режиме постоянного слежения. Я не подталкиваю пользователя к действию (мой пользователь не глупее меня), но даю возможность исправить ситуацию, если это всего лишь досадное упущение.

Что ещё можно сказать о переделке этого приложения? Пожалуй, что она была не самой простой. Вот, например, переделывать Веб-сервис (или тоже службу?) - вообще легче лёгкого. А давайте, прямо сейчас сделаем такой Web-Windows-Service? Это действительно просто.

I. Создаём для начала нормальное приложение.

1.Создаём приложение по шаблону

 File|Close All File|New|Other..., Delphi Projects\Web Broker\Web Server Application, Ok
Stand-alone application --> VCL application --> Finish
File|Save All, Новая папка 'WebWinService1' , войти в папку 'WebWinService1', FormUnitX - как 'uMain', WebModuleUnitX - как 'uWeb', ProjectX - как 'WebWinService1'.

2.Добавляем конфигурационный модуль

File|New|Unit - Delphi
File|Save - 'uSettings' 

unit uSettings;

interface

procedure Put( const AName, AValue: String );
function Get( const AName, ADefault: String ): String;

implementation
uses
  System.IniFiles, VCL.Forms, System.SysUtils;

function CreateIni: TIniFile;
begin
  Result := TIniFile.Create( ChangeFileExt( Application.ExeName, '.ini' ) );
end;

const
  sSettings = 'Settings';

procedure Put( const AName, AValue: String );
begin
  with CreateIni do
  try      WriteString( sSettings, AName, AValue );
  finally  Free;
  end;
end;

function Get( const AName, ADefault: String ): String;
begin
  with CreateIni do
  try      Result := ReadString( sSettings, AName, ADefault );
  finally  Free;
  end;
end;

end.
File|Save

3.Настраиваем функционал

uWeb
Design (напоминаю про F12)
Object Inspector\Properties, Name := 'Web'
Structure, Actions, Add Item
Object Inspector\Properties,  Name := 'List', Path := '/api/list', \Events, создать OnAction. К стыду разработчиков Делфи почему-то в выпадающем списке команды "Создать метод" нет, мы вынуждены использовать секретный приём "Двойной клик".

procedure TWeb.WebListAction(Sender: TObject; Request: TWebRequest;
  Response: TWebResponse; var Handled: Boolean);
var
  LPath: String;
  LMask: String;
  SR: TSearchRec;
  JA: TJSONArray;
begin
  try //except
    LPath := uSettings.Get( 'Path', '.' );
    LMask := Request.ContentFields.Values[ 'Mask' ];
    if String.IsNullOrWhiteSpace( LMask ) then
      LMask := '*';
    with TJSONObject.Create do
    try
      AddPair( 'path', LPath ).AddPair( 'mask', LMask );
      JA := TJSONArray.Create;
      AddPair( 'list', JA );
      if FindFirst( TPath.Combine( LPath, LMask ), faAnyFile, SR) = 0 then
      try
        repeat
          if SR.Attr and System.SysUtils.faDirectory = 0 then
            JA.AddElement( TJSONObject.Create.
              AddPair( 'name', SR.Name ).
              AddPair( 'size', TJSONNumber.Create( SR.Size ) ).
              AddPair( 'time', DateToISO8601( SR.TimeStamp ) )
            );
        until FindNext( SR ) <> 0;
      finally
        FindClose(SR);
      end;

      Response.StatusCode := 200;
      Response.ContentType := 'application/json; charset=UTF-8';
      Response.Content := ToJSON;

    finally Free; //TJSONObject.Create
    end;
  except on e: Exception do with Response do begin
    StatusCode := 500;
    ReasonString := Format( '%s: %s', [ e.ClassName, e.Message ] );
  end;  end;
end;

Я подумал, что пусть это будет не простой 'HW!', а что-то похожее на правду - так интереснее. Поэтому давайте добавим ещё одну Веб-акцию.

 Design
Structure, Actions, Add Item
Object Inspector\Properties,  Name := 'File', Path := '/api/file', \Events, создать OnAction 

procedure TWeb.WebFileAction(Sender: TObject; Request: TWebRequest;
  Response: TWebResponse; var Handled: Boolean);
//
  function QQ( const S: String ): String;
  begin
    Result := S.DeQuotedString('"').QuotedString('"');
  end;
//  
var
  LPath: String;
  LName: String;
begin
  try //except
    LPath := uSettings.Get( 'Path', '.' );
    LName := TPath.GetFileName( Request.ContentFields.Values[ 'Name' ] ); //!!! Strip any relation paths
    if String.IsNullOrWhiteSpace( LName ) then
      raise Exception.Create( 'Имя файла отсутствует.' );

    with Response do begin
      ContentType := 'application/octet-stream';
      SetCustomHeader( 'Content-Disposition', 'Attachment; filename=' + QQ( LName ) );
      ContentStream := TFileStream.Create(  TPath.Combine( LPath, LName ),  fmShareDenyNone );  
      StatusCode := 200;
    end;

  except on e: Exception do with Response do begin
    StatusCode := 500;
    ReasonString := Format( '%s: %s', [ e.ClassName, e.Message ] );
  end;  end;
end;

Было бы странно оставить наши акции без возможности их вызвать. Поэтому немного ещё.

Design
Structure, Actions\DefaultHandler
Object Inspector\Events, перейти в OnAction
Удалить код метода между begin и end, Ctrl+S (или File|Save)
Design
Structure, Actions\DefaultHandler
Object Inspector\Events, создать OnAction 

procedure TWeb.WebDefaultHandlerAction(Sender: TObject; Request: TWebRequest;
  Response: TWebResponse; var Handled: Boolean);
begin
  Response.Content := Format(
    '<html>' +
    '<head><title>WebWinService1</title></head>' +
    '<body><H1>WebWinService1</H1>' +
    'Access to folder <b>%s</b>.<br><hr>' +

    '<fieldset><form method="post" action="/api/list">' +
    'File list<br><hr>' +
    'Mask: <input type="text" name="MASK" value="*.*" >'+
    '<input type=submit value="Invoke">' +
    '</form></fieldset><br>' +

    '<fieldset><form method="post" action="/api/file">' +
    'Get file<br><hr>' +
    'File name: <input type="text" name="NAME" >'+
    '<input type=submit value="Invoke">' +
    '</form></fieldset><br>' +

    '<hr>' +
    '<i>...and there was no greater happiness than to sing in your native language!</i>' +
    '</body></html>',
    [ uSettings.Get( 'Path', TPath.GetDirectoryName( ParamStr(0) ) ) ] );
end;

Не забудем подключить библиотеки. 

implementation

{%CLASSGROUP 'Vcl.Controls.TControl'}

{$R *.dfm}

uses
  System.IOUtils, System.StrUtils,  System.DateUtils,
  uSettings;

4.Проверяем функционал

F9, Open Browser


Убедимся  в корректности сформированного JSON:

 Delphi, Tools|REST Debugger
URL:='http://localhost:8080/api/list', Content-Type:='application/json'
Tabular Data, JSON Root Element:='list', Apply
Send Request

Ура! Заработало! (© Кот Матроскин)


5.Дорабатывем пользовательский интерфейс ввода параметров

uMain
Design
Переместить "Open Browser" ниже
Выделить "Port" и "8080", Ctrl+C, Ctrl+V, выровнять копии ниже, расширить новое поле редактирования, в метку ввести "Folder", в редактор '.\' и назвать его EditFolder.



Выбрать форму, Object Inspector\Properties, Name:='Main'
Code (жаль, что это удобное F12 есть не во всех средах)
Добавить в implementation uses модуль uSettings
Вставим названия методов в декларацию формы

{ Private declarations }
    procedure GetSettings;
    procedure PutSettings;

Shift+Ctrl+C, Заполняем новые методы. 

procedure TMain.GetSettings;
begin
  EditPort.Text := uSettings.Get( 'Port', EditPort.Text );
  EditFolder.Text := uSettings.Get( 'Path', EditFolder.Text );
end;

procedure TMain.PutSettings;
begin
  uSettings.Put( 'Port', EditPort.Text );
  uSettings.Put( 'Path', EditFolder.Text );
end;

Вставить новые методы в старые

procedure TMain.FormCreate(Sender: TObject);
begin
  GetSettings;
  FServer := TIdHTTPWebBrokerBridge.Create(Self);
end;
...
procedure TMain.StartServer;
begin
  PutSettings;
  if not FServer.Active then
  begin
    FServer.Bindings.Clear;
    FServer.DefaultPort := StrToInt(EditPort.Text);
    FServer.Active := True;
  end;
end;

F9
Нормальное приложение готово. Но нам-то нужно не нормальное.

II.Оснащение Веб-сервиса службой.

1.Добавим в проект модуль uSvc.pas

unit uSvc;
interface

type
  TSvcStatus = (
...
const
  SvcStatusName: array[ TSvcStatus ] of String = (
...
var
  SvcStatus: TSvcStatus;

function IsService: Boolean;
procedure SvcAfterInstall( const ADescription: String );
procedure SvcAfterUninstall;
//GUI mode
procedure SvcRun( StartStop: Boolean );
function SvcGetStatus: TSvcStatus;

implementation
uses
  System.Classes, System.SysUtils,
  System.Win.Registry,
  Winapi.Windows, Winapi.WinSvc,
  Vcl.SvcMgr;

var
  Reference: TService;
...

Уверен, поискав выше по заголовку 'unit uSvc', вы без труда восполните недостающие детали.

2.Используем донорский проект

File|Save Project As..., Копируем путь к проекту, Esc
Project Manager, ProjectGroupX, Правая Кн Мыши, Add New Project...
Delphi Projects\Service Application
UnitX, File|Save, Вставляем каталог проекта, Сохранить, 'uService', Сохранить
Project Manager, ProjectX, Ctrl+V (исходник нового проекта), Ctrl+A (всё скопом), Ctrl+C
Project Manager, WebWinService.exe, Ctrl+V, пока вставляем всё после 'end.', File|Save
Project Manager, ProjectX, Правая Кн Мыши, Remove Project и незачем его сохранять.

Project Manager, WebWinService.exe, Правая Кн Мыши, Add..., uService.pas
WebWinService, Копируем строчку '  Vcl.SvcMgr,' перед '  uService...' в верхний uses.
Убедитесь, что SvcMgr ниже Vcl.Forms - это важно для квалифицирования имён.
К тому 'Application.', что выше 'end.', добавляем 'Vcl.Forms.', кроме 'Application.CreateForm(TService...'
Строку 'Application.CreateForm(TService...' поднимаем выше создания главной формы, чтобы можно было сразу обращаться из главной формы к экземпляру Service.

После верхнего begin ставим 'if uSvc.IsService or Application.Installing then begin', под который попадёт всё про WebRequestHandler. А уже '...Initialize;' и до самого 'end.' - оборачиваем в 'else begin...end'.
Переносим 'if not Application.DelayInitialize ...Run' из нижней части под инициализацию WebRequestHandler.

Чистим всё после 'end.', File|Save
Не покажу, как всё получилось. Считаю, что и без этого всё достаточно ясно объяснил.

3.Настраиваем службу

uService
Code
Добавляем implementation uses uSvc, uSettings.
Design
Object Inspector\Properties, AllowPause:=false (AllowStop:=true!), DisplayName:='WebWinService1', Name:='WebWinService1_Service',(StartType=stAuto), ServiceStartName := 'NT AUTHORITY\SYSTEM'.


  • Последнее отмечу особо: если каталог файлов будет сетевым('\\имякомпьютера\имяресурса'), то при пустом значении свойства ServiceStartName функция FindFirst в методе TWeb.WebListAction не найдёт вам ни "фёст", ни "секонд".


Object Inspector\Events, AfterInstall, Двойной Клик, Вписываем SvcAfterInstall( 'Web-Win-Service #1' );
Design
Object Inspector\Events, AfterUninstall, Двойной Клик, Вписываем SvcAfterUninstall;
Design
Object Inspector\Events, OnCreate, Двойной Клик
Object Inspector\Events, OnStart, Двойной Клик
Object Inspector\Events, OnStop, Двойной Клик
uMain, из interface uses вырезаем ', IdHTTPWebBrokerBridge, Web.HTTPApp' и добавляем в interface uses службы. Можно без Web.HTTPApp.
uMain, из декларации формы вырезаем 'FServer...' и переносим в декларацию службы.
uMain, из FormCreate вырезаем 'FServer...' и переносим в OnCreate службы.
uMain, из StartServer вырезаем всё 'if not FServer...' и переносим в ServiceStart службы. Сам If можно убрать, оставляем только 3 внутренние строчки. EditPort.Text меняем на uSettings.Get( 'Port', '8080' ).
uMain, из ButtonStopClick вырезаем весь и переносим в ServiceStop службы.
File|Save

4.Доделываем пользовательский интерфейс

uMain
Добавим в implementation uses модуль uSvc.
Удалим ApplicationEvents1 и очистим метод ApplicationEvents1Idle.
Уберём StartSetver из ButtonOpenBrowserClick
Добавим на форму TStatusBar  (Tool Palette\Win32), SimplePanel:=True
Добавим на форму Timer (Tool Palette\System), создадим OnTimer, пропишем


procedure TMain.Timer1Timer(Sender: TObject);
begin
  StatusBar1.SimpleText := Format(
    'Служба: %s', [ SvcStatusName[ SvcGetStatus ] ] );

  ButtonStart.Enabled := not ( SvcStatus in
  [ START_PENDING,
    STOP_PENDING,
    CONTINUE_PENDING,
    PAUSE_PENDING,
    ACCESS_DENIED ] );

  ButtonStop.Enabled := ButtonStart.Enabled;
end;

Удалим StartService
В ButtonStartClick пропишем  TControl( Sender ).Enabled := False;  PutSettings;  uSvc.SvcRun( True );
В ButtonStopClick пропишем  TControl( Sender ).Enabled := False;  uSvc.SvcRun( False );

File|Save

5.Добавляем шаблон сообщений для журнала событий

Я уже подробно рассказывал об этом. Поэтому сложностей у вас возникнуть не должно. В принципе, служба будет и без этого работать, но не советую вовсе отворачиваться от Журнала событий: отлаживать службу сложнее, чем приложение, а использовать для этого файлы в многопоточных программах - хороший шанс нарваться на блокировку. Добавьте шаблон. Пусть в нашем проекте это будет своеобразной вишенкой на торт.

6.Последний штрих

Ctrl+Shift+F11, Version Info, File Description:='Web-Win-Service #1 - It's simple like orange!'
Теперь в списке процессов можно увидеть это описание.

Запускаем, пробуем, радуемся - F9!

Ха! Было бы просто невежливо по отношению к Святому Исидору, если бы всё сразу заработало. Но, уверен, вы уже нашли ошибку в тексте проекта. Да, это название объекта службы. Что? Что-то ещё?!
Автор: на

Комментариев нет:

Отправить комментарий

Подписаться на: Комментарии к сообщению (Atom)