nettimeipc.pas

VC++实现的时间同步程序

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

   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 [e-mail]
   so that I can include them in an 'official' release.

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

unit NetTimeIPC;

interface

uses Windows, Classes, SysUtils, NetTimeCommon, iswinnt, syncobjs;

type

  TServerStatusBlock = record
    Config: TServerConfigBlock;
    Server: boolean;
    Active: boolean;
    Status: TSyncStatus;
    LastUpdateTime: TDateTime;
  end;

  // Whenever you change this, you have to increment ProtocolVersion
  // in NetTimeCommon.
  TShareMemBlock = record
    // Section that anyone can write to
    G_MagicCookie: longword;
    G_ProtocolVersion: longword;
    G_ExitNowFlag: boolean;
    // Section that the SERVER writes to
    S_ServerPID: longword;
    S_StatusProvidedSerial: integer;
    S_AdviseStatusFlag: boolean;
    S_Status: TServerStatusBlock;
    S_LargeAdjFlag: boolean;
    S_ServerTime, S_StationTime: TDateTime;
    S_LastUpdateGood: boolean; // only valid when C_WantUpdateNow called
    // Section that the CLIENT writes to
    C_ClientPID: longword;
    C_ClientStatusChangeFlag: boolean;
    C_StatusWantedSerial: integer;
    C_LargeAdjReplyFlag: boolean;
    C_LargeAdjReplyResult: boolean;
    C_SetConfigFlag: boolean;
    C_Config: TServerConfigBlock;
    C_SetServerFlag: boolean;
    C_Server: boolean;
    C_WantUpdateNowFlag: boolean;
  end;
  PShareMemBlock = ^TShareMemBlock;

  TExitNowCallback = procedure of object;
  TUpdateNowCallback = function: boolean of object;

  TNetTimeIPC = class
  protected
    ShareMemHandle: THandle;
    ShareMem: PShareMemBlock;
    ExitNowCallback: TExitNowCallback;
  protected
    HaveKilled: boolean;
  public
    procedure InitResources; virtual;
    procedure FreeResources; virtual;
    function CheckServerRunning: boolean;
    function CheckClientRunning: boolean;
    procedure KillEverything;
    constructor Create(const enb: TExitNowCallback);
    destructor Destroy; override;
  end;

  TGetServerStatusCallback = function: TServerStatusBlock of object;
  TSetConfigCallback = procedure(const cfg: TServerConfigBlock) of object;
  TSetServerCallback = procedure(const srv: boolean) of object;

  TNetTimeServerThread = class;

  TNetTimeIPCServer = class(TNetTimeIPC)
  private
    MyThread: TNetTimeServerThread;
    ClientEvent: THandle;
    GetServerStatusCallback: TGetServerStatusCallback;
    SetConfigCallback: TSetConfigCallback;
    SetServerCallback: TSetServerCallback;
    UpdateNowCallback: TUpdateNowCallback;
    procedure ClientHello;
    procedure ClientGoodbye;
    procedure SetServer;
    procedure SetConfig;
  public
    procedure InitResources; override;
    procedure FreeResources; override;
    function LargeAdjustWarn(const ServerTime, StationTime: TDateTime): boolean;
    procedure AdviseStatus;
    constructor Create(const gsb: TGetServerStatusCallback;
      const scb: TSetConfigCallback; const ssb: TSetServerCallback;
      const enb: TExitNowCallback; const unb: TUpdateNowCallback);
    destructor Destroy; override;
  end;

  TNetTimeServerThread = class(TThread)
  protected
    MyOwner: TNetTimeIPCServer;
    MyEvent: THandle;
    procedure Execute; override;
  public
    constructor Create(const Owner: TNetTimeIPCServer;
      const Suspended: boolean = false);
  end;

  TAdviseStatusCallback = procedure(const stat: TServerStatusBlock) of object;
  TLargeAdjCallback = function(const ServerTime, StationTime: TDateTime): boolean of object;

  TNetTimeClientThread = class;

  TNetTimeIPCClient = class(TNetTimeIPC)
  private
    MyThread: TNetTimeClientThread;
    ServerEvent: THandle;
    AdviseStatusCallback: TAdviseStatusCallback;
    LargeAdjCallback: TLargeAdjCallback;
    procedure RetrieveStatus;
    procedure DoLargeAdj;
  public
    procedure InitResources; override;
    procedure FreeResources; override;
    function GetServerStatus: TServerStatusBlock;
    procedure SetConfig(const cfg: TServerConfigBlock);
    procedure SetServer(const srv: boolean);
    constructor Create(const asb: TAdviseStatusCallback;
      const lab: TLargeAdjCallback; const enb: TExitNowCallback);
    function UpdateNow: boolean;
    destructor Destroy; override;
  end;

  TNetTimeClientThread = class(TThread)
  protected
    MyOwner: TNetTimeIPCClient;
    MyEvent: THandle;
    procedure Execute; override;
  public
    constructor Create(const Owner: TNetTimeIPCClient;
      const Suspended: boolean = false);
  end;

implementation

const
  ShareMemName = 'NetTimeGHJM_ShareMem';
  ServerEventName = 'NetTimeGHJM_ServerEvent';
  ClientEventName = 'NetTimeGHJM_ServerEvent';

{ TNetTimeIPC }

