目录
控件源代码下载: WebSocket_Component_Source.rar
非常感谢我服务的公司，感谢公司老板开明，给我们营造了很好的工作、学习氛围，开放，包容，让大家可以充分发挥自己的能力，本来我们目前没有项目打算使用Websocket，在微信公众号开发过程中偶然遇到需要长连接，就需要WebSocket，我在网上查询了，delphi语言除了商业的控件以外，似乎没有真正的可用的Websocket（delphi）服务器端控件（也许有，我没有查找到），所以就想尝试开发一个，在5.1假期就做了这个控件，上班后继续完善，老板给了很多支持，也很支持互联网开源。我把控件源代码可演示程序源代码发出来，旨在抛砖引玉，愿与大家共同学习，共同进步！大家有WebSocke方面的解决方案或者问题，可以加我QQ: 910731685或者微信扫描下面二维码，加入WebSocket 技术讨论群 讨论。为了表示对公司的感谢，演示程序上的logo是我公司的logo及注册商标，实际使用控件不影响。
控件源代码下载: WebSocket_Component_Source.rar
一、WebSocket Demo程序
1、测试程序界面：
2、测试客户端：
为了测试Websocket服务端控件，必须要有客户端，客户端实际上是一段js代码，就是一个Web页面，在源程序里是index.html这个文件，这个页面在浏览器里边打开，或者在HBuilder编辑器里边打开刷新即可。为了测试方便，在测试程序中，【打开服务】后 ，可以直接按下【谷歌浏览器】（其它浏览器，请自行打开运行），程序就会自动打开谷歌浏览器，然后就是一个Websocket的客户端，客户端代码如下：
<!doctype html>
<style>
textarea { vertical-align: bottom; }
#output { overflow: auto; }
#output > p { overflow-wrap: break-word; }
#output span { color: blue; }
#output span.error { color: red; }
</style>
<h2>WebSocket Test</h2>
<textarea cols=60 rows=6></textarea>
<button>send</button>
<div id=output></div>
<script>
// http://www.websocket.org/echo.html
var button = document.querySelector("button"),
output = document.querySelector("#output"),
textarea = document.querySelector("textarea"),
//wsUri = "ws://echo.websocket.org/",
wsUri = "ws://127.0.0.1:3002",
//wsUri = "ws://sslTest.local:3002",
websocket = new WebSocket(wsUri);
button.addEventListener("click", onClickButton);
websocket.onopen = function (e) {
writeToScreen("CONNECTED");
doSend('SZHN');
//doSend("1234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890");
};
websocket.onclose = function (e) {
writeToScreen("DISCONNECTED");
};
websocket.onmessage = function (e) {
writeToScreen("<span>RESPONSE: " + e.data + "</span>");
};
websocket.onerror = function (e) {
writeToScreen("<span class=error>ERROR:</span> " + e.data);
};
function doSend(message) {
writeToScreen("SENT: " + message);
websocket.send(message);
}
function writeToScreen(message) {
output.insertAdjacentHTML("afterbegin", "<p>" + message + "</p>");
}
function onClickButton() {
var text = textarea.value;
text && doSend(text);
textarea.value = "";
textarea.focus();
}
</script>
切记：
index.html里边的 wsUri = "ws://127.0.0.1:3002",中的端口号要和测试程序中设置的端口号一致，可以更改，但一致才可以。
3、操作步骤
第一步：按下【打开服务】
第二步：按下【谷歌浏览器】
第三步：选择客户端，给客户端发送消息
第四步：客户端给服务端发送消息
第五步：可以同时打开多个客户端，多次按下【谷歌浏览器】
其它功能，请尽情测试，不再赘述！
3、控件核心代码：
{2020-04-29 开始开发
1. 需要使用到 Indy TidTCPServer 控件；
2. 需要处理线程中事件回调问题
3. 需要记录 各个连接的 AContext: TIdContext,以便后续处理，包括断开，发信息等等
4. 需要使用到正则函数
//实际的握手信号， Client端发过来的
GET / HTTP/1.1
Upgrade: websocket
Connection: Upgrade
Host: ssltest.local:3002
Origin: http://127.0.0.1:8020
Pragma: no-cache
Cache-Control: no-cache
Sec-WebSocket-Key: fS9cWqJVhWrwc8+4S3vj3A==
Sec-WebSocket-Version: 13
Sec-WebSocket-Extensions: permessage-deflate; client_max_window_bits, x-webkit-deflate-frame
User-Agent: Mozilla/5.0 (Windows NT 6.3; WOW64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/35.0.1916.138 Safari/537.36
分析client 端的数据，已经握手成功
0 1 2 3
0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1
+-+-+-+-+-------+-+-------------+-------------------------------+
|F|R|R|R| opcode|M| Payload len | Extended payload length |
|I|S|S|S| (4) |A| (7) | (16/64) |
|N|V|V|V| |S| | (if payload len==126/127) |
| |1|2|3| |K| | |
+-+-+-+-+-------+-+-------------+ - - - - - - - - - - - - - - - +
| Extended payload length continued, if payload len == 127 |
+ - - - - - - - - - - - - - - - +-------------------------------+
| |Masking-key, if MASK set to 1 |
+-------------------------------+-------------------------------+
| Masking-key (continued) | Payload Data |
+-------------------------------- - - - - - - - - - - - - - - - +
: Payload Data continued ... :
+ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +
| Payload Data continued ... |
+---------------------------------------------------------------+
FIN : 此位指示是否已从客户端发送完整消息（最后一包消息）。
RSV1,RSV2,RSV3 : 这些位必须为0，除非协商了向它们提供非零值的扩展。
opcode : 这些位描述接收到的消息类型。操作码0x1表示这是一条文本消息。
0 : 表示是一个连续的Frame
1 : 表示是一条文本消息
2 : 表示是流消息
3-7 : 保留
8 : 表示一个连接关闭
9 : 一个ping
A : 一个pong
B-F : 保留 （自定义 ： B Client端发送的FIN不是1）
M : 定义是否包含“有效加密数据”。如果设置为1，则数据中包含加密密钥，这用于解除“有效加密数据”的数据。从客户端到服务器的所有消息都设置了此位。
Payload Length : 如果此值介于0和125之间，则为消息的长度。如果是126，则以下2个字节（16位无符号整数）是长度。如果是127，则以下8个字节（64位无符号整数）是长度。
关于连续帧数据的说明：
对于作为三个片段发送的文本消息，第一个片段的操作码为0x1，FIN位为clear；第二个片段的操作码为0x0，FIN位为clear，
第三个片段有一个0x0操作码和一个FIN位，说明整个数据已经准备好了。
}
unit uWebSocket_Component;
interface
uses
IdCustomTCPServer, IdTCPServer, IdContext,IdComponent,IdGlobal, //关于 TidTCPServer
System.Hash,
System.NetEncoding,
System.RegularExpressions, //正则，编码，Hash 库
system.DateUtils,
Vcl.ExtCtrls, //Timer
System.SysUtils, System.Classes;
const
CWebSocket_KEY = '258EAFA5-E914-47DA-95CA-C5AB0DC85B11'; //标准要求的
type
TClientInfo = record
ClientIP : string;
ClientPort : Word;
ConnectTime : TDateTime; //连接成功时间
HandshakeTime : TDateTime; //握手成功时间
ping_Timeout : TDateTime; //发送ping命令之后，需要在这个时间之前得到回复，如果没有得到回复，则需要挂断客户端 0:表示没有发送ping命令
R_Last_Text : string; //最后一次接收到的文本数据
S_Last_Text : string; //最后一次发送的数据
R_Count : integer; //接收的消息次数
S_Count : integer; //发送的消息次数
ID : string; //唯一的索引 是 ClientIP + ':' + ClientPort
DisConnect : Boolean; //断开客户端连接
User_Agent : string;
end;
//创建一个包含客户端连接信息的ContextClass
TMyContext = class(TIdServerContext)
ClientInfo: TClientInfo;
end;
TOnStartup = procedure(Sender : TObject) of object; //服务器启动事件
TOnShutdown = procedure(Sender : TObject) of object; //服务器关闭事件
TOnConnect = procedure(ClientID : string) of object;
TOnDisConnect = procedure(ClientID : string) of object;
TOnError = procedure(ClientID : string; ErrorMsg : string) of object;
TOnException = procedure(Sender : TObject; ErrorMsg : string) of object;
TOnHandhake = procedure(ClientID : string; WebSocket_Key,WebSocket_Version,User_Agent : string) of object;
TOnMessage = procedure(ClientID : string; Text_Message : string) of object;
TOnBinary = procedure(ClientID : string; Bytes_Message : TBytes) of object;
TOnPong = procedure(ClientID : string; Text_Message : string) of object;
TWebSocket = class(TComponent)
private
FIdTCPServer : TIdTCPServer; //indy的TCP服务器
//定义属性
FActive : Boolean; //服务器是否启动
FWebPort : Word; //WebSocket的打开端口
FVersion : string;
FHeartBeat : Boolean; //是否允许心跳，默认是False
FInterval : Word; //心跳间隔时间，单位是秒，默认60秒
FHandShakeTimeout : Integer; //超时时间，单位： ms
FPingTimeout : integer; //单位是毫秒， 默认10 * 1000
FReadTimeOut : Word; //线程中，检查数据的时间间隔，默认是10毫秒，减少CPU占用用时间
FMaxConnections : integer; //最大连接数
FConnectionList : TStringList;
FPingTimer : TTimer; //进行ping 的定时器
FOnStartup : TOnStartup; //服务器启动事件
FOnShutdown : TOnShutdown; //服务器停止事件
FOnConnect : TOnConnect; //客户端连接成功
FOnDisConnect : TOnDisConnect; //客户端断开连接
FOnError : TOnError; //错误发生事件，例如握手错误
FOnException : TOnException; //TCPServer的异常事件
FOnHandhake : TOnHandhake; //握手成功事件
FOnMessage : TOnMessage; //收到客户端消息
FOnBinary : TOnBinary; //二进制消息
FOnPong : TOnPong; //Pong事件
procedure SetWebPort(Value : Word);
procedure SetVersion(Value : string);
procedure SetHandShakeTimeout(Value : integer);
procedure SetPingTimeout(Value : integer);
procedure SetHeartBeat(Value : Boolean);
procedure SetInterval(Value : Word);
procedure SetReadTimeOut(Value : Word);
procedure SetMaxConnections(Value : integer);
//ping定时器 事件
procedure Ping_OnTimer(Sender: TObject);
//在字节流后增加字节流
function AppendBytes(const ABytes, BBytes: TBytes): TBytes;
//数据字节流转 HEX字符串
function Bytes_To_HexStr(Bytes: TBytes; Delia: string = ' '; BCount: Byte = 32): string;
//服务器端，根据发送的数据，生成协议需要的数据
function Build_WebSocketBytes(SourceData : TBytes; opcode : Byte = $01) : TBytes;
//获取FIN,opcode 等函数, 通过第一个字节判断
function Get_FIN_and_opcode(ClientData : TBytes; var opcode : Byte) : Boolean; //取得FIN,True表示已经设置FIN，False表示没有设置FIN
//获取客户端实际的发送数据，作为字节流返回，掩码后的
function Get_ClientData(ClientData :TBytes) : TBytes; //得到解密后的实际数据
//处理握手函数,如果握手成功，则返回True，否则返回False, 同时 ErrorMsg中包含错误信息
function Process_Handshake(Context : TIdContext; var ErrorMsg : string) : Boolean;
protected
//TidTCPServer 事件处理函数
procedure IdTCPServer_Connect(AContext: TIdContext);
procedure IdTCPServer_Disconnect(AContext: TIdContext);
procedure IdTCPServer_ContextCreated(AContext: TIdContext);
procedure IdTCPServer_Execute(AContext: TIdContext);
procedure IdTCPServer_Exception(AContext: TIdContext; AException: Exception);
procedure IdTCPServer_Status(ASender: TObject; const AStatus: TIdStatus; const AStatusText: string);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
//对外公共方法
procedure Start_WebSocketServer; //启动服务器
procedure Stop_WebSocketServer; //停止服务器
procedure DisconnectAll; //断开所有连接
procedure ping(ClientID : string; Application_data : string = ''); //sends a ping to all connected clients. If a time-out is specified, it waits a response until a time-out is exceeded, if no response, then closes the connection.
function Connections : TStringList;
function Count : Word;
function WriteBytes(const ClientID : string; Bytes_Message : TBytes; var ErrorMsg : string): Boolean; //发送字节数据流
function WriteTexts(const ClientID : string; Text_Message : string; var ErrorMsg : string): Boolean;
procedure Broadcast(Text_Message : string); //广播消息给所有客户端，不判断是否成功
function Get_ClientInfo(ClientID : string) : TClientInfo;
published
property Active : Boolean read FActive; //指示服务器状态
property WebPort : Word read FWebPort write SetWebPort;
property Version : string read FVersion;
property HeartBeat : Boolean read FHeartBeat write SetHeartBeat default False;
property Interval : Word read FInterval write SetInterval;
property HandShakeTimeout : integer read FHandShakeTimeout write SetHandShakeTimeout;
property PingTimeout : integer read FPingTimeout write SetPingTimeout;
property ReadTimeout : Word read FReadTimeOut write SetReadTimeOut;
property MaxConnections : integer read FMaxConnections write SetMaxConnections;
property OnStartup : TOnStartup read FOnStartup write FOnStartup;
property OnShutdown : TOnShutdown read FOnShutdown write FOnShutdown;
property OnConnect : TOnConnect read FOnConnect write FOnConnect;
property OnDisConnect : TOnDisConnect read FOnDisConnect write FOnDisConnect;
property OnError : TOnError read FOnError write FOnError;
property OnException : TOnException read FOnException write FOnException;
property OnHandShake : TOnHandhake read FOnHandhake write FOnHandhake;
property OnMessage : TOnMessage read FOnMessage write FOnMessage;
property OnBinary : TOnBinary read FOnBinary write FOnBinary;
property OnPong : TOnPong read FOnPong write FOnPong;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('LW', [TWebSocket]);
end;
{ TWebSocket }
function TWebSocket.AppendBytes(const ABytes, BBytes: TBytes): TBytes;
var
BLen, OldLen: Integer;
begin
BLen := Length(BBytes);
if BLen <= 0 then
Exit;
OldLen := Length(ABytes);
SetLength(Result, OldLen + BLen);
if OldLen > 0 then
Move(ABytes[0], Result[0], OldLen);
Move(BBytes[0], Result[OldLen], BLen);
end;
procedure TWebSocket.Broadcast(Text_Message: string);
var
LContext: TIdContext;
LList: TIdContextList;
i : integer;
B : TBytes;
begin
if FIdTCPServer.Contexts = nil then Exit;
LList := FIdTCPServer.Contexts.LockList;
try
for i := 0 to LList.Count - 1 do
begin
LContext := {$IFDEF HAS_GENERICS_TList}LList.Items[i]{$ELSE}TIdContext(LList.Items[i]){$ENDIF};
//判断是否握手成功
if TMyContext(LContext).ClientInfo.HandshakeTime = 0 then
Continue;
B := TEncoding.UTF8.GetBytes(Text_Message);
B := Build_WebSocketBytes(B);
LContext.Connection.IOHandler.Write(TidBytes(B));
//更新发送计数
TMyContext(LContext).ClientInfo.S_Last_Text := Text_Message;
TMyContext(LContext).ClientInfo.S_Count := TMyContext(LContext).ClientInfo.S_Count + 1;
end;
finally
FIdTCPServer.Contexts.UnLockList;
end;
end;
function TWebSocket.Build_WebSocketBytes(SourceData: TBytes; opcode : Byte = $01): TBytes;
var
Len : Int64;
begin
//1. 取得数据长度
Len := Length(SourceData);
if Len = 0 then Exit;
if opcode > $0F then Exit; //opcode 的有效值是 0 - F
//2. 构建第一个包含opcode 的字节
if Len <= 125 then
begin
SetLength(Result, Len + 2);
Result[0] := $80 + opcode ;// $81; //129 表示是最后一帧
Result[1] := Len; //实际的数据长度
move(SourceData[0],Result[2],Len);
Exit;
end;
if (Len > 125) and (Len <= 65535) then
begin
SetLength(Result, Len + 4);
Result[0] := $80 + opcode ;// $81; //129 表示是最后一帧
Result[1] := 126; //包含两个字节的数据长度
Result[2] := Len div 256;
Result[3] := len mod 256;
move(SourceData[0],Result[4],Len);
Exit;
end;
if Len > 65535 then
begin
SetLength(Result, Len + 6);
Result[0] := $80 + opcode ;// $81; //129 表示是最后一帧
Result[1] := 127; //包含两个字节的数据长度
Result[2] := Len div (256 * 256 * 256);
Result[3] := len mod (256 * 256);
Result[4] := Len div 256;
Result[5] := len mod 256;
move(SourceData[0],Result[6],Len);
Exit;
end;
end;
function TWebSocket.Bytes_To_HexStr(Bytes: TBytes; Delia: string;
BCount: Byte): string;
var
RB: TBytes;
i, j, Len: Integer;
S: string;
begin
if Length(Bytes) <= 0 then
Exit('');
SetLength(RB, Length(Bytes) * 2);
BinToHex(Bytes, 0, RB, 0, Length(Bytes));
S := TEncoding.ANSI.GetString(RB);
Result := '';
j := 0;
// 用空格分开
Len := Length(S);
for i := 1 to Len do
begin
if (i Mod 2) = 0 then
begin
Result := Result + S.Substring(i - 2, 2) + Delia;
j := j + 1;
if (j mod BCount) = 0 then
Result := Result + #13#10;
end;
end;
end;
function TWebSocket.Connections: TStringList;
var
LContext: TIdContext;
LList: TIdContextList;
i : integer;
B : TBytes;
begin
FConnectionList.Clear;
Result := FConnectionList;
if FIdTCPServer.Contexts = nil then Exit;
LList := FIdTCPServer.Contexts.LockList;
try
FConnectionList.Clear;
for i := 0 to LList.Count - 1 do
begin
LContext := {$IFDEF HAS_GENERICS_TList}LList.Items[i]{$ELSE}TIdContext(LList.Items[i]){$ENDIF};
FConnectionList.Append(TMyContext(LContext).ClientInfo.ID);
end;
Result := FConnectionList;
finally
FIdTCPServer.Contexts.UnLockList;
end;
end;
function TWebSocket.Count: Word;
begin
Result := FIdTCPServer.Contexts.Count;
end;
constructor TWebSocket.Create(AOwner: TComponent);
begin
inherited;
FVersion := '1.0.0.0'; //当前版本
FWebPort := 80; //默认端口号
FHandShakeTimeout := 10; //超时时间 10秒
FPingTimeout := 10; //超时时间 10秒
FHeartBeat := False;
FInterval := 60; //每隔60秒 ping 客户端一次, 最小20
FReadTimeOut := 10; //单位：ms
FMaxConnections := 0;
if not (csDesigning in ComponentState) then
begin
FConnectionList := TStringList.Create;
//创建TCP服务器
FIdTCPServer := TIdTCPServer.Create(nil);
//个性化创建，包含客户端信息
FIdTCPServer.ContextClass:= TMyContext;
FIdTCPServer.MaxConnections := FMaxConnections;
FIdTCPServer.DefaultPort := FWebPort;
FIdTCPServer.Active := False;
FIdTCPServer.OnConnect := IdTCPServer_Connect;
FIdTCPServer.OnDisconnect := IdTCPServer_Disconnect;
FIdTCPServer.OnContextCreated := IdTCPServer_ContextCreated;
FIdTCPServer.OnExecute := IdTCPServer_Execute;
FIdTCPServer.OnException := IdTCPServer_Exception;
FIdTCPServer.OnStatus := IdTCPServer_Status;
FPingTimer := TTimer.Create(nil);
FPingTimer.Interval:= FInterval * 1000; //定时器的时间间隔
FPingTimer.OnTimer := Ping_OnTimer
end;
end;
destructor TWebSocket.Destroy;
begin
if not (csDesigning in ComponentState) then
begin
if FIdTCPServer <> nil then
FIdTCPServer.Free;
FConnectionList.Free;
FPingTimer.Free;
end;
inherited;
end;
procedure TWebSocket.DisconnectAll;
var
LContext: TIdContext;
LList: TIdContextList;
i : integer;
B : TBytes;
begin
if not FActive then Exit;
if FIdTCPServer.Contexts = nil then Exit;
LList := FIdTCPServer.Contexts.LockList;
try
for i := 0 to LList.Count - 1 do
begin
LContext := {$IFDEF HAS_GENERICS_TList}LList.Items[i]{$ELSE}TIdContext(LList.Items[i]){$ENDIF};
TMyContext(LContext).ClientInfo.DisConnect := True; //设置关闭连接
end;
finally
FIdTCPServer.Contexts.UnLockList;
end;
end;
function TWebSocket.Get_ClientData(ClientData: TBytes): TBytes;
var
MaskKEY : TBytes; //掩码密钥，应该是4个字节
Payload_Length,i : Int64; //实际的数据长度
M : Byte;
B : Byte;
Payload_Len : Byte;
dataPosition : Byte;
begin
//1. 首先判断段M位是否为1，不是则错误
if Length(ClientData) <= 3 then
raise Exception.Create('Err04,数据长度不能为0');
B := ClientData[1];
M := B shr 7;
if M <> 1 then //说明从客户端发来的数据没有加密，是不正确的
raise Exception.Create('Err05,客户端数据格式不正确(没有掩码位)');
//2. 数据长度
Payload_Len := B - $80;
SetLength(MaskKEY,4);
case Payload_Len of
126 :
begin
//获取数据长度
Payload_Length := 0;
Payload_Length := ((Payload_Length or ClientData[2]) shl 8) or ClientData[3];
move(ClientData[4],MaskKEY[0],4); //MaskKEY
dataPosition := 8;
end;
127 :
begin
//获取数据长度
Payload_Length := 0;
for i := 2 to 8 do
Payload_Length := (Payload_Length or ClientData[i]) shl 8;
Payload_Length := Payload_Length or ClientData[9];
move(ClientData[2],Payload_Length,8);
move(ClientData[10],MaskKEY[0],4);
dataPosition := 14;
end
else //0-125
Payload_Length := Payload_Len;
move(ClientData[2],MaskKEY[0],4);
dataPosition := 6;
end;
//解密数据
SetLength(Result,Payload_Length);
for i := 0 to Payload_Length - 1 do
Result[i] := ClientData[i + dataPosition] xor MaskKEY[i mod 4];
end;
function TWebSocket.Get_ClientInfo(ClientID: string): TClientInfo;
var
LContext: TIdContext;
LList: TIdContextList;
i : integer;
B : TBytes;
begin
if FIdTCPServer.Contexts = nil then Exit;
LList := FIdTCPServer.Contexts.LockList;
try
for i := 0 to LList.Count - 1 do
begin
LContext := {$IFDEF HAS_GENERICS_TList}LList.Items[i]{$ELSE}TIdContext(LList.Items[i]){$ENDIF};
if (TMyContext(LContext).ClientInfo.ID = ClientID) then
begin
Result := TMyContext(LContext).ClientInfo;
Exit;
end;
end;
finally
FIdTCPServer.Contexts.UnLockList;
end;
end;
function TWebSocket.Get_FIN_and_opcode(ClientData: TBytes; var opcode: Byte): Boolean;
var
B : Byte;
begin
//只判断第一个字节
if Length(ClientData) <= 3 then
raise Exception.Create('Err02,数据长度不能为0');
//1. 首先判断是否符合数格式 x000xxxx 数据
B := ClientData[0];
B := B and $70;
if B <> 0 then
raise Exception.Create('Err03,客户端数据格式不正确');
//2. 取得FIN位
B := ClientData[0];
B := B shr 7;
Result := B = 1;
//3. 取得opcode
B := ClientData[0];
opcode := B and $0F;
end;
procedure TWebSocket.IdTCPServer_Connect(AContext: TIdContext);
begin
//发起连接成功事件
if not Assigned(FOnConnect) then Exit;
FOnConnect(AContext.Connection.Socket.Binding.PeerIP + ':' + AContext.Connection.Socket.Binding.PeerPort.ToString);
end;
procedure TWebSocket.IdTCPServer_ContextCreated(AContext: TIdContext);
begin
//初始化客户端记录结构数据
with TMyContext(AContext).ClientInfo do
begin
ClientIP := AContext.Connection.Socket.Binding.PeerIP;
ClientPort := AContext.Connection.Socket.Binding.PeerPort;
ID := ClientIP + ':' + ClientPort.ToString;
ConnectTime:= Now;
HandshakeTime := 0; //没有握手成功,如果成功，这里表示的是握手成功的时间
ping_Timeout := 0; //不是ping 状态
R_Last_Text := '';
S_Last_Text := '';
R_Count := 0;
S_Count := 0;
DisConnect := False;
end;
end;
procedure TWebSocket.IdTCPServer_Disconnect(AContext: TIdContext);
begin
if not Assigned(FOnDisConnect) then Exit;
FOnDisConnect(TMyContext(AContext).ClientInfo.ID);
end;
procedure TWebSocket.IdTCPServer_Exception(AContext: TIdContext;
AException: Exception);
var
ClientIP : string;
ClientPort : Word;
ErrorMsg : string;
begin
if Assigned(FOnException) then
begin
clientIP := AContext.Connection.Socket.BoundIP;
clientPort := AContext.Connection.Socket.BoundPort;
ErrorMsg := ClientIP + ':' + clientPort.ToString + #13#10 + AException.Message;
FOnException(Self, ErrorMsg);
end;
end;
procedure TWebSocket.IdTCPServer_Execute(AContext: TIdContext);
var
ClientIP : string;
ClientPort : Word;
len : int64;
inBytes,outBytes : TBytes;
S,sKey,sResponse : string;
ErrorMsg : string;
ClientID : string;
FIN : Boolean;
opcode : Byte;
FRB : TBytes; //结果字节流
Fopcode: Byte;
Handhake_OK : Boolean;
i : integer;
begin
ClientID := AContext.Connection.Socket.Binding.PeerIP + ':' + AContext.Connection.Socket.Binding.PeerPort.ToString;
Sleep(FReadTimeOut); //这样将减少 CPU的占用时间，但是减低实时性，不过 毫秒级是可以忽略的
if TMyContext(AContext).ClientInfo.DisConnect then
begin
AContext.Connection.Disconnect;
Exit;
end;
//1. 首先判断是否已经握手成功，判断标准是是否已经有握手时间
if TMyContext(AContext).ClientInfo.HandshakeTime = 0 then
if Process_Handshake(AContext,ErrorMsg) then //握手成功，修改握手时间
TMyContext(AContext).ClientInfo.handshakeTime := Now
else //握手失败，关闭客户端连接，直接退出
begin
AContext.Connection.Disconnect;
Exit;
end;
//2. 判断是否有ping 在执行
if TMyContext(AContext).ClientInfo.ping_Timeout <> 0 then
if Now > TMyContext(AContext).ClientInfo.ping_Timeout then
begin
//超时未收到ping的回复，挂断客户端
AContext.Connection.Disconnect;
Exit;
end;
//3. 握手成功，处理接收的消息
//循环接收消息
SetLength(FRB,0);
//while True do
begin
//准备接收客户端数据
if AContext.Connection.IOHandler.InputBufferIsEmpty then
begin
AContext.Connection.IOHandler.CheckForDataOnSource(0);
AContext.Connection.IOHandler.CheckForDisconnect;
if AContext.Connection.IOHandler.InputBufferIsEmpty then Exit;
end;
Len := AContext.Connection.IOHandler.InputBuffer.Size;
if Len <= 3 then Exit;;
SetLength(inBytes,0);
AContext.Connection.IOHandler.ReadBytes(TidBytes(inBytes),len ,False);
FIN := Get_FIN_and_opcode(inBytes,opcode);
if not FIN then
case opcode of
0 : //表示是一个连续的Frame
begin
outBytes := Get_ClientData(inBytes);
FRB := AppendBytes(FRB,outBytes);
//Continue;
end;
1 : //表示是一条文本消息
begin
Fopcode := opcode;
outBytes := Get_ClientData(inBytes);
FRB := AppendBytes(FRB,outBytes);
//Continue;
end;
2 : //表示是流消息
begin
Fopcode := opcode;
outBytes := Get_ClientData(inBytes);
FRB := AppendBytes(FRB,outBytes);
//Continue;
end;
3,4,5,6,7 : ; //保留
8 : //表示一个连接关闭
begin
AContext.Connection.Disconnect; //关闭连接，直接退出
Exit;
end;
9 : //一个ping
begin
end;
$A : //一个pong
begin
Fopcode := opcode;
outBytes := Get_ClientData(inBytes);
FRB := AppendBytes(FRB,outBytes);
end;
end
else //说明已经结束
begin
outBytes := Get_ClientData(inBytes);
if length(FRB) = 0 then
Fopcode := opcode;
FRB := AppendBytes(FRB,outBytes);
case Fopcode of
1 : //文本消息
begin
S := TEncoding.UTF8.GetString(FRB);
if Assigned(FOnMessage) then
FOnMessage(ClientID,S);
SetLength(FRB,0);
//更新接收消息计数
TMyContext(AContext).ClientInfo.R_Last_Text := S;
TMyContext(AContext).ClientInfo.R_Count := TMyContext(AContext).ClientInfo.R_Count + 1;
end;
2 : //流消息
begin
if Assigned(FOnBinary) then
FOnBinary(ClientID,FRB);
SetLength(FRB,0);
end;
9 : //一个ping
begin
end;
$A:
begin
S := TEncoding.UTF8.GetString(FRB);
if Assigned(FOnPong) then
FOnPong(ClientID,S);
SetLength(FRB,0);
//修改Ping的超时
TMyContext(AContext).ClientInfo.ping_Timeout := 0; //本次执成功
end;
end;
end;
end;
end;
procedure TWebSocket.IdTCPServer_Status(ASender: TObject;
const AStatus: TIdStatus; const AStatusText: string);
begin
end;
procedure TWebSocket.ping(ClientID, Application_data: string);
var
LContext: TIdContext;
LList: TIdContextList;
i : integer;
B : TBytes;
begin
if FIdTCPServer.Contexts = nil then Exit;
if Application_data = '' then Application_data := FormatDateTime('YYYY-MM-DD hh:mm:ss zzz',Now);
LList := FIdTCPServer.Contexts.LockList;
try
for i := 0 to LList.Count - 1 do
begin
LContext := {$IFDEF HAS_GENERICS_TList}LList.Items[i]{$ELSE}TIdContext(LList.Items[i]){$ENDIF};
if (TMyContext(LContext).ClientInfo.ID = ClientID) then
begin
B := TEncoding.UTF8.GetBytes(Application_data);
B := Build_WebSocketBytes(B,$09); //ping指令
LContext.Connection.IOHandler.Write(TidBytes(B));
//设置接收Pong的时间
TMyContext(LContext).ClientInfo.ping_Timeout := IncSecond(Now,FPingTimeout);
Exit;
end;
end;
finally
FIdTCPServer.Contexts.UnLockList;
end;
end;
procedure TWebSocket.Ping_OnTimer(Sender: TObject);
var
LContext: TIdContext;
LList: TIdContextList;
i : integer;
B : TBytes;
begin
if FIdTCPServer.Contexts = nil then Exit;
LList := FIdTCPServer.Contexts.LockList;
try
for i := 0 to LList.Count - 1 do
begin
//如果已经关闭了定时器，则立即退出
if not FPingTimer.Enabled then Exit;
LContext := {$IFDEF HAS_GENERICS_TList}LList.Items[i]{$ELSE}TIdContext(LList.Items[i]){$ENDIF};
B := TEncoding.UTF8.GetBytes('ping');
B := Build_WebSocketBytes(B,$09); //ping指令
LContext.Connection.IOHandler.Write(TidBytes(B));
//设置接收Pong的时间
TMyContext(LContext).ClientInfo.ping_Timeout := IncSecond(Now,FPingTimeout);
end;
finally
FIdTCPServer.Contexts.UnLockList;
end;
end;
function TWebSocket.Process_Handshake(Context: TIdContext;
var ErrorMsg: string): Boolean;
var
inBytes : TBytes;
inString : string;
inLen : integer;
tStart : TDateTime;
ClientID : string;
WebSocket_Key : string;
WebSocket_Version : string;
User_Agent : string;
Upgrade : string;
Connection : string;
sResponse : string;
outBytes : TBytes;
S : string;
begin
//如果握手成功，则返回True,否则返回握手失败 False
//1. 首先检查接收到的数据，数据长度必须至少50
ClientID := Context.Connection.Socket.Binding.PeerIP + ':' + Context.Connection.Socket.Binding.PeerPort.ToString;
tStart := Now; //当前时间
while true do
begin
//如果超时，则直接返回错误
if SecondsBetween(Now,tStart) > FHandShakeTimeout then
begin
Result := False;
ErrorMsg := '握手信号超时！';
if Assigned(FOnError) then
FOnError(ClientID,ErrorMsg);
Exit;
end;
if Context.Connection.IOHandler.InputBufferIsEmpty then
begin
Context.Connection.IOHandler.CheckForDataOnSource(0);
Context.Connection.IOHandler.CheckForDisconnect;
if Context.Connection.IOHandler.InputBufferIsEmpty then Exit;
end;
inLen := Context.Connection.IOHandler.InputBuffer.Size;
if inLen <= 50 then Continue;
SetLength(inBytes,0);
//读取到实际的数据
Context.Connection.IOHandler.ReadBytes(TidBytes(inBytes),inlen ,False);
try
inString := TEncoding.UTF8.GetString(inBytes);
//1.进行数据解析
Upgrade := TRegEx.Match(inString,'Upgrade: (.*)').Groups.Item[1].Value;
Connection := TRegEx.Match(inString,'Connection: (.*)').Groups.Item[1].Value;
WebSocket_Key := TRegEx.Match(inString,'Sec-WebSocket-Key: (.*)').Groups.Item[1].Value;
WebSocket_Version := TRegEx.Match(inString,'Sec-WebSocket-Version: (.*)').Groups.Item[1].Value;
User_Agent := TRegEx.Match(inString,'User-Agent: (.*)').Groups.Item[1].Value;
if (Upgrade <> 'websocket') or (Connection <> 'Upgrade') or (WebSocket_Key = '') then //说明不是WebSocket协议，退出
begin
Result := False;
ErrorMsg := '收到的握手数据流不正确(未包含 WebSocket_Key 字段)！';
if Assigned(FOnError) then
FOnError(ClientID,ErrorMsg);
Exit;
end;
//2.构造返回数据
sResponse := 'HTTP/1.1 101 Switching Protocols' + #13#10;
sResponse := sResponse + 'Connection: Upgrade' + #13#10;
sResponse := sResponse + 'Upgrade: websocket' + #13#10;
outBytes := THashSHA1.GetHashBytes(UTF8String( Trim(WebSocket_Key) + CWebSocket_KEY ));
S := TNetEncoding.Base64.EncodeBytesToString(outBytes);
sResponse := sResponse + 'Sec-WebSocket-Accept: ' + S +#13#10#13#10;
outBytes := TEncoding.UTF8.GetBytes(sResponse);
Context.Connection.IOHandler.Write(TidBytes(outBytes),Length(outBytes));
//客户端信息
TMyContext(Context).ClientInfo.User_Agent := User_Agent;
if Assigned(FOnHandhake) then
FOnHandhake(ClientID,WebSocket_Key,WebSocket_Version,User_Agent);
//写入握手成功时间
Result := True;
Break;
except on E: Exception do
begin
Result := False;
ErrorMsg := '收到的握手数据流不正确(不是UTF8字符串)！';
if Assigned(FOnError) then
FOnError(ClientID,ErrorMsg);
Exit;
end;
end;
end;
end;
procedure TWebSocket.SetHeartBeat(Value: Boolean);
begin
FHeartBeat := Value;
//需要启动 心跳检测
if not (csDesigning in ComponentState) then
if FIdTCPServer.Active then
FPingTimer.Enabled := FHeartBeat;
end;
procedure TWebSocket.SetInterval(Value: Word);
begin
if Value < 20 then Value := 20;
FInterval := Value;
//刷新定时器的时间间隔
if not (csDesigning in ComponentState) then
FPingTimer.Interval:= FInterval * 1000; //定时器的时间间隔
end;
procedure TWebSocket.SetMaxConnections(Value: integer);
begin
if Value < 0 then Value := 0;
FMaxConnections := Value;
if not (csDesigning in ComponentState) then
FIdTCPServer.MaxConnections := FMaxConnections;
end;
procedure TWebSocket.SetPingTimeout(Value: integer);
begin
if Value <= 0 then Value := 10;
FPingTimeout := Value;
end;
procedure TWebSocket.SetReadTimeOut(Value: Word);
begin
FReadTimeOut := Value;
end;
procedure TWebSocket.SetHandShakeTimeout(Value: integer);
begin
if Value < 0 then Value := 20;
FHandShakeTimeout := Value;
end;
procedure TWebSocket.SetVersion(Value: string);
begin
FVersion := Value;
end;
procedure TWebSocket.SetWebPort(Value: Word);
begin
FWebPort := Value;
end;
procedure TWebSocket.Start_WebSocketServer;
begin
if FActive then Exit;
FIdTCPServer.DefaultPort := FWebPort; //设置打开端口
try
FIdTCPServer.Active := True;
FActive := FIdTCPServer.Active;
//是否启动ping定时器
FPingTimer.Enabled := FHeartBeat;
//启动成功事件
if Assigned(FOnStartup) then
FOnStartup(Self);
except on E: Exception do
begin
FActive := False;
raise Exception.Create('Err001'#13#10 + E.Message);
end;
end;
end;
procedure TWebSocket.Stop_WebSocketServer;
begin
if not FActive then Exit;
FPingTimer.Enabled := False;
sleep(200);
DisconnectAll;
Sleep(200);
FPingTimer.Enabled := False;
FIdTCPServer.Active := False;
FActive := FIdTCPServer.Active;
if Assigned(FOnShutdown) then FOnShutdown(Self);
end;
function TWebSocket.WriteBytes(const ClientID: string; Bytes_Message: TBytes;
var ErrorMsg: string): Boolean;
var
LContext: TIdContext;
LList: TIdContextList;
i : integer;
B : TBytes;
begin
ErrorMsg := '当前没有连接的客户端！';
if FIdTCPServer.Contexts = nil then Exit(False);
LList := FIdTCPServer.Contexts.LockList;
try
for i := 0 to LList.Count - 1 do
begin
LContext := {$IFDEF HAS_GENERICS_TList}LList.Items[i]{$ELSE}TIdContext(LList.Items[i]){$ENDIF};
if (TMyContext(LContext).ClientInfo.ID = ClientID) then
begin
//判断是否握手成功
if TMyContext(LContext).ClientInfo.HandshakeTime = 0 then
begin
ErrorMsg := '当前连接尚未进行握手！';
Exit(False);
end;
B := Build_WebSocketBytes(Bytes_Message,2); //发送的是字节流
LContext.Connection.IOHandler.Write(TidBytes(B));
//更新发送计数
TMyContext(LContext).ClientInfo.S_Last_Text := Bytes_To_HexStr(Bytes_Message);
TMyContext(LContext).ClientInfo.S_Count := TMyContext(LContext).ClientInfo.S_Count + 1;
Exit(True);
end;
end;
ErrorMsg := '未查询到客户端: ' + ClientID;
Exit(False);
finally
FIdTCPServer.Contexts.UnLockList;
end;
end;
function TWebSocket.WriteTexts(const ClientID: string; Text_Message: string;
var ErrorMsg: string): Boolean;
var
LContext: TIdContext;
LList: TIdContextList;
i : integer;
B : TBytes;
begin
ErrorMsg := '当前没有连接的客户端！';
if FIdTCPServer.Contexts = nil then Exit(False);
LList := FIdTCPServer.Contexts.LockList;
try
for i := 0 to LList.Count - 1 do
begin
LContext := {$IFDEF HAS_GENERICS_TList}LList.Items[i]{$ELSE}TIdContext(LList.Items[i]){$ENDIF};
if (TMyContext(LContext).ClientInfo.ID = ClientID) then
begin
//判断是否握手成功
if TMyContext(LContext).ClientInfo.HandshakeTime = 0 then
begin
ErrorMsg := '当前连接尚未进行握手！';
Exit(False);
end;
B := TEncoding.UTF8.GetBytes(Text_Message);
B := Build_WebSocketBytes(B);
LContext.Connection.IOHandler.Write(TidBytes(B));
//更新发送计数
TMyContext(LContext).ClientInfo.S_Last_Text := Text_Message;
TMyContext(LContext).ClientInfo.S_Count := TMyContext(LContext).ClientInfo.S_Count + 1;
Exit(True);
end;
end;
ErrorMsg := '未查询到客户端: ' + ClientID;
Exit(False);
finally
FIdTCPServer.Contexts.UnLockList;
end;
end;
end.
488
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
