mormot websocket

mormot websocket

THttpApiWebSocketServer基于http.sys通讯的websocket server，同时它又能作为普通的http server使用，支持高并发。

下面是它的演示代码：

?
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
program Project31WinHTTPEchoServer;
 
{$I Synopse.inc}
 
{$APPTYPE CONSOLE}
 
uses
  {$I SynDprUses.inc} // use FastMM4 on older Delphi, or set FPC threads
  SysUtils,
  SynZip,
  SynCrtSock,
  SynCommons,
  SynTable;
 
type
  TSimpleWebsocketServer = class
  private
    fServer: THttpApiWebSocketServer;
//    fProtocols: THttpApiWebSocketServerProtocolDynArray;
    function onHttpRequest(Ctxt: THttpServerRequest): cardinal;
    function onAccept(Ctxt: THttpServerRequest; var Conn: THttpApiWebSocketConnection): Boolean;
    procedure onConnect(const Conn: THttpApiWebSocketConnection );
    procedure onMessage(const Conn: THttpApiWebSocketConnection; aBufferType: WEB_SOCKET_BUFFER_TYPE; aBuffer: Pointer; aBufferSize: Cardinal);
    procedure onDisconnect(const Conn: THttpApiWebSocketConnection ; aStatus: WEB_SOCKET_CLOSE_STATUS; aBuffer: Pointer; aBufferSize: Cardinal);
  public
    constructor Create;
    destructor Destroy; override;
  end;
{ TSimpleWebsocketServer }
 
constructor TSimpleWebsocketServer.Create;
begin
  fServer := THttpApiWebSocketServer.Create(false, 8, 10000);
  fServer.AddUrl('','8888', False, 'localhost');
  fServer.AddUrlWebSocket('whatever', '8888', False, 'localhost');
  // ManualFragmentManagement = false - so Server will join all packet fragments
  // automatically and call onMessage with full message content
  fServer.RegisterProtocol('meow', False, onAccept, onMessage, onConnect, onDisconnect);
  fServer.RegisterCompress(CompressDeflate);
  fServer.OnRequest := onHttpRequest;
  fServer.Clone(8);
end;
 
destructor TSimpleWebsocketServer.Destroy;
begin
  fServer.Free;
  inherited;
end;
 
function TSimpleWebsocketServer.onAccept(Ctxt: THttpServerRequest; var Conn: THttpApiWebSocketConnection): Boolean;
begin
// You can check some Ctxt parameters here
  Result := true;
end;
 
procedure TSimpleWebsocketServer.onConnect(const Conn: THttpApiWebSocketConnection);
begin
  Writeln('New connection. Assigned connectionID=', Conn.index);
end;
 
procedure TSimpleWebsocketServer.onDisconnect(const Conn: THttpApiWebSocketConnection;
  aStatus: WEB_SOCKET_CLOSE_STATUS; aBuffer: Pointer; aBufferSize: Cardinal);
var
  str: RawUTF8;
begin
  SetString(str, pUtf8Char(aBuffer), aBufferSize);
 
  Writeln('Disconnected ', Conn.index,' ',aStatus,' ',str);
end;
 
function TSimpleWebsocketServer.onHttpRequest(Ctxt: THttpServerRequest): cardinal;
begin
  Writeln('HTTP request to ', Ctxt.URL);
  if Ctxt.URL = '/' then
    Ctxt.OutContent := 'Project31SimpleEchoServer.html'
  else if Ctxt.URL = '/favicon.ico' then
     Ctxt.OutContent := 'favicon.ico';
  Ctxt.OutContentType := HTTP_RESP_STATICFILE;
  Result := 200;
end;
 
procedure TSimpleWebsocketServer.onMessage(const Conn: THttpApiWebSocketConnection;
  aBufferType: WEB_SOCKET_BUFFER_TYPE; aBuffer: Pointer; aBufferSize: Cardinal);
var
  str: RawUTF8;
begin
  Conn.Send(aBufferType, aBuffer, aBufferSize);
//  Conn.Protocol.Send(Conn.index, aBufferType, aBuffer, aBufferSize); //also work
  SetString(str, pUtf8Char(aBuffer), aBufferSize);
  if aBufferType = WEB_SOCKET_UTF8_MESSAGE_BUFFER_TYPE then
    Writeln('UTF8 message from ', Conn.index, ': ',str)
  else if aBufferType = WEB_SOCKET_UTF8_FRAGMENT_BUFFER_TYPE then
    Writeln('UTF8 fragment from ', Conn.index, ': ',str)
  else if (aBufferType = WEB_SOCKET_BINARY_MESSAGE_BUFFER_TYPE)
    or (aBufferType = WEB_SOCKET_BINARY_FRAGMENT_BUFFER_TYPE) then
    Writeln(aBufferType, ' from ', Conn.index, ' of length ', aBufferSize)
  else begin
    Writeln(aBufferType, ' from ', Conn.index, ': ',str);
  end;
