DIOCP之DEMO-登陆验证设计（二）

ECHOServer代码（不考虑粘包的处理）：

unit ufrmMain;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ActnList, diocp_tcp_server, ExtCtrls,
ComCtrls, utils_safeLogger, utils_BufferPool, utils_fileWriter, System.Actions, ComObj;

type
TfrmMain = class(TForm)
edtPort: TEdit;
btnOpen: TButton;
actlstMain: TActionList;
actOpen: TAction;
actStop: TAction;
btnDisconectAll: TButton;
pgcMain: TPageControl;
TabSheet1: TTabSheet;
tsLog: TTabSheet;
mmoLog: TMemo;
pnlMonitor: TPanel;
btnGetWorkerState: TButton;
btnFindContext: TButton;
pnlTop: TPanel;
btnPostWSAClose: TButton;
btnReOpenTest: TButton;
tmrKickOut: TTimer;
tmrTest: TTimer;
tmrInfo: TTimer;
chkLogDetails: TCheckBox;
tsOperator: TTabSheet;
mmoPushData: TMemo;
btnPushToAll: TButton;
actPushToAll: TAction;
btnPoolInfo: TButton;
edtThread: TEdit;
chkEcho: TCheckBox;
chkShowInMemo: TCheckBox;
chkSaveToFile: TCheckBox;
chkUseContextPool: TCheckBox;
chkUseBufferPool: TCheckBox;
mmo1: TMemo;
btn1: TButton;
mmo2: TMemo;
procedure actOpenExecute(Sender: TObject);
procedure actPushToAllExecute(Sender: TObject);
procedure actStopExecute(Sender: TObject);
procedure btnDisconectAllClick(Sender: TObject);
procedure btnFindContextClick(Sender: TObject);
procedure btnGetWorkerStateClick(Sender: TObject);
procedure btnPoolInfoClick(Sender: TObject);
procedure btnPostWSACloseClick(Sender: TObject);
procedure btnReOpenTestClick(Sender: TObject);
procedure chkEchoClick(Sender: TObject);
procedure chkLogDetailsClick(Sender: TObject);
procedure chkSaveToFileClick(Sender: TObject);
procedure chkShowInMemoClick(Sender: TObject);
procedure chkUseBufferPoolClick(Sender: TObject);
procedure tmrInfoTimer(Sender: TObject);
procedure tmrKickOutTimer(Sender: TObject);
procedure tmrTestTimer(Sender: TObject);
procedure btn1Click(Sender: TObject);
private
//iCounter:Integer;
FChkUseBufferPool:Boolean;
FChkEcho:Boolean;
FChkShowInMemo:Boolean;
FChkSaveToFile:Boolean;
FTcpServer: TDiocpTcpServer;
FPool:PBufferPool;
procedure ReadState;
procedure RefreshState;
procedure OnRecvBuffer(pvClientContext:TIocpClientContext; buf:Pointer;
len:cardinal; errCode:Integer);

procedure OnSendBufferCompleted(pvContext: TIocpClientContext; pvBuff: Pointer;
len: Cardinal; pvBufferTag, pvErrorCode: Integer);

procedure OnAccept(pvSocket: THandle; pvAddr: String; pvPort: Integer; var
vAllowAccept: Boolean);
procedure OnDisconnected(pvClientContext: TIocpClientContext);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
{ Public declarations }
end;

var
frmMain: TfrmMain;
LoginGUID:TStringList;
implementation

uses
uFMMonitor, diocp_core_engine, diocp_core_rawWinSocket,StrUtils;

{$R *.dfm}

constructor TfrmMain.Create(AOwner: TComponent);
begin
inherited Create(AOwner);

sfLogger.setAppender(TStringsAppender.Create(mmoLog.Lines));
sfLogger.AppendInMainThread := true;

FTcpServer := TDiocpTcpServer.Create(Self);
FTcpServer.Name := 'iocpSVR';
FTcpServer.OnDataReceived := self.OnRecvBuffer;
FTcpServer.OnContextAccept := OnAccept;
FTcpServer.createDataMonitor;
FTcpServer.OnSendBufferCompleted := OnSendBufferCompleted;
FTcpServer.OnContextDisconnected := OnDisconnected;
FPool := NewBufferPool(FTcpServer.WSARecvBufferSize);
TFMMonitor.createAsChild(pnlMonitor, FTcpServer);
ReadState;

LoginGUID:=TStringList.Create;
end;

