mormot2的weboscket示例

一份cross-socket到mormot2的websocket适配器，演示mormot2的websocket如何使用，如果不需要spring4d的话可以删除相关引用。

点击查看代码

{ ****************************************************************************** }
{                                mORMot2 Adapter Layer                           }
{ ****************************************************************************** }
unit Mormot.Adapter;

interface

uses
  mormot.lib.openssl11,
  mormot.crypt.openssl,
  System.SysUtils,
  mormot.net.sock,
  System.Classes,
  Spring.Container,
  // mORMot 2 units
  mormot.net.client,
  mORMot.Core.Base,
  mormot.rest.http.client,
  mORMot.Net.Http,
  mORMot.net.ws.core,
  mORMot.Net.Ws.Client,
  mORMot.Core.Log,
  mormot.net.ws.async,

  // Project units
  Mormot.LogBridge.Adapter,
  GameWebSocketUnit.inf;

type
{ TWebSocketProtocolGameSocket }
  TWebSocketProtocolGameSocket = class(TWebSocketProtocol)
  protected
    FCallBack:TOnWebSocketProtocolChatIncomingFrame;
    //mormot2要求覆盖TWebSocketProtocol.ProcessIncomingFrame
    //直接使用THttpClientWebSockets的OnIncomingFrame属于未定义行为
    procedure ProcessIncomingFrame(Sender: TWebSocketProcess;
      var Request: TWebSocketFrame; const Info: RawUtf8);override;
  public
    constructor Create(const aName, aUri: RawUtf8;ACallBack:TOnWebSocketProtocolChatIncomingFrame);
  end;

  /// <summary>
  /// 基于 mORMot2 THttpClientWebSockets 的引擎实现
  /// </summary>
  TMormotWsEngine = class(TInterfacedObject, IWebSocketEngine)
  strict private
    FClient: THttpClientWebSockets;
    FOnMessage: TOnWsMessage;
    FOnStatusChange: TOnWsStatusChange;
    FLastStatus: TWsEngineStatus;

    /// <summary>
    /// 内部状态更新并同步业务层状态
    /// </summary>
    procedure UpdateStatus(const AStatus: TWsEngineStatus);

    /// <summary>
    /// 处理 mORMot 2 的回调请求 (Push Notification)
    /// </summary>
    procedure DoOnIncomingFrame(Sender: TWebSocketProcess; const Frame: TWebSocketFrame);
    procedure OnWebSocketsClosed(Sender: TObject);
  public
    constructor Create;
    destructor Destroy; override;

    /// <summary>
    /// 建立连接
    /// </summary>
    /// <remarks>
    /// 逻辑变更：mORMot2 的 WebSocketsUpgrade 是同步过程，返回空字符串表示成功。
    /// </remarks>
    function Connect(const AUrl: string): Boolean;

    procedure Close;

    function GetStatus: TWsEngineStatus;

    procedure SendBinary(const AData: TBytes; const ACallback: TNetSendCallback = nil);

    procedure SetOnMessage(const ACallback: TOnWsMessage);
    procedure SetOnStatusChange(const ACallback: TOnWsStatusChange);
  end;

implementation

{ TMormotWsEngine }

constructor TMormotWsEngine.Create;
begin
  //启动websocket日志
  WebSocketLog := TSynLog;
  inherited Create;
  FClient := nil;
  TMormotLogBridge.InitializeBridge;
  FLastStatus := wsDisconnected;
end;

destructor TMormotWsEngine.Destroy;
begin
  Close;
  FClient := nil;
  inherited Destroy;
end;

procedure TMormotWsEngine.UpdateStatus(const AStatus: TWsEngineStatus);
begin
  if FLastStatus <> AStatus then
  begin
    FLastStatus := AStatus;
    if Assigned(FOnStatusChange) then
      FOnStatusChange(AStatus);
  end;
end;

procedure TMormotWsEngine.SetOnMessage(const ACallback: TOnWsMessage);
begin
  FOnMessage := ACallback;
end;

procedure TMormotWsEngine.SetOnStatusChange(const ACallback: TOnWsStatusChange);
begin
  FOnStatusChange := ACallback;
end;

function TMormotWsEngine.GetStatus: TWsEngineStatus;
begin
  if not Assigned(FClient) or not Assigned(FClient.WebSockets) then
    Exit(wsDisconnected);

  // 根据 mORMot 内部 Process 状态映射

  if FClient.SockConnected then
    Result := wsConnected
  else
    Result := wsDisconnected;
end;

procedure TMormotWsEngine.OnWebSocketsClosed(Sender: TObject);
begin
  UpdateStatus(wsDisconnected);
end;

