unit ServiceRunDLL;

interface

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


procedure ServiceMain(Argc: DWord; Argv: PLPWSTR); stdcall;
procedure InstallServices_dll(Silent: BOOL; dwSvcType, dwSvcStart: DWORD); stdcall;
procedure UnInstallServices_dll(Silent: BOOL); stdcall;


implementation

uses
  Tocsg.Trace, System.UITypes, Vcl.Dialogs, Vcl.Consts;



{$IFNDEF WIN64}
type
  TIsWow64Process = function(hProcess: THandle;var bWow64Proc: Boolean): Boolean; stdcall;

function IsWow64: Boolean;
var
  h: THandle;
  b: Boolean;
  fnIsWow64Process: TIsWow64Process;
begin
  Result := false;

  h := GetModuleHandle('kernel32');
  if h = 0 then
    exit;

  try
    fnIsWow64Process := GetProcAddress(h, 'IsWow64Process');
    if @fnIsWow64Process = nil then
      exit;

    if fnIsWow64Process(GetCurrentProcess, b) = true then
      Result := b;
  finally
    FreeLibrary(h);
  end;
end;
{$ENDIF}

function GetModuleName(): String;
begin
  SetLength(Result, MAX_PATH);
  GetModuleFileName(hInstance, PChar(Result), Length(Result));
  SetLength(Result, StrLen(PChar(Result)));
end;

type
  TServiceApplicationDerr = class (TServiceApplication);

procedure ServiceMain(Argc: DWord; Argv: PLPWSTR); stdcall;
begin
  TTgTrace.T('DLL ServiceMain called. Argc %d', [Argc]);
  TTgTrace.T('CmdLine: ' + GetCommandLine);
  TTgTrace.T('Module: ' + GetModuleName());

  TServiceApplicationDerr(Vcl.SvcMgr.Application).DispatchServiceMain(Argc, Argv);
end;

type
  TRegistryHelper = class helper for TRegistry
  public
    function ReadMultiSz(const name: string; var Strings: TStrings): boolean;
    function WriteMultiSz(const name: string; const value: TStrings): boolean;
  end;

function TRegistryHelper.ReadMultiSz(const name: string; var Strings: TStrings): boolean;
var
  iSizeInByte: integer;
  Buffer: array of WChar;
  iWCharsInBuffer: integer;
  z: integer;
  sString: string;
begin
  iSizeInByte := GetDataSize(name);
  if iSizeInByte > 0 then begin
    SetLength(Buffer, Floor(iSizeInByte / sizeof(WChar)));
    iWCharsInBuffer := Floor(ReadBinaryData(name, Buffer[0],
      iSizeInByte) / sizeof(WChar));
    sString := '';
    for z := 0 to iWCharsInBuffer do begin
      if Buffer[z] <> #0 then
      begin
        sString := sString + Buffer[z];
      end else
      begin
        if sString <> '' then begin
          Strings.Append(sString);
          sString := '';
        end;
      end;
    end;
    result := true;
  end else begin
    result := false;
  end;
end;

function TRegistryHelper.WriteMultiSz(const name: string; const value: TStrings): boolean;
var
  sContent: string;
  x: integer;
begin
  sContent := '';
  for x := 0 to pred(value.Count) do begin
    sContent := sContent + value.Strings[x] + #0;
  end;
  sContent := sContent + #0;
  result := RegSetValueEx(CurrentKey, pchar(name), 0, REG_MULTI_SZ,
    pointer(sContent), Length(sContent)*sizeof(Char)) = 0;
end;