destructor TfrmMain.Destroy;
begin
FTcpServer.SafeStop;
FreeBufferPool(FPool);
FTcpServer.Free;
LoginGUID.Free;
inherited Destroy;
end;

procedure TfrmMain.RefreshState;
begin
if FTcpServer.Active then
begin
btnOpen.Action := actStop;

end else
begin
LoginGUID.Clear;
btnOpen.Action := actOpen;
end;
chkUseContextPool.Enabled := not FTcpServer.Active;
edtPort.Enabled := not FTcpServer.Active;
edtThread.Enabled := not FTcpServer.Active;
end;

procedure TfrmMain.actOpenExecute(Sender: TObject);
begin
FTcpServer.WorkerCount := StrToInt(edtThread.Text);
FTcpServer.Port := StrToInt(edtPort.Text);
FTcpServer.OnDataReceived := self.OnRecvBuffer;
FTcpServer.UseObjectPool := chkUseContextPool.Checked;
FTcpServer.Active := true;
RefreshState;
end;

procedure TfrmMain.actPushToAllExecute(Sender: TObject);
var
ansiStr:AnsiString;
var
lvList:TList;
i:Integer;
lvContext:TIocpClientContext;
begin
ansiStr := mmoPushData.Lines.Text;
lvList := TList.Create;
try
FTcpServer.getOnlineContextList(lvList);
for i:=0 to lvList.Count -1 do
begin
lvContext := TIocpClientContext(lvList[i]);
lvContext.PostWSASendRequest(PAnsiChar(ansiStr), Length(ansiStr));
end;
finally
lvList.Free;
end;
end;

procedure TfrmMain.actStopExecute(Sender: TObject);
begin
FTcpServer.DisconnectAll;
FTcpServer.SafeStop;
RefreshState;
end;

procedure TfrmMain.btn1Click(Sender: TObject);
begin
mmo2.Text:=LoginGUID.Text;
end;

procedure TfrmMain.btnDisconectAllClick(Sender: TObject);
begin
FTcpServer.DisConnectAll();
end;

procedure TfrmMain.btnFindContextClick(Sender: TObject);
var
lvList:TList;
i:Integer;
begin
lvList := TList.Create;
try
FTcpServer.getOnlineContextList(lvList);
for i:=0 to lvList.Count -1 do
begin
FTcpServer.findContext(TIocpClientContext(lvList[i]).SocketHandle);
end;
finally
lvList.Free;
end;

end;

procedure TfrmMain.btnGetWorkerStateClick(Sender: TObject);
begin
ShowMessage(FTcpServer.IocpEngine.getWorkerStateInfo(0));
end;

procedure TfrmMain.btnPoolInfoClick(Sender: TObject);
var
s:string;
r:Integer;
begin
if FPool = nil then Exit;
s :=Format('get:%d, put:%d, addRef:%d, releaseRef:%d, size:%d',
[FPool.FGet, FPool.FPut, FPool.FAddRef, FPool.FReleaseRef, FPool.FSize]);
r := CheckBufferBounds(FPool);
s := s + sLineBreak + Format('池中共有:%d个内存块, 可能[%d]个内存块写入越界的情况', [FPool.FSize, r]);
ShowMessage(s);
end;

procedure TfrmMain.btnPostWSACloseClick(Sender: TObject);
var
lvList:TList;
i:Integer;
begin
lvList := TList.Create;
try
FTcpServer.getOnlineContextList(lvList);
for i:=0 to lvList.Count -1 do
begin
TIocpClientContext(lvList[i]).PostWSACloseRequest();
end;
finally
lvList.Free;
end;

end;

procedure TfrmMain.btnReOpenTestClick(Sender: TObject);
begin
FTcpServer.logMessage('DoHeartBeatChcek', 'DEBUG', lgvDebug);
tmrTest.Enabled := not tmrTest.Enabled;
end;

procedure TfrmMain.chkLogDetailsClick(Sender: TObject);
begin
if chkLogDetails.Checked then
begin
FTcpServer.Logger.LogFilter := LogAllLevels;
end else
begin
FTcpServer.Logger.LogFilter := [lgvError]; // 只记录致命错误
end;
end;

procedure TfrmMain.chkEchoClick(Sender: TObject);
begin
ReadState;
end;

procedure TfrmMain.chkSaveToFileClick(Sender: TObject);
begin
ReadState;
end;