procedure TMormotWsEngine.Close;
begin
  if Assigned(FClient) then
  begin
    // THttpClientWebSockets 会在 Destroy 时自动处理关闭
    // 但显式清理是一个好习惯
    FClient.Free;
    FClient := nil;
    UpdateStatus(wsDisconnected);
  end;
end;

function TMormotWsEngine.Connect(const AUrl: string): Boolean;
var
  LCustomHeaders: RawUtf8;
  LNewClient: THttpClientWebSockets;
  LProtocol: TWebSocketProtocolGameSocket;
  LRES: RawUtf8;
  TLS: TNetTlsContext;
  LUri: TUri;
begin

  Result := False;
  try
    if Assigned(FClient) then Close;

    UpdateStatus(wsConnecting);
    LCustomHeaders := 'Origin: https://1.0.0.1'#$D#$A +
                      'Mozilla/5.0 (Windows NT 10.0; Win64; x64) ' +
                      'AppleWebKit/537.36 (KHTML, like Gecko) ' +
                      'Chrome/132.0.0.0 Safari/537.36 ' +
                      'MicroMessenger/7.0.20.1781(0x6700143B) ' +
                      'NetType/WIFI MiniProgramEnv/Windows WindowsWechat/WMPF WindowsWechat(0x63090a13) UnifiedPCWindowsWechat(0xf254101e) XWEB/16203;'#$D#$A;

    LUri.From(RawUtf8(AUrl));

    InitNetTlsContext(TLS);
    TLS.IgnoreCertificateErrors := True;
    //注意：LProtocol会在WebSocketsUpgrade释放，无需手工释放！
    LProtocol := TWebSocketProtocolGameSocket.Create('','',DoOnIncomingFrame);
    LProtocol.SetSubprotocol('');
    //打开链接
    LNewClient := THttpClientWebSockets.Open(LUri.Server, LUri.Port, nlTcp, 10000, LUri.Https, @TLS);
    LNewClient.Settings.SetFullLog;
    LRES := LNewClient.WebSocketsUpgrade(LUri.Address,'',False,[],LProtocol,LCustomHeaders);
    //关闭默认的心跳
    LNewClient.WebSockets.Settings^.HeartbeatDelay := 0;
    // 返回空则表示成功，否则返回错误信息
    if LRES = '' then
    begin
      //连接成功以后设置关闭回调
      LNewClient.OnWebSocketsClosed := OnWebSocketsClosed;

      FClient := LNewClient;
      //此处无需设置，因为在DoOnIncomingFrame立即收到对应指令并设置状态
      Result := True;
    end
    else
    begin
      // 返回 空 意味着底层的 TCP Open 或协议 Upgrade 失败
      UpdateStatus(wsDisconnected);
      Result := False;
    end;
  except
    //报错的话直接设置未连接
    UpdateStatus(wsDisconnected);
    Result := False;
  end;
end;

procedure TMormotWsEngine.DoOnIncomingFrame(Sender: TWebSocketProcess; const Frame: TWebSocketFrame);
var
  LBytes: TBytes;
  LLen: Integer;
begin
  // 我们这里需要根据类型进行处理
  case Frame.opcode of
  focBinary:
  BEGIN
    LLen := Length(Frame.payload);
    if Assigned(FOnMessage) and (LLen > 0) then
    begin
      SetLength(LBytes, LLen);
      // 将 mORMot 底层的 RawByteString/RawUtf8 内存安全拷贝到 TBytes 中
      Move(Pointer(Frame.payload)^, LBytes[0], LLen);
      // 触发业务层的回调
      FOnMessage(LBytes);
    end;
  END;
  focText:
  begin
    //我的服务器没有文本返回
  end;
  focConnectionClose:
  begin
    UpdateStatus(wsDisconnected);
  end;
  focContinuation:
  begin
    UpdateStatus(wsConnected);
  end;
  focPing:
  begin
    //我们的服务器没有
  end;
  focPong:
  begin
    //我们的服务器没有
  end;
  end;

end;

procedure TMormotWsEngine.SendBinary(const AData: TBytes; const ACallback: TNetSendCallback);
var
  LSuccess:Boolean;
  LWebSocketFrame:TWebSocketFrame;
  _TempRaw: RawByteString;
