nhcbiznetdriver.pas

NetHook API 对战平台内核库是一套实现时下流行的网络对战平台[如浩方、VS]同样功能的通用内核库

  end;
end;

//-----------------------------------------------------------------------------
// 描述: 从处理器中删除请求包 (根据数据包SeqNumber)
//-----------------------------------------------------------------------------
procedure TUdpTaskExecutor.RemoveReqPacket(PacketSeqNumber: Cardinal);
begin
  FTaskList.RemoveTasks(PacketSeqNumber);
end;

//-----------------------------------------------------------------------------
// 描述: 从处理器中删除请求包 (根据 Caller)
//-----------------------------------------------------------------------------
procedure TUdpTaskExecutor.RemoveReqPacket(Caller: TObject);
begin
  FTaskList.RemoveTasks(Caller);
end;

//-----------------------------------------------------------------------------
// 描述: 从处理器中删除请求包 (根据 OnTaskResult)
//-----------------------------------------------------------------------------
procedure TUdpTaskExecutor.RemoveReqPacket(OnTaskResult: TUdpTaskResultEvent);
begin
  FTaskList.RemoveTasks(OnTaskResult);
end;

//-----------------------------------------------------------------------------
// 描述: 取消结果事件 (根据 Caller)
//-----------------------------------------------------------------------------
procedure TUdpTaskExecutor.CancelResultEvent(Caller: TObject);
begin
  FTaskList.CancelResultEvent(Caller);
end;

//-----------------------------------------------------------------------------
// 描述: 清空处理器
//-----------------------------------------------------------------------------
procedure TUdpTaskExecutor.Clear;
begin
  FTaskList.Clear;
end;

//-----------------------------------------------------------------------------
// 描述: 执行器的工作函数
//-----------------------------------------------------------------------------
procedure TUdpTaskExecutor.Execute;
var
  DoneList: TList;
  I: Integer;
begin
  FTaskList.Lock;
  try
    if FTaskList.Count = 0 then Exit;

    DoneList := TList.Create;
    try
      for I := 0 to FTaskList.Count - 1 do
        FTaskList[I].Process;

      for I := FTaskList.Count - 1 downto 0 do
        if FTaskList[I].Done then
          DoneList.Add(FTaskList.Extract(I));

      for I := DoneList.Count - 1 downto 0 do
        NetMgr.BizNetDriver.FUdpDoneTaskList.Add(TUdpTask(DoneList[I]));
    finally
      DoneList.Free;
    end;
  finally
    FTaskList.Unlock;
  end;
end;

{ TUdpPacketDupChecker }

constructor TUdpPacketDupChecker.Create;
begin
  inherited;
  ThreadSafe := True;
  FActionCodes := TList.Create;
  FSenders := TIntMap.Create;
end;

destructor TUdpPacketDupChecker.Destroy;
begin
  Clear;
  FActionCodes.Free;
  FSenders.Free;
  inherited;
end;

function TUdpPacketDupChecker.IsRegActionCode(ActionCode: Integer): Boolean;
var
  I: Integer;
begin
  Result := False;
  for I := 0 to FActionCodes.Count - 1 do
    if ActionCode = Integer(FActionCodes[I]) then
    begin
      Result := True;
      Break;
    end;
end;

//-----------------------------------------------------------------------------
// 描述: 检测前自动调用此函数，从包首部中取出关键数据
// 返回:
//   True  - 允许检测
//   False - 不允许检测
//-----------------------------------------------------------------------------
function TUdpPacketDupChecker.BeforeCheck(const PacketHeader;
  var SenderID, SeqNumber, ActionCode: Integer): Boolean;
var
  HeaderPtr: PBizUdpPacketHeader;
begin
  HeaderPtr := PBizUdpPacketHeader(@PacketHeader);
  // 对于SenderID为-1的包，不做检查
  Result := (HeaderPtr.SenderID >= 0);
  if Result then
  begin
    SenderID := HeaderPtr.SenderID;
    SeqNumber := HeaderPtr.SeqNumber;
    ActionCode := HeaderPtr.ActionCode;
  end;
end;

//-----------------------------------------------------------------------------
// 描述: 注册一个需要检查是否重复包的动作代码
//-----------------------------------------------------------------------------
procedure TUdpPacketDupChecker.RegisterActionCode(ActionCode: Integer);
begin
  Lock;
  try
    if not IsRegActionCode(ActionCode) then
      FActionCodes.Add(Pointer(ActionCode));
  finally
    Unlock;
  end;
