ServiceMain.pas

{ ************************************************************************

   NetTime is copyrighted by Graham Mainwaring. Permission is hereby
   granted to use, modify, redistribute and create derivative works
   provided this attribution is not removed. I also request that if you
   make any useful changes, please e-mail the diffs to graham@mhn.org
   so that I can include them in an 'official' release.

  ************************************************************************ }

unit ServiceMain;

interface

uses
  Windows, Messages, SysUtils, Classes, SvcMgr,
  NetTimeThread, ConfigObj, Mutex, NetTimeCommon, WinSvc;

type
  TNetTimeSvc = class(TService)
    procedure ServiceStart(Sender: TService; var Started: Boolean);
    procedure ServiceStop(Sender: TService; var Stopped: Boolean);
    procedure DoExitNow(Sender: TObject);
  private
    tt: TNetTimeServer;
    procedure WMEndSession(var Msg: TWMEndSession); message WM_ENDSESSION;
  public
    function GetServiceController: TServiceController; override;
  end;

var
  NetTimeSvc: TNetTimeSvc;

implementation

{$R *.DFM}

procedure ServiceController(CtrlCode: DWord); stdcall;
begin
  NetTimeSvc.Controller(CtrlCode);
end;

function TNetTimeSvc.GetServiceController: TServiceController;
begin
  Result := ServiceController;
end;

procedure TNetTimeSvc.DoExitNow(Sender: TObject);
begin
  Controller(SERVICE_CONTROL_STOP);
end;

procedure TNetTimeSvc.ServiceStart(Sender: TService; var Started: Boolean);

var
  co: TConfigObj;

begin
  if not GetExclusivity(ExNameServer) then
    raise exception.create('Cannot load NetTime server: Another server is already running');
  tt := TNetTimeServer.Create;
  co := TConfigObj.Create;
  try
    co.ReadFromRegistry;
    co.WriteToRunning(tt);
  finally
    co.Free;
  end;
  if (tt.Config.ServerCount = 0) then
    raise exception.create('NetTime has not been configured');
  tt.OnExitNow := DoExitNow;
  tt.Start;
  Started := true;
end;

procedure TNetTimeSvc.ServiceStop(Sender: TService; var Stopped: Boolean);
begin
  tt.Stop;
  Stopped := true;
end;

procedure TNetTimeSvc.WMEndSession(var Msg: TWMEndSession);
begin
  DoExitNow(Self);
end;

end.