procedure TNetTimeIPC.InitResources;

var
  sa: TSecurityAttributes;
  sd: TSecurityDescriptor;
  sp: PSecurityAttributes;
  ae: boolean;

begin
  if IsWindowsNT then
    begin
      InitializeSecurityDescriptor(@sd,SECURITY_DESCRIPTOR_REVISION);
      SetSecurityDescriptorDACL(@sd,true,nil,false);
      sa.nLength := sizeof(sa);
      sa.lpSecurityDescriptor := @sd;
      sa.bInheritHandle := false;
      sp := @sa;
    end
  else
    sp := nil;
  ShareMemHandle := CreateFileMapping($ffffffff,sp,PAGE_READWRITE,0,
    sizeof(TShareMemBlock),pchar(ShareMemName));
  if ShareMemHandle = 0 then
    raise exception.create('Could not open shared memory');
  ae := (GetLastError = ERROR_ALREADY_EXISTS);
  ShareMem := MapViewOfFile(ShareMemHandle,FILE_MAP_ALL_ACCESS,0,0,
    sizeof(TShareMemBlock));
  if ShareMem = nil then
    raise exception.create('Could not map shared memory');
  if not ae then
    FillChar(ShareMem^,sizeof(TShareMemBlock),0);
end;

procedure TNetTimeIPC.FreeResources;
begin
  if ShareMem <> nil then
    begin
      UnmapViewOfFile(ShareMem);
      CloseHandle(ShareMemHandle);
      ShareMem := nil;
    end;
end;

function CheckProcessExists(const pid: longword): boolean;

var
  ph: THandle;
  er: longword;

begin
  if pid = 0 then
    begin
      result := false;
      exit;
    end;
  ph := OpenProcess(PROCESS_QUERY_INFORMATION,false,pid);
  if ph = 0 then
    begin
      er := GetLastError;
      if (er = ERROR_ACCESS_DENIED) or (er = ERROR_NETWORK_ACCESS_DENIED) or
        (er = ERROR_EA_ACCESS_DENIED) then
        result := true
      else
        result := false;
    end
  else
    begin
      result := true;
      CloseHandle(ph);
    end;
end;

function TNetTimeIPC.CheckServerRunning: boolean;
begin
  if ShareMem = nil then
    result := false
  else
    result := CheckProcessExists(ShareMem^.S_ServerPID);
end;

function TNetTimeIPC.CheckClientRunning: boolean;
begin
  if ShareMem = nil then
    result := false
  else
    result := CheckProcessExists(ShareMem^.C_ClientPID);
end;

procedure SignalEventByName(const Name: string);

var
  EventHandle: THandle;

begin
  EventHandle := OpenEvent(EVENT_ALL_ACCESS,false,pchar(Name));
  if EventHandle <> 0 then
    begin
      SetEvent(EventHandle);
      CloseHandle(EventHandle);
    end;
end;

procedure TNetTimeIPC.KillEverything;
begin
  if ShareMem <> nil then
    begin
      ShareMem^.G_ExitNowFlag := true;
      SignalEventByName(ClientEventName);
      SignalEventByName(ServerEventName);
    end;
  if Assigned(ExitNowCallback) then
    ExitNowCallback;
end;

constructor TNetTimeIPC.Create(const enb: TExitNowCallback);
begin
  inherited Create;
  ExitNowCallback := enb;
  HaveKilled := false;
  ShareMem := nil;
end;

destructor TNetTimeIPC.Destroy;
begin
  FreeResources;
  inherited;
end;

{TNetTimeIPCServer}

procedure TNetTimeIPCServer.ClientHello;
begin
  ClientEvent := OpenEvent(EVENT_ALL_ACCESS,false,ClientEventName);
end;

procedure TNetTimeIPCServer.ClientGoodbye;
begin
  ClientEvent := 0;
end;

function TNetTimeIPCServer.LargeAdjustWarn(const ServerTime, StationTime: TDateTime): boolean;
begin
  if (ClientEvent = 0) or (ShareMem = nil) or (not CheckClientRunning) then
    begin
      result := true;
      exit;
    end;
  ShareMem^.S_ServerTime := ServerTime;
  ShareMem^.S_StationTime := StationTime;
  ShareMem^.C_LargeAdjReplyFlag := false;
  ShareMem^.S_LargeAdjFlag := true;
  SetEvent(ClientEvent);
  repeat
    Sleep(IPCSleepTime);
  until ShareMem^.C_LargeAdjReplyFlag;
  ShareMem^.C_LargeAdjReplyFlag := false;
  result := ShareMem^.C_LargeAdjReplyResult;
end;

procedure TNetTimeIPCServer.AdviseStatus;
begin
  if ShareMem = nil then
    exit;
  ShareMem^.S_Status := GetServerStatusCallback;
  ShareMem^.S_AdviseStatusFlag := true;
  if (ClientEvent <> 0) then
    SetEvent(ClientEvent);
end;

procedure TNetTimeIPCServer.InitResources;
begin
  inherited;
  ShareMem^.G_MagicCookie := MagicCookie;
  ShareMem^.G_ProtocolVersion := ProtocolVersion;
  ShareMem^.S_ServerPID := GetCurrentProcessID;
  MyThread := TNetTimeServerThread.Create(Self);
end;

procedure TNetTimeIPCServer.FreeResources;
begin