socketprotocolserver.~pas

delphi实现的一个完全自动运行的数据库存取的软件保留30天日志记录

unit SocketProtocolServer;

interface

uses
  Classes, SysUtils, ScktComp, ExtCtrls;

const
  //一层通讯协议命令字
  CstSPCmdLv0_S_ClientLogin = $41;      //客户端登录消息命令字
  CstSPCmdLv0_R_ClientLogin = $42;      //客户端登录应答消息命令字
  CstSPCmdLv0_SR_ClientData = $43;      //客户端转发数据消息命令字
  CstSPCmdLv0_S_ClientOnLine = $44;     //客户端在线消息命令字
  CstSPCmdLv0_R_OthersOnLine = $45;     //其他客户端在线消息命令字
  CstSPCmdLv0_S_ClientLogout = $47;     //客户端下线消息命令字
  CstSPCmdLv0_R_OthersOffLine = $46;    //其他客户端下线消息命令字

  //二层通讯协议命令字（针对于一层协议中的转发消息命令字）
  CstSPCmdLv1_S_CFrame = $01;   //连续数据包命令字，表示后面仍有数据
  CstSPCmdLv1_R_CFrame = $41;   //连续数据包应答命令字
  CstSPCmdLv1_S_FFrame = $02;   //最后一包数据命令字
  CstSPCmdLv1_R_FFrame = $42;   //最后一包数据应答命令字

  //三层通讯协议命令字（转发数据协议格式）
  CstSPCmdLv2_S_DataRecord = $01;   //数据记录命令字
  CstSPCmdLv2_R_DataRecord = $41;   //数据记录响应命令字
  CstSPCmdLv2_S_CheckTable = $02;   //校验表命令字
  CstSPCmdLv2_R_CheckTable = $42;   //校验表响应命令字

type

