Service Control

// *****************************************************************************
//  Title.............. :  Service Control Project
//
//  Modulname ......... :  ServiceControl.lpr
//  Type .............. :  Lazarus Project File
//  Author ............ :  Udo Schmal
//  Development Status  :  26.10.2015
//  Operating System .. :  Win32/Win64
//  IDE ............... :  Lazarus
// *****************************************************************************
program ServiceControl;

{$mode objfpc}{$H+}

uses
  Interfaces, Forms, Main;

{$R *.res}

begin
  Application.Title:='Service Control';
  RequireDerivedFormResource := True;
  Application.Initialize;
  Application.CreateForm(TfrmServiceControl, frmServiceControl);
  Application.Run;
end.

// *****************************************************************************
//  Title.............. :  Service Control Main
//
//  Modulname ......... :  main.pas (TfrmServiceControl)
//  Type .............. :  Unit
//  Author ............ :  Udo Schmal
//  Development Status  :  26.10.2015
//  Operating System .. :  Win32/Win64
//  IDE ............... :  Lazarus
// *****************************************************************************
unit Main;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, ExtCtrls,
  {$ifdef USE_SHELLAPI}Windows, ShellApi,{$else}Process,{$endif}
  {$ifdef USE_REGISTRY}Registry,{$endif}
  Menus, ServiceManager, JwaWinSvc, TaskScheduler_1_0_TLB;

const
  ServiceName = 'httpServer';
  ServiceTitel = 'UDOs Webserver';
  ServiceExecutable = 'httpServer.exe';

type
  TfrmServiceControl = class(TForm)
    ImageList: TImageList;
    leave: TMenuItem;
    install: TMenuItem;
    uninstall: TMenuItem;
    stop: TMenuItem;
    start: TMenuItem;
    TrayMenu: TPopupMenu;
    TrayIcon: TTrayIcon;
    procedure FormCloseQuery(Sender: TObject; var CanClose: boolean);
    procedure FormCreate(Sender: TObject);
    procedure installClick(Sender: TObject);
    procedure leaveClick(Sender: TObject);
    procedure TrayMenuPopup(Sender: TObject);
    procedure startClick(Sender: TObject);
    procedure stopClick(Sender: TObject);
    procedure TrayIconMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
    procedure uninstallClick(Sender: TObject);
  private
    FPath: string;
    FServiceIsInstalled, FServiceIsRunning: Boolean;
    procedure SetAutoStart(bRegister: Boolean);
    procedure UpdateServiceStatus();
  end;

var
  frmServiceControl: TfrmServiceControl;

implementation

{$R *.lfm}

{$ifdef USE_SHELLAPI}
function RunAsAdmin(const Handle: Hwnd; const Path: string; Params: string = ''): Boolean;
var
  sei: TShellExecuteInfoA;
begin
  FillChar(sei, SizeOf(sei), 0);
  sei.cbSize := SizeOf(sei);
  sei.Wnd := Handle;
  sei.fMask := SEE_MASK_FLAG_DDEWAIT or SEE_MASK_FLAG_NO_UI;
  sei.lpVerb := 'runas';
  sei.lpFile := PAnsiChar(Path);
  sei.lpParameters := PAnsiChar(Params);
  sei.nShow := SW_HIDE;//SW_SHOWNORMAL;
  Result := ShellExecuteExA(@sei);
  if not Result then
    RaiseLastOSError;
end;
{$endif}

procedure TfrmServiceControl.SetAutoStart(bRegister: Boolean);
{$ifdef USE_REGISTRY}
// only works with UAC Disable and always Admin
const RegKey = '\SOFTWARE\Microsoft\Windows\CurrentVersion\Run';
var Registry: TRegistry;
begin
  Registry := TRegistry.Create;
  try