procedure TfrmMain.chkShowInMemoClick(Sender: TObject);
begin
ReadState;
end;

procedure TfrmMain.chkUseBufferPoolClick(Sender: TObject);
begin
ReadState;
end;

procedure TfrmMain.OnAccept(pvSocket: THandle; pvAddr: String; pvPort: Integer;
var vAllowAccept: Boolean);
begin
mmo1.Lines.Add(pvAddr+':'+inttostr(pvPort));
// if pvAddr = '127.0.0.1' then
// vAllowAccept := false;

end;

procedure TfrmMain.OnDisconnected(pvClientContext: TIocpClientContext);
begin
if pvClientContext.Data <> nil then
begin
TObject(pvClientContext.Data).Free;
pvClientContext.Data := nil;
end;
end;

procedure TfrmMain.OnRecvBuffer(pvClientContext:TIocpClientContext;
buf:Pointer; len:cardinal; errCode:Integer);
var
j:Integer;
s:AnsiString;
lvBuff:PByte;
lvFileWriter:TSingleFileWriter;
sGUID:string;
PostGUID:string;
begin
if FChkShowInMemo then
begin
sGUID := CreateClassID;
// 如果客户端发送的为字符串，可以用下面代码进行显示
SetLength(s, len);
Move(buf^, s[1], len);
sfLogger.logMessage(s);
if Pos('GUID',s)>0 then
begin
PostGUID:=midstr(s,6,38);
if LoginGUID.IndexOf(PostGUID)<>-1 then

begin

pvClientContext.PostWSASendRequest( PAnsiChar('Success;GUID='+AnsiString(PostGUID)), Length('Success;GUID='+AnsiString(PostGUID)));

//这里可写其它的业务处理代码，就是一次交互数据等，客户端每次与服务器交互时都带上服务器分配的GUID做为身份名牌

end

else
pvClientContext.PostWSASendRequest(PAnsiChar('Eerror'), Length('Eerror'));
end
else
if s='stu=admin&pwd=admin123' then
begin
LoginGUID.Sorted:=True;
LoginGUID.Duplicates := dupIgnore;
LoginGUID.Add(sGUID);
pvClientContext.PostWSASendRequest( PAnsiChar('Success;GUID='+AnsiString(sGUID)), Length('Success;GUID='+AnsiString(sGUID)));

end
else
begin
pvClientContext.PostWSASendRequest(PAnsiChar('Eerror'), Length('Eerror'));
pvClientContext.DoDisconnect;
end;

end;
if FChkEcho then
begin
if FChkUseBufferPool then
begin

lvBuff := GetBuffer(FPool);

Move(buf^, lvBuff^, len);

//
AddRef(lvBuff);

pvClientContext.PostWSASendRequest(lvBuff, len, dtNone, 1);
end else
begin
pvClientContext.PostWSASendRequest(buf, len);
end;
end;

if FChkShowInMemo then
begin
lvFileWriter := TSingleFileWriter(pvClientContext.Data);
if lvFileWriter = nil then
begin
lvFileWriter := TSingleFileWriter.Create;
pvClientContext.Data := lvFileWriter;
lvFileWriter.FilePreFix := Format('RECV_%d', [pvClientContext.SocketHandle]);
lvFileWriter.FilePerSize := 1024 * 1024 * 100;
end;

lvFileWriter.WriteBuffer(buf, len);
end;
end;

procedure TfrmMain.OnSendBufferCompleted(pvContext: TIocpClientContext; pvBuff:
Pointer; len: Cardinal; pvBufferTag, pvErrorCode: Integer);
begin
if pvBufferTag = 1 then
ReleaseRef(pvBuff);
end;

procedure TfrmMain.ReadState;
begin
FChkEcho := chkEcho.Checked;
FChkShowInMemo := chkShowInMemo.Checked;
FChkUseBufferPool := chkUseBufferPool.Checked;
FChkSaveToFile := chkSaveToFile.Checked;
end;

procedure TfrmMain.tmrInfoTimer(Sender: TObject);
begin
self.Caption := Format('DIOCP 测试:%d, %d', [__DebugWSACreateCounter, __DebugWSACloseCounter]);
end;

procedure TfrmMain.tmrKickOutTimer(Sender: TObject);
begin
FTcpServer.KickOut(30000);
end;

procedure TfrmMain.tmrTestTimer(Sender: TObject);
begin
actStop.Execute;

Application.ProcessMessages;

actOpen.Execute;

end;

end.