end;

//-----------------------------------------------------------------------------
// 描述: 注销一个需要检查是否重复包的动作代码
//-----------------------------------------------------------------------------
procedure TUdpPacketDupChecker.UnregisterActionCode(ActionCode: Integer);
var
  I: Integer;
begin
  Lock;
  try
    for I := 0 to FActionCodes.Count - 1 do
      if ActionCode = Integer(FActionCodes[I]) then
      begin
        FActionCodes.Delete(I);
        Break;
      end;
  finally
    Unlock;
  end;
end;

//-----------------------------------------------------------------------------
// 描述: 检查是否重复包
// 参数:
//   PacketHeader - 待检查的数据包的首部
// 返回:
//   True  - 是重复包
//   False - 不是重复包
//-----------------------------------------------------------------------------
function TUdpPacketDupChecker.Check(const PacketHeader): Boolean;
var
  I, SenderID, SeqNumber, ActionCode: Integer;
  SeqNumbers: TList;
begin
  Result := False;
  Lock;
  try
    // 从包首部中取出关键数据
    if not BeforeCheck(PacketHeader, SenderID, SeqNumber, ActionCode) then Exit;

    // 如果没有注册这个动作代码则不做检查
    if not IsRegActionCode(ActionCode) then Exit;

    // 如果还没有登记这个SenderID
    if not FSenders.GetValue(SenderID, Integer(SeqNumbers)) then
    begin
      SeqNumbers := TList.Create;
      FSenders.Add(SenderID, Integer(SeqNumbers));
    end else
    begin
      for I := 0 to SeqNumbers.Count - 1 do
        if SeqNumber = Integer(SeqNumbers[I]) then
        begin
          Result := True;
          Break;
        end;
    end;

    // 把新包的顺序号加到列表中
    if not Result then
    begin
      SeqNumbers.Insert(0, Pointer(SeqNumber));
      if SeqNumbers.Count > MaxChkDupSeqsPerSender then
        SeqNumbers.Delete(SeqNumbers.Count - 1);
    end;
  finally
    Unlock;
  end;
end;

//-----------------------------------------------------------------------------
// 描述: 删除一个用户的检测记录
//-----------------------------------------------------------------------------
procedure TUdpPacketDupChecker.ClearUser(SenderID: Integer);
var
  SeqNumbers: TList;
begin
  Lock;
  try
    if FSenders.GetValue(SenderID, Integer(SeqNumbers)) then
      SeqNumbers.Free;
    FSenders.Remove(SenderID);
  finally
    Unlock;
  end;
end;

//-----------------------------------------------------------------------------
// 描述: 删除所有检测记录
//-----------------------------------------------------------------------------
procedure TUdpPacketDupChecker.Clear;
var
  I: Integer;
  SeqNumbers: TList;
begin
  Lock;
  try
    for I := 0 to FSenders.Count - 1 do
    begin
      SeqNumbers := TList(FSenders.Items[I].Value);
      SeqNumbers.Free;
    end;
    FSenders.Clear;
  finally
    Unlock;
  end;
end;

{ TTcpTask }

constructor TTcpTask.Create;
begin
  inherited;
  FAckPacket := TBufferStream.Create;
  SetState(ttsConnect);
end;

destructor TTcpTask.Destroy;
begin
  FReqPacket.Free;
  FAckPacket.Free;

  // 无人接管连接，故须释放。
  if not Assigned(FOnTaskResult) and FNeedConnect then
    FreeAndNil(FConnection);

  inherited;
end;

function TTcpTask.GetDone: Boolean;
begin
  Result := tsDone in FTaskStatus;
end;

function TTcpTask.GetSuccess: Boolean;
begin
  Result := tsSuccess in FTaskStatus;
end;

//-----------------------------------------------------------------------------
// 描述: 取消结果事件
//-----------------------------------------------------------------------------
procedure TTcpTask.CancelResultEvent;
begin
  FOnTaskResult := nil;
end;

procedure TTcpTask.SetState(Value: TTcpTaskState);
begin
  FState := Value;
  FLastStateTicks := GetTickCount;
end;

procedure TTcpTask.SetNeedSleep(Value: Boolean);
begin
  NetMgr.BizNetDriver.FExecuteProcessor.SleepController.NeedSleep := Value;