{ TSocketProtocolServer }

  T8KBytesBuf = array [0..8191] of Byte; //8K的数据缓冲区
  T4KBytesBuf = array [0..4095] of Byte; //4K的数据缓冲区
  T1KBytesBuf = array [0..1023] of Byte; //1K的数据缓冲区
  T512BytesBuf = array [0..511] of Byte; //1/2K的数据缓冲区
  T20BytesBuf = array [0..19] of Byte;   //20个字节的数据缓冲区
  //
  TSPLogEvent = procedure (LogMessage: string; LogCode: Byte) of object;
  //
  TSPRspLoginEvent = procedure (Sender: TObject; Status: Boolean) of object;
  TSPRspTransDataEvent = procedure (Sender: TObject; Src, Dst: string; Cmd, PkCnt, PkNO: Byte; PkData: array of Byte; PkDataLen: integer) of object;
  TSPRspOthersOnLineEvent = procedure (Sender: TObject; Client: string) of object;
  TSPRspOthersOffLineEvent = procedure (Sender: TObject; Client: string) of object;

  TSocketProtocolServer = class(TObject) 
    FSPCRspOnLogin: TSPRspLoginEvent;
    FSPCRspOnTransData: TSPRspTransDataEvent;
    FSPCRspOnOthersOnLine: TSPRspOthersOnLineEvent;
    FSPCRspOnOthersOffLine: TSPRspOthersOffLineEvent;

    FSPCOnLogLv0: TSPLogEvent; //日志记录级别0 -- 最高级别，针对于异常情况的记录
    FSPCOnLogLv1: TSPLogEvent; //日志记录级别1 -- 级别稍低，针对于通讯记录的记录
    FSPCOnLogLv2: TSPLogEvent; //日志记录级别2 -- 级别更低，针对于正常提示的记录
    FSPCOnLogLv3: TSPLogEvent; //日志记录级别3 -- 级别最低，针对于正常情况无关紧要信息的记录
  private
    //Control
    FSPCLocalName: string;

    //Socket
    FSPCCS: TClientSocket;
    FSPCServerAddr: string;
    FSPCServerPort: integer;

    //Store Buffer
    FSPCPackData: T4KBytesBuf;
    FSPCPackDataLen: integer;

    //Send Buffer
    FSPCSendBuf: T512BytesBuf;
    FSPCSendBufLen: integer;
    FSPCSendBusy: Boolean;

    //Recv Buffer
    FSPCRecvBuf: T4KBytesBuf;
    FSPCRecvFront: integer;
    FSPCRecvRear: integer;
  public
    constructor Create(LocalName: string); reintroduce;
    destructor Destroy; override;
    
    procedure OpenSocket(ServerAddress: string; ServerPort: integer);
    procedure CloseSocket;
    
    procedure ClientLogin(SrcName: string);
    procedure ClientOnLine(SrcName: string);
    function  ClientTansData(SrcName, DstName: string; Data: T4KBytesBuf; DataLen: integer): Boolean;
    procedure ClientLogout(SrcName: string);
    function PackSendBuf(PackSendData: T512BytesBuf; PackSendDataLen: integer): integer;
  private
    //客户端Socket处理
    procedure ClientSocketConnect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure ClientSocketConnecting(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure ClientSocketDisconnect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure ClientSocketError(Sender: TObject; Socket: TCustomWinSocket;
      ErrorEvent: TErrorEvent; var ErrorCode: Integer);
    procedure ClientSocketLookup(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure ClientSocketRead(Sender: TObject; Socket: TCustomWinSocket);
    procedure ClientSocketWrite(Sender: TObject;
      Socket: TCustomWinSocket);
  private
    { Functions Parts }
    function IsIPFormat(IPAddr: string): Boolean;
    function EnRecvBuf(RecvBuf: array of Byte; RecvLength: integer): Boolean;
    function DeRecvBuf(PopSize: integer): Boolean;
    function RecvDataLength: integer;
    function LocatePacketHeadByte: Boolean;
    function GetAt(Index: integer): Byte;
    
    { Procedure Parts }
    procedure Pack2DataGate(PackCmd: Byte; PackData: T20BytesBuf; PackDataLen: integer);
    procedure Pack2OtherClient(PackCmd: Byte; Src, Dst: string; PackData: T4KBytesBuf; PackDataLen: integer);
  end;

{$ifndef SPCDebug}
{$define SPCDebug}
{$endif}

implementation

{ TSocketProtocolServer }

constructor TSocketProtocolServer.Create(LocalName: string);
begin
    Inherited Create;
    try
      //初始化成员变量
      FSPCLocalName:= LocalName;
      FSPCCS:= TClientSocket.Create(nil);
      //设置事件响应函数
      FSPCCS.OnLookup:= ClientSocketLookup;
      FSPCCS.OnConnecting:= ClientSocketConnecting;
      FSPCCS.OnConnect:= ClientSocketConnect;
      FSPCCS.OnDisconnect:= ClientSocketDisconnect;
      FSPCCS.OnRead:= ClientSocketRead;
      FSPCCS.OnWrite:= ClientSocketWrite;
      FSPCCS.OnError:= ClientSocketError;
      
      FSPCRspOnLogin:= nil;           //登录网关的响应消息函数
      FSPCRspOnTransData:= nil;       //网关转发数据的响应消息函数
      FSPCRspOnOthersOnLine:= nil;    //其他客户端上线响应消息函数
      FSPCRspOnOthersOffLine:= nil;   //其他客户端离线响应消息函数

      FSPCOnLogLv0:= nil;   //日志记录级别0 -- 最高级别，针对于异常情况的记录
      FSPCOnLogLv1:= nil;   //日志记录级别1 -- 级别稍低，针对于通讯记录的记录
      FSPCOnLogLv2:= nil;   //日志记录级别2 -- 级别更低，针对于正常提示的记录
      FSPCOnLogLv3:= nil;   //日志记录级别3 -- 级别最低，针对于正常情况无关紧要信息的记录

      FSPCPackDataLen:= 0;
      FSPCSendBufLen:= 0;
      FSPCSendBusy:= FALSE;

      FSPCRecvFront:= 0;
      FSPCRecvRear:= 0;
    except
      FSPCCS:= nil;
    end;
end;

destructor TSocketProtocolServer.Destroy;
begin
    if Assigned(FSPCCS) then FSPCCS.Free;
    Inherited Destroy;
end;

procedure TSocketProtocolServer.OpenSocket(ServerAddress: string; ServerPort: integer);
begin
    try
      //保存服务器连接信息
      FSPCServerAddr:= ServerAddress;
      FSPCServerPort:= ServerPort;
      if IsIPFormat(FSPCServerAddr) then
      begin
        //设置客户端Socket属性
        FSPCCS.Address:= FSPCServerAddr;
        FSPCCS.Port:= FSPCServerPort;
        //打开客户端连接
        if not FSPCCS.Active then FSPCCS.Open;
      end
      else
      begin
        if Assigned(FSPCOnLogLv0) then FSPCOnLogLv0(Format('IP(%s) is not in correct format', [FSPCServerAddr]), $04);
      end;
    except
      on E: Exception do
      begin
        if Assigned(FSPCOnLogLv0) then FSPCOnLogLv0(E.Message, $02);
      end;
    end;
end;

procedure TSocketProtocolServer.CloseSocket;
begin
    if Assigned(FSPCCS) then FSPCCS.Close;
end;

procedure TSocketProtocolServer.ClientLogin(SrcName: string);
var
    LvData: T20BytesBuf;
    LvDataLen: integer;
    i: integer;
begin
    LvDataLen:= 0;
    for i:= 1 to 20 do
    begin
      if (i <= Length(SrcName)) then
      begin
        LvData[LvDataLen]:= Ord(SrcName[i]);
        LvDataLen:= LvDataLen + 1;
      end
      else
      begin
        LvData[LvDataLen]:= $20;
        LvDataLen:= LvDataLen + 1;
      end;
    end;
    Pack2DataGate(CstSPCmdLv0_S_ClientLogin, LvData, LvDataLen);
    PackSendBuf(FSPCSendBuf, FSPCSendBufLen);
end;

procedure TSocketProtocolServer.ClientOnLine(SrcName: string);
var
    LvData: T20BytesBuf;
    LvDataLen: integer;
    i: integer;
begin
    LvDataLen:= 0;
    for i:= 1 to 20 do
    begin
      if (i <= Length(SrcName)) then
      begin
        LvData[LvDataLen]:= Ord(SrcName[i]);
        LvDataLen:= LvDataLen + 1;
      end
      else
      begin
        LvData[LvDataLen]:= $20;
        LvDataLen:= LvDataLen + 1;
      end;
    end;
    Pack2DataGate(CstSPCmdLv0_S_ClientOnLine, LvData, LvDataLen);
    PackSendBuf(FSPCSendBuf, FSPCSendBufLen);
end;

function TSocketProtocolServer.ClientTansData(SrcName, DstName: string; Data: T4KBytesBuf; DataLen: integer): Boolean;
begin
    //发送数据
    if not FSPCSendBusy then
    begin
      Pack2OtherClient(CstSPCmdLv0_SR_ClientData, SrcName, DstName, Data, DataLen);
      PackSendBuf(FSPCSendBuf, FSPCSendBufLen);
      FSPCSendBusy:= TRUE;
      Result:= TRUE;
    end
    else Result:= FALSE;
end;

procedure TSocketProtocolServer.ClientLogout(SrcName: string);
var
    LvData: T20BytesBuf;
    LvDataLen: integer;
    i: integer;
begin
    LvDataLen:= 0;
    for i:= 1 to 20 do
    begin
      if (i <= Length(SrcName)) then
      begin
        LvData[LvDataLen]:= Ord(SrcName[i]);
        LvDataLen:= LvDataLen + 1;
      end
      else
      begin
        LvData[LvDataLen]:= $20;
        LvDataLen:= LvDataLen + 1;
      end;
    end;
    Pack2DataGate(CstSPCmdLv0_S_ClientLogout, LvData, LvDataLen);
    PackSendBuf(FSPCSendBuf, FSPCSendBufLen);
end;

function TSocketProtocolServer.IsIPFormat(IPAddr: string): Boolean;
var
    LvIPLen: integer;
    LvPointCnt: integer;
    LvSection: string;
    i: integer;
begin
    IPAddr:= Format('%s.', [Trim(IPAddr)]);
    LvIPLen:= Length(IPAddr);
    LvSection:= '';
    LvPointCnt:= 0;
    Result:= TRUE;
    for i:= 1 to LvIPLen do
    begin
      if not (IPAddr[i] in ['0'..'9', '.', ' ']) then
      begin
        //IP地址串中只能包含(数字)和(.)
        Result:= FALSE;
        Break;
      end
      else if (IPAddr[i] = '.') then
      begin
        LvSection:= Trim(LvSection);
        if (Length(LvSection) <= 0) or (strtointdef(LvSection, $100) > $FF) then
        begin
          Result:= FALSE;
          Break;
        end
        else
        begin
          if LvPointCnt >= 4 then
          begin
            Result:= FALSE;
            Break;
          end
          else
          begin
            LvSection:= '';
            LvPointCnt:= LvPointCnt + 1;
          end;
        end;
      end
      else
      begin
        LvSection:= LvSection + IPAddr[i];
        if (Length(LvSection) >= 4) then
        begin
          Result:= FALSE;
          Break;
        end;
      end;
    end;
end;

function TSocketProtocolServer.EnRecvBuf(RecvBuf: array of Byte; RecvLength: integer): Boolean;
var
{$ifdef SPCDebug}
    LvEnData: string;
{$endif}
    i: integer;
begin
    if (((FSPCRecvRear + RecvLength) mod SizeOf(FSPCRecvBuf)) = FSPCRecvFront) then
      Result:= FALSE
    else
    begin
      {$ifdef SPCDebug}
      LvEnData:= '';
      {$endif}
      for i:= 0 to RecvLength - 1 do
      begin
        {$ifdef SPCDebug}
        LvEnData:= Format('%s%.2x', [LvEnData, RecvBuf[i]]);
        {$endif}
        FSPCRecvBuf[FSPCRecvRear]:= RecvBuf[i];
        FSPCRecvRear:= (FSPCRecvRear + 1) mod SizeOf(FSPCRecvBuf);
      end;
      {$ifdef SPCDebug}
      if Assigned(FSPCOnLogLv1) then FSPCOnLogLv1(Format('EnBuf: %s', [LvEnData]), $00);
      {$endif}
      Result:= TRUE;
    end;
end;

function TSocketProtocolServer.DeRecvBuf(PopSize: integer): Boolean;
var
{$ifdef SPCDebug}
    LvDeData: string;
{$endif}
    i: integer;
begin
    if (((FSPCRecvFront + PopSize - 1) mod SizeOf(FSPCRecvBuf)) = FSPCRecvRear) then
      Result:= FALSE
    else
    begin
      {$ifdef SPCDebug}