end;
 
var
  _Server: TSimpleWebsocketServer;
  s: string;
  idx: integer;
  MsgBuffer: RawUTF8;
  CloseReasonBuffer: RawUTF8;
begin
  MsgBuffer := '';
  CloseReasonBuffer := 'Connection closed by server';
  try
    _Server := TSimpleWebsocketServer.Create;
    try
      Writeln('WebSocket server is now listen on ws://localhost:8888/whatever');
      Writeln('HTTP server is now listen on http://localhost:8888/');
      Writeln(' Point your browser to http://localhost:8888/ for initial page');
      WriteLn('Type one of a commnad:');
      Writeln(' - "close connectionID" to close existing webSocket connection');
      Writeln(' - "sendto connectionID" to send text to specified WebCocket');
      Writeln(' - "sendall" to send text to specified WebCocket');
      Writeln(' - press [Enter] to quit');
      Writeln('Waiting for command:');
      repeat
        Readln(s);
        if Pos('close ', s) = 1 then begin
          s := SysUtils.Trim(Copy(s, 7, Length(s)));
          _Server.fServer.Protocols[0].Close(StrToIntDef(s, -1), WEB_SOCKET_SUCCESS_CLOSE_STATUS,
            Pointer(CloseReasonBuffer), length(CloseReasonBuffer));
        end else if Pos('sendto ', s) = 1 then begin
          s := SysUtils.Trim(Copy(s, 8, Length(s)));
          idx := StrToIntDef(s, -1);
          if (idx = -1 ) then
            Writeln('Invalid connection ID. Usage: send connectionID (Example: send 0)')
          else begin
            Write('Type text to send: ');
            Readln(MsgBuffer);
            if _Server.fServer.Protocols[0].Send(
              StrToIntDef(s, -1), WEB_SOCKET_UTF8_MESSAGE_BUFFER_TYPE,
              Pointer(MsgBuffer), length(MsgBuffer)
            ) then
              WriteLn('Sent successfully. The message should appear in the client. Waiting for command:')
            else
              WriteLn('Error')
          end;
        end else if (s = 'sendall') then begin
          Write('Type text to send: ');
          Readln(MsgBuffer);
          if _Server.fServer.Protocols[0].Broadcast(
            WEB_SOCKET_UTF8_MESSAGE_BUFFER_TYPE,
            Pointer(MsgBuffer), length(MsgBuffer)
          ) then
            WriteLn('Broadcast successfully. All clients should got a message. Waiting for command:')
          else
            WriteLn('Error')
        end else if (s <> '') then
          WriteLn('Invalid comand; Valid command are: close, sendto, sendall');
      until s = '';
    finally
      _Server.Free;
    end;
  except
    on E: Exception do
      Writeln(E.ClassName, ': ', E.Message);
  end;
end.

　　

posted @   delphi中间件  阅读(1788)  评论(0)  编辑  收藏  举报
编辑推荐：
· .NET Core 中如何实现缓存的预热？
· 从 HTTP 原因短语缺失研究 HTTP/2 和 HTTP/3 的设计差异
· AI与.NET技术实操系列：向量存储与相似性搜索在 .NET 中的实现
· 基于Microsoft.Extensions.AI核心库实现RAG应用
· Linux系列：如何用heaptrack跟踪.NET程序的非托管内存泄露
阅读排行：
· TypeScript + Deepseek 打造卜卦网站：技术与玄学的结合
· Manus的开源复刻OpenManus初探
· AI 智能体引爆开源社区「GitHub 热点速览」
· 三行代码完成国际化适配，妙~啊~
· .NET Core 中如何实现缓存的预热？
历史上的今天：
2017-03-30 Ubuntu上安装MySQL
2017-03-30 vcl.Forms等与VCL界面有关的单元不支持跨平台
2017-03-30 vcl.Forms等与VCL界面有关的单元不支持跨平台
2017-03-30 DELPHI10.2的LINUX数据库开发环境配置
点击右上角即可分享
微信分享提示
SQL AI 助手