end;

//-----------------------------------------------------------------------------
// 描述: 处理 ttsConnect 状态
//-----------------------------------------------------------------------------
procedure TTcpTask.DoStateConnect;
begin
  if FConnection <> nil then
  begin
    SetState(ttsSendReqPacket);
    SetNeedSleep(False);
  end else
  begin
    FConnection := TTcpClient.Create;
    // 如果连接建立完成
    if TTcpClient(FConnection).AsyncConnect(PeerAddr) then
    begin
      SetState(ttsSendReqPacket);
      SetNeedSleep(False);
    end else
    begin
      SetState(ttsWaitConnect);
      SetNeedSleep(False);
    end;
  end;
end;

//-----------------------------------------------------------------------------
// 描述: 处理 ttsWaitConnect 状态
//-----------------------------------------------------------------------------
procedure TTcpTask.DoStateWaitConnect;
var
  ConnectState: TAsyncConnectState;
begin
  Assert(FConnection <> nil);

  ConnectState := TTcpClient(FConnection).CheckAsyncConnectState;
  // 如果连接建立完成
  if ConnectState = acsConnected then
  begin
    SetState(ttsSendReqPacket);
    SetNeedSleep(False);
  end else
  begin
    // 如果连接建立超时，或连接发生错误
    if (GetTickDiff(FLastStateTicks, GetTickCount) > TcpConnectTimeout) or
      (ConnectState = acsFailed) then
    begin
      // 连接失败
      raise Exception.Create('');
    end;
  end;
end;

//-----------------------------------------------------------------------------
// 描述: 处理 ttsSendReqPacket 状态
//-----------------------------------------------------------------------------
procedure TTcpTask.DoStateSendReqPacket;
var
  R: Integer;
begin
  if FReqPacket = nil then
  begin
    SetState(ttsWaitAckPacket);
    Exit;
  end;

  // 如果数据尚未发送完毕
  if FReqPacketSentSize < FReqPacket.Size then
  begin
    R := FConnection.WriteBuffer((FReqPacket.Buffer + FReqPacketSentSize)^,
      FReqPacket.Size - FReqPacketSentSize);
    Inc(FReqPacketSentSize, R);

    if R > 0 then SetNeedSleep(False);
  end;

  // 如果数据已发送完毕
  if FReqPacketSentSize >= FReqPacket.Size then
  begin
    SetState(ttsWaitAckPacket);
    SetNeedSleep(False);
  end;
end;

//-----------------------------------------------------------------------------
// 描述: 处理 ttsWaitAckPacket 状态
//-----------------------------------------------------------------------------
procedure TTcpTask.DoStateWaitAckPacket;
begin
  if not FNeedAck then
  begin
    FTaskStatus := [tsDone, tsSuccess];
    Exit;
  end;

  if FSocketError then
    FTaskStatus := [tsDone];

  if FAckPacket.Size = 0 then
  begin
    // 如果接收超时
    if GetTickDiff(FLastStateTicks, GetTickCount) > TcpRecvPacketTimeout then
    begin
      // 连接失败
      raise Exception.Create('');
    end;

    NetMgr.BizNetDriver.FTcpPacketRecverList.AddConnection(FConnection, 1);
  end else
  begin
    // 如果收到了应答包
    FTaskStatus := [tsDone, tsSuccess];
  end;
end;

//-----------------------------------------------------------------------------
// 描述: 初始化任务参数
//-----------------------------------------------------------------------------
procedure TTcpTask.InitParams(Executor: TTcpTaskExecutor;
  const PeerAddr: TPeerAddress; Connection: TTcpConnection;
  ReqPacket: TBizTcpPacket; NeedAck: Boolean; Caller: TObject;
  OnTaskResult: TTcpTaskResultEvent);
begin
  FExecutor := Executor;
  FPeerAddr := PeerAddr;
  FConnection := Connection;
  FReqPacket := ReqPacket;
  FNeedAck := NeedAck;
  FNeedConnect := (Connection = nil);
  FCaller := Caller;
  FOnTaskResult := OnTaskResult;
end;

//-----------------------------------------------------------------------------
// 描述: 执行连接任务
//-----------------------------------------------------------------------------
procedure TTcpTask.Process;

  procedure HandleException;
  begin
    if FNeedConnect then
      FreeAndNil(FConnection);
    FTaskStatus := [tsDone];