//    Registry.RootKey := HKEY_CURRENT_USER;
    Registry.RootKey := HKEY_LOCAL_MACHINE;
    if Registry.OpenKey(RegKey, False) then
    begin
      if bRegister = False then
        Registry.DeleteValue(ChangeFileExt(ExtractFileName(ParamStr(0)), ''))
      else
        Registry.WriteString(ChangeFileExt(ExtractFileName(ParamStr(0)), ''), '"'+ParamStr(0)+'"');
    end;
  finally
    Registry.Free;
  end;
end;
{$else}
var
  TS: ITaskService;
  TaskFolder: ITaskFolder;
  TaskDefinition: ITaskDefinition;
  RegInfo: IRegistrationInfo;
  Principal: IPrincipal;
  TaskSettings: ITaskSettings;
  Triggers: ITriggerCollection;
  Trigger: ITrigger;
  Exec: IAction;
begin
  TS := CoTaskScheduler.Create;
  TS.Connect(null, null, null, null);
  TaskFolder := TS.GetFolder('\');

  if (bRegister) then
  begin
    TaskDefinition := TS.NewTask(0);

    RegInfo := TaskDefinition.RegistrationInfo;
    RegInfo.Description := 'Service Control Task';
    RegInfo.Author := 'Udo Schmal';

    Principal := TaskDefinition.Principal;
    Principal.Id := 'Author';
    Principal.RunLevel := TASK_RUNLEVEL_HIGHEST;

    Triggers := TaskDefinition.Triggers;
    Trigger := Triggers.Create(TASK_TRIGGER_LOGON);
    Trigger.StartBoundary := FormatDateTime('yyyy"-"mm"-"dd"T"hh":"nn":"ss', Now);
//    Trigger.EndBoundary := '2100-01-01T00:00:00';
//    Trigger.ExecutionTimeLimit := 'PT72H';
    Trigger.Id := 'AnyLogon';
    Trigger.Enabled := true;

    TaskSettings := TaskDefinition.Settings;
    TaskSettings.MultipleInstances := TASK_INSTANCES_IGNORE_NEW;
    TaskSettings.DisallowStartIfOnBatteries := false;
    TaskSettings.StopIfGoingOnBatteries := false;
    TaskSettings.AllowHardTerminate := true;
    TaskSettings.StartWhenAvailable := true;
    TaskSettings.RunOnlyIfNetworkAvailable := false;
    TaskSettings.IdleSettings.StopOnIdleEnd := false;
    TaskSettings.IdleSettings.RestartOnIdle := false;
    TaskSettings.AllowDemandStart := true;
    TaskSettings.Enabled := true;
    TaskSettings.Hidden := false;
    TaskSettings.RunOnlyIfIdle := false;
    TaskSettings.WakeToRun := false;
    TaskSettings.ExecutionTimeLimit := 'PT0S';
    TaskSettings.Priority := 7;

    TaskDefinition.Actions.Context := 'Author';
    Exec := TaskDefinition.Actions.Create(0);
    IExecAction(Exec).Id := 'Action';
    IExecAction(Exec).Path := ParamStr(0);
    IExecAction(Exec).Arguments := '';
    IExecAction(Exec).WorkingDirectory := ExtractFilePath(ParamStr(0));
    TaskFolder.RegisterTaskDefinition('Service Starter', TaskDefinition,
      TASK_CREATE_OR_UPDATE, NULL, NULL, TASK_LOGON_INTERACTIVE_TOKEN, NULL);
  end
  else
    TaskFolder.DeleteTask('Service Starter', 0);
end;
{$endif}

procedure TfrmServiceControl.UpdateServiceStatus();
var
  Services: TServiceManager;
  ServiceStatus: TServiceStatus;
begin
  FServiceIsInstalled := false;
  FServiceIsRunning := false;
  Services := TServiceManager.Create(nil);
  try
    try
//      Services.Acces := SC_MANAGER_CONNECT;
      Services.Connect;
      Services.GetServiceStatus(ServiceName, ServiceStatus);
      FServiceIsInstalled := ServiceStatus.dwCurrentState <> 0;
      FServiceIsRunning := ServiceStatus.dwCurrentState = SERVICE_RUNNING;
      Services.Disconnect;
      if FServiceIsRunning then
        TrayIcon.Hint := ServiceTitel + #10'status: running'
      else if FServiceIsInstalled then
        TrayIcon.Hint := ServiceTitel + #10'status: installed'
      else
        TrayIcon.Hint := ServiceTitel + #10'status: not installed';
    except
      on E: Exception do
      begin
        FServiceIsInstalled := false;
        FServiceIsRunning := false;
      end;
    end;
  finally
    Services.Free;
  end;
  TrayMenu.Items[0].Visible := not FServiceIsInstalled; //install
  TrayMenu.Items[1].Visible := FServiceIsInstalled and not FServiceIsRunning; //start
  TrayMenu.Items[2].Visible := FServiceIsInstalled and FServiceIsRunning; //stop
  TrayMenu.Items[3].Visible := FServiceIsInstalled and not FServiceIsRunning; //uninstall
  TrayMenu.Items[4].Visible := not FServiceIsInstalled; //leave
end;

procedure TfrmServiceControl.FormCloseQuery(Sender: TObject; var CanClose: boolean);
begin
  UpdateServiceStatus();
  WindowState := wsMinimized;
  Hide;
  CanClose := not FServiceIsInstalled;
end;

procedure TfrmServiceControl.FormCreate(Sender: TObject);
begin
  WindowState := wsMinimized;
  Hide;
  TrayIcon.Hint := ServiceTitel;
  TrayIcon.BalloonTitle := ServiceTitel;
  FPath := ExtractFilePath(ParamStr(0));
end;

procedure TfrmServiceControl.TrayMenuPopup(Sender: TObject);
begin
  UpdateServiceStatus();
end;

procedure TfrmServiceControl.startClick(Sender: TObject);
var Services: TServiceManager;
begin
  Services := TServiceManager.Create(nil);
  try
//    Services.Acces := SC_MANAGER_ALL_ACCESS;
    Services.Connect;
    Services.StartService(ServiceName, nil);
    Services.Disconnect;
  finally
    Services.Free;
  end;
  UpdateServiceStatus();
end;

procedure TfrmServiceControl.stopClick(Sender: TObject);
var Services: TServiceManager;
begin
  Services := TServiceManager.Create(nil);
  try
//    Services.Acces := SC_MANAGER_ALL_ACCESS;
    Services.Connect;
    Services.StopService(ServiceName, true);
    Services.Disconnect;
  finally
    Services.Free;
  end;
  UpdateServiceStatus();
end;

procedure TfrmServiceControl.TrayIconMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
  UpdateServiceStatus();
end;

procedure TfrmServiceControl.installClick(Sender: TObject);
{$ifdef USE_SHELLAPI}
begin
RunAsAdmin(self.Handle, FPath + ServiceExecutable, '--install');
{$else}
var AProcess: TProcess;
begin
  AProcess := TProcess.Create(nil);
  AProcess.Executable := FPath + ServiceExecutable;
  AProcess.Parameters.Add('--install');
  AProcess.Options := [poWaitOnExit];
  AProcess.Execute;
  AProcess.Free;
{$endif}
  UpdateServiceStatus();
  SetAutoStart(true);
end;

procedure TfrmServiceControl.uninstallClick(Sender: TObject);
{$ifdef USE_SHELLAPI}
begin
  RunAsAdmin(self.Handle, FPath + ServiceExecutable, '--uninstall');
{$else}
var AProcess: TProcess;
begin
  AProcess := TProcess.Create(nil);
  AProcess.Executable := FPath + ServiceExecutable;
  AProcess.Parameters.Add('--uninstall');
  AProcess.Options := [poWaitOnExit];
  AProcess.Execute;
  AProcess.Free;
{$endif}
  UpdateServiceStatus();
  SetAutoStart(false);
end;


procedure TfrmServiceControl.leaveClick(Sender: TObject);
begin
  Close;
end;

end.