begin
  if not Assigned(FClient) or not Assigned(FClient.WebSockets) then
  begin
    if Assigned(ACallback) then ACallback(False);
    Exit;
  end;

  try
    //复制TBytes到mormot2定义的万能类型（其实就是Pansichar）
    SetString(_TempRaw, PAnsiChar(@AData[0]), Length(AData));
    //清零websocket数据包头
    FillCharFast(LWebSocketFrame, SizeOf(LWebSocketFrame), 0);
    //设置websocket数据包的头
    LWebSocketFrame.opcode := focBinary;
    //设置websocket数据包数据
    LWebSocketFrame.payload := _TempRaw;
    //这里mormot2要求使用SendFrame，使用SendBytes会直接触发close
    LSuccess := FClient.WebSockets.SendFrame(LWebSocketFrame);

    if Assigned(ACallback) then
      ACallback(LSuccess);
  except
    if Assigned(ACallback) then ACallback(False);
  end;
end;

{ TWebSocketProtocolGameSocket }

constructor TWebSocketProtocolGameSocket.Create(const aName, aUri: RawUtf8;ACallBack:TOnWebSocketProtocolChatIncomingFrame);
begin
  inherited Create(aName,aUri);

  FCallBack := ACallBack;
end;

procedure TWebSocketProtocolGameSocket.ProcessIncomingFrame(
  Sender: TWebSocketProcess; var Request: TWebSocketFrame; const Info: RawUtf8);
begin
  if Assigned(FCallBack) then
    FCallBack(Sender,Request);
end;

initialization

end.

下面是常量定义

点击查看代码

  TWsEngineStatus = (wsUnknown, wsConnecting, wsConnected, wsDisconnected,wsShutdown);
  TPacketStatus = (pa_Queueing, pa_Sending);

  TRequestCallBack = reference to procedure(const ASuccess: Boolean; const AJson: string);
  TLogined = reference to procedure(const ASuccess: Boolean);
  TGameWebSocketOnRecv = procedure(const AOnBin: string) of object;
  TOnFatalEvent = procedure(ASender: TObject; const AJson: string) of object;

  TNetSendCallback = reference to procedure(const ASuccess: Boolean);
  TOnWsMessage = reference to procedure(const AData: TBytes);
  TOnWsStatusChange = reference to procedure(const AStatus: TWsEngineStatus);

下面是适配mormot2的日志模块，自行修改

点击查看代码

unit Mormot.LogBridge.Adapter;

interface

uses
  mORMot.Core.Base,
  mormot.core.text,
  Rat.Utils.UtilsInterface,
  mORMot.Core.Log;

type
  /// <summary>
  /// mORMot 日志到业务日志模块的桥接器
  /// </summary>
  TMormotLogBridge = class
  public
    /// <summary>
    /// 初始化桥接，将 TSynLog 的输出重定向到你现有的日志系统
    /// </summary>
    class procedure InitializeBridge;

    /// <summary>
    /// mORMot 日志触发时的回调函数
    /// </summary>
    class function OnMormotLog(Sender: TEchoWriter; Level: TSynLogLevel;
    const Text: RawUtf8): boolean;
  end;

implementation

{ TMormotLogBridge }

class procedure TMormotLogBridge.InitializeBridge;
var
  LFamily: TSynLogFamily;
begin

  LFamily := TSynLog.Family;

  // 开启你关心的日志级别（比如网络请求、异常、自定义追踪等）
  LFamily.Level := [sllInfo,sllWarning,sllError, sllException];

  // 禁用 mORMot 默认的文件写入，避免双重 I/O 开销
  LFamily.NoFile := True;

  // 注册自定义拦截回调。每当 mORMot 内部有日志产生，都会触发此方法
  LFamily.EchoCustom := OnMormotLog;
end;

class function TMormotLogBridge.OnMormotLog(Sender: TEchoWriter;
  Level: TSynLogLevel; const Text: RawUtf8): boolean;
var
  LMsg: string;
begin
  // 将 mORMot 的底层 UTF8 日志转换为 Delphi 标准 string
  LMsg := UTF8ToString(Text);
  case Level of
  sllInfo:GlobalLog.Info(LMsg);
  sllError:GlobalLog.Error(LMsg);
  sllException:GlobalLog.Warn(LMsg);
  sllTrace:GlobalLog.Trace(LMsg);
 // sllDebug:GlobalLog.Debug(LMsg);
  end;
end;

initialization
  // 配置 mORMot2 全局日志族 (Log Family) 策略
  with TSynLog.Family do
  begin
    // 设置需要拦截的日志级别：包括基本信息、警告、错误、异常以及我们在高频方法中使用的 Trace
    Level := [sllInfo, sllWarning, sllError, sllException];

    // 设置日志文件按天轮转保存，存放于可执行文件同级的 \Logs 目录下
    DestinationPath := 'Logs\';
    PerThreadLog := ptIdentifiedInOnFile;
    HighResolutionTimestamp := True;

    // 如果你在控制台程序中调试，可取消注释下面这行直接在黑窗口输出
    EchoToConsole := Level;
  end;

end.