function RegisterServices(Install, Silent: Boolean;
      dwSvcType: DWORD = DWORD(-1); dwSvcStart: DWORD = DWORD(-1)): Boolean;

  procedure InstallService(Service: TService; SvcMgr: SC_HANDLE);
  var
    TmpTagID: DWORD;
    PTag: PDWORD;
    PSSN: PChar;
    Svc: SC_HANDLE;
    Path: string;

    function GetNTServiceType: DWORD;
    const
      NTServiceType: array[TServiceType] of DWORD = ( SERVICE_WIN32_OWN_PROCESS,
        SERVICE_KERNEL_DRIVER, SERVICE_FILE_SYSTEM_DRIVER);
    begin
      with Service do
      begin
        Result := NTServiceType[Service.ServiceType];
        if (ServiceType = stWin32) and Interactive then
          Result := Result or SERVICE_INTERACTIVE_PROCESS;
        if (ServiceType = stWin32) and (Vcl.SvcMgr.Application.ServiceCount > 1) then
          Result := (Result xor SERVICE_WIN32_OWN_PROCESS) or SERVICE_WIN32_SHARE_PROCESS;
      end;
    end;

    function GetNTStartType: DWORD;
    const
      NTStartType: array[TStartType] of DWORD = (SERVICE_BOOT_START,
        SERVICE_SYSTEM_START, SERVICE_AUTO_START, SERVICE_DEMAND_START,
        SERVICE_DISABLED);
    begin
      with Service do
      begin
        Result := NTStartType[StartType];
        if (StartType in [stBoot, stSystem]) and (ServiceType <> stDevice) then
          Result := SERVICE_AUTO_START;
      end;
    end;

    function GetNTErrorSeverity: DWORD;
    const
      NTErrorSeverity: array[TErrorSeverity] of DWORD = (SERVICE_ERROR_IGNORE,
        SERVICE_ERROR_NORMAL, SERVICE_ERROR_SEVERE, SERVICE_ERROR_CRITICAL);
    begin
        Result := NTErrorSeverity[Service.ErrorSeverity];
    end;

    function GetNTDependencies: String;
    var
      I, Len: Integer;
      P: PChar;
    begin
      Result := '';
      Len := 0;
      with Service do
      begin
        for i := 0 to Dependencies.Count - 1 do
        begin
          Inc(Len, Length(Dependencies[i].Name) + 1); // For null-terminator
          if Dependencies[i].IsGroup then Inc(Len);
        end;

        if Len <> 0 then
        begin
          Inc(Len); // For final null-terminator;
          SetLength(Result, Len);
          P := @Result[1];
          for i := 0 to Dependencies.Count - 1 do
          begin
            if Dependencies[i].IsGroup then
            begin
              P^ := SC_GROUP_IDENTIFIER;
              Inc(P);
            end;
            P := StrECopy(P, PChar(Dependencies[i].Name));
            Inc(P);
          end;
          P^ := #0;
        end;
      end;
    end;

    procedure SetSvcHostParameters();
    var
      Reg: TRegistry;
      StrList: TStringList;
    begin
      Reg := TRegistry.Create(KEY_READ or KEY_WRITE);
      try
        // 이 서비스의 Parameters 기록
        Reg.RootKey := HKEY_LOCAL_MACHINE;
        if Reg.OpenKey('\SYSTEM\CurrentControlSet\services\' + Service.Name + '\Parameters', true) then
        begin
          Reg.WriteExpandString('ServiceDll', GetModuleName());
          Reg.WriteInteger('ServiceDllUnloadOnStop', 1); // 서비스 정지시 svchost가 이 DLL을 놓도록 한다.
          Reg.CloseKey();
        end;

        // svchost 의 엔트리포인트 기록
        if Reg.OpenKey('\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Svchost', false) then
        begin
          StrList:= TStringList.Create;
          try
            StrList.Text := Service.Name;
            Reg.WriteMultiSz(Service.Name, StrList);
          finally
            StrList.Free;
          end;

          Reg.CloseKey;
        end;

      finally
        Reg.Free;
      end;
    end;

  begin
    with Service do
    begin
    {$IFDEF WIN64}
      Path := '%SystemRoot%\system32\svchost.exe -k ' + Name;
    {$ELSE}
      if IsWow64 then
      begin
        Path := '%SystemRoot%\SysWOW64\svchost.exe -k ' + Name;
      end else
      begin
        Path := '%SystemRoot%\system32\svchost.exe -k ' + Name;
      end;
    {$ENDIF}

      if Assigned(BeforeInstall) then BeforeInstall(Service);
      TmpTagID := TagID;

      if TmpTagID > 0 then PTag := @TmpTagID else PTag := nil;
      if ServiceStartName = '' then
        PSSN := nil
      else
        PSSN := PChar(ServiceStartName);

      if dwSvcType = DWORD(-1) then
        dwSvcType := GetNTServiceType;

      if dwSvcStart = DWORD(-1) then
        dwSvcStart := GetNTStartType;

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

      TagID := TmpTagID;
      if Svc = 0 then
        RaiseLastOSError;

      // Parameters 키 생성. 정보 적재.
      SetSvcHostParameters();

      try
        try
          if Assigned(AfterInstall) then AfterInstall(Service);
        except
          on E: Exception do
          begin
            DeleteService(Svc);
            raise;
          end;
        end;
      finally
        CloseServiceHandle(Svc);
      end;
    end;
  end;

  procedure UninstallService(Service: TService; SvcMgr: SC_HANDLE);
  var
    Svc: SC_HANDLE;
    Reg: TRegistry;

    procedure RemSvcHostParameters();
    begin
      // svchost 의 엔트리포인트 제거
      Reg := TRegistry.Create(KEY_READ or KEY_WRITE);
      try
        Reg.RootKey := HKEY_LOCAL_MACHINE;
        if Reg.OpenKey('\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Svchost', false) then
        begin
          //ShowMessage('엔트리 키오픈 성공. 제거 시작');
          Reg.DeleteValue(Service.Name);
          Reg.CloseKey();
        end;

        // 이 서비스의 Parameters 제거
        Reg.RootKey := HKEY_LOCAL_MACHINE;
        if Reg.OpenKey('\SYSTEM\CurrentControlSet\services\' + Service.Name, false) then
        begin
          //ShowMessage('파라미터 키 오픈 성공. 제거 시작');
          Reg.DeleteKey('Parameters');
          Reg.CloseKey();
        end;

      finally
        Reg.Free;
      end;

    end;

  begin
    with Service do
    begin
      if Assigned(BeforeUninstall) then BeforeUninstall(Service);
      //ShowMessage('서비스 제거 ' + Service.Name);

      RemSvcHostParameters();

      Svc := OpenService(SvcMgr, PChar(Name), SERVICE_ALL_ACCESS);
      if Svc = 0 then RaiseLastOSError;
      try
        if not DeleteService(Svc) then RaiseLastOSError;
      finally
        CloseServiceHandle(Svc);
      end;

      if Assigned(AfterUninstall) then AfterUninstall(Service);
    end;
  end;

  procedure DisplayMessage(const Msg: string; const MsgType: TMsgDlgType);
  begin
    if IsConsole then
      WriteLn(Msg)
    else
      MessageDlg(Msg, MsgType, [mbOk], 0);
  end;

var
  SvcMgr: SC_HANDLE;
  Msg: string;
  i: Integer;
begin
  Result := True;
  SvcMgr := OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);
  if SvcMgr = 0 then RaiseLastOSError;
  with Vcl.SvcMgr.Application do
  try
    for i := 0 to ComponentCount - 1 do
      if Components[i] is TService then
      try
        if Install then
          InstallService(TService(Components[i]), SvcMgr)
        else
          UninstallService(TService(Components[i]), SvcMgr)
      except
        on E: Exception do
        begin
          Result := False;

          if (not Silent) then
          begin
            if Install then
              Msg := SServiceInstallFailed
            else
              Msg := SServiceUninstallFailed;
            with TService(Components[i]) do
              DisplayMessage(Format(Msg, [DisplayName, E.Message]), mtError);
          end;
        end;
      end;

    if Result and not Silent then
      if Install then
        DisplayMessage(SServiceInstallOK, mtInformation)
      else
        DisplayMessage(SServiceUninstallOK, mtInformation);

  finally
    CloseServiceHandle(SvcMgr);
  end;

end;

procedure InstallServices_dll(Silent: BOOL; dwSvcType, dwSvcStart: DWORD); stdcall;
begin
  try
    RegisterServices(true, Silent, dwSvcType, dwSvcStart);
  except

  end;
end;

procedure UnInstallServices_dll(Silent: BOOL); stdcall;
var
  bRetry: Boolean;
  nReCnt: Integer;
Label
  LB_Retry;
begin
LB_Retry :
  bRetry := false;
  try
    RegisterServices(false, Silent);
  except
    on E: EOSError do
    begin
      if E.ErrorCode = 5 then
        bRetry := true
      else
        exit;
    end;

    on E: Exception do
      exit;
  end;

  if bRetry then
  begin
    Inc(nReCnt);
    if nReCnt > 5 then
      exit;
    Sleep(1000);
    goto LB_Retry;
  end;
end;

end.