ewsdr/WsClient.pas

{
  Copyright (C)
  2026 - Uladzimir Karpenka, EW8BAK

  This program is free software; you can redistribute it and/or
  modify it under the terms of the GNU General Public License
  as published by the Free Software Foundation; either version 2
  of the License, or (at your option) any later version.

  This program is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with this program; if not, write to the Free Software
  Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
}

unit WsClient;

{
  WsClient.pas — WebSocket клиент (одно соединение).

  Инкапсулирует:
    - TCP-сокет
    - Состояние WS (handshake / open / closed)
    - Буфер приёма
    - Отправку raw-байт, WS-фреймов (text / binary)
    - Basic-Auth флаг
}

{$IFDEF FPC}
  {$MODE Delphi}
  {$LONGSTRINGS ON}
{$ENDIF}

interface

uses
  SyncObjs, WebUtils
  {$IFDEF WINDOWS}, WinSock2{$ELSE}, Sockets{$ENDIF};

const
  { Приёмный буфер соединения. 4 КБ хватало командам и web-запросам, но блок
    бинарного потока TCI (§3.4) — это заголовок 64 байта плюс data[16384],
    и кадр крупнее буфера не собирается НИКОГДА: BufLen упирается в потолок и
    разбор встаёт. Поэтому потолок держим с запасом на кадр целиком вместе с
    маской и хвостом соседнего сообщения. }
  WS_BUF_SIZE = 32768;

type
  TWsState = (wsHandshake, wsOpen, wsClosed);

  TWsClient = class
  private
    FSocket:  TSocket;
    FState:   TWsState;
    FLock:    TCriticalSection;
    FBuf:     array[0..WS_BUF_SIZE-1] of Byte;
    FBufLen:  Integer;
    FAuthed:  Boolean;
  public
    constructor Create(ASocket: TSocket);
    destructor  Destroy; override;

    { Отправка raw-байт (вызывать держа FLock) }
    function SendRaw(const Data; Len: Integer): Boolean;

    { Отправка WebSocket-фрейма (text или binary) }
    function SendWsFrame(Opcode: Byte; const Data; Len: Integer): Boolean;

    { Текстовый WS-фрейм (opcode $01) }
    function SendText(const S: string): Boolean;

    { Бинарный WS-фрейм (opcode $02) }
    function SendBinary(const Data; Len: Integer): Boolean;

    { Читает данные в FBuf, возвращает кол-во байт (-1 = ошибка/закрыто) }
    function Recv: Integer;

    { Указатель на начало буфера приёма }
    function BufData: PByte; inline;

    { Ёмкость приёмного буфера: разбору фреймов нужен потолок, чтобы вовремя
      закрыть соединение, а не встать намертво на несобираемом кадре. }
    function BufCapacity: Integer; inline;

    property Socket: TSocket read FSocket;
    property State:  TWsState read FState write FState;
    property Authed: Boolean  read FAuthed write FAuthed;
    property Lock:   TCriticalSection read FLock;
    property BufLen: Integer  read FBufLen write FBufLen;
  end;

implementation

{ ═══════════════════════════════════════════════════════════════════════════
  TWsClient
  ═══════════════════════════════════════════════════════════════════════════ }

constructor TWsClient.Create(ASocket: TSocket);
begin
  inherited Create;
  FSocket  := ASocket;
  FState   := wsHandshake;
  FBufLen  := 0;
  FAuthed  := False;
  FLock    := TCriticalSection.Create;
end;

destructor TWsClient.Destroy;
begin
  if FSocket <> SOCK_INVALID then
    SockClose(FSocket);
  FLock.Free;
  inherited;
end;

function TWsClient.SendRaw(const Data; Len: Integer): Boolean;
var
  Sent, R: Integer;
  P: PByte;
begin
  Result := False;
  if (FSocket = SOCK_INVALID) or (Len <= 0) then Exit;
  P    := @Data;
  Sent := 0;
  while Sent < Len do
  begin
    R := SockSend(FSocket, P + Sent, Len - Sent, 0);
    if R <= 0 then Exit;
    Inc(Sent, R);
  end;
  Result := True;
end;

function TWsClient.SendWsFrame(Opcode: Byte; const Data; Len: Integer): Boolean;
var
  Header: array[0..9] of Byte;
  HLen:   Integer;
  P:      PByte;
begin
  Result := False;
  if FState <> wsOpen then Exit;

  // FIN=1 + opcode
  Header[0] := $80 or (Opcode and $0F);

  if Len <= 125 then
  begin
    Header[1] := Byte(Len);
    HLen := 2;
  end
  else if Len <= 65535 then
  begin
    Header[1] := 126;
    Header[2] := Byte(Len shr 8);
    Header[3] := Byte(Len);
    HLen := 4;
  end
  else
  begin
    Header[1] := 127;
    Header[2] := 0; Header[3] := 0; Header[4] := 0; Header[5] := 0;
    Header[6] := Byte(Len shr 24); Header[7] := Byte(Len shr 16);
    Header[8] := Byte(Len shr  8); Header[9] := Byte(Len);
    HLen := 10;
  end;

  FLock.Enter;
  try
    Result := SendRaw(Header[0], HLen);
    if Result and (Len > 0) then
    begin
      P      := @Data;
      Result := SendRaw(P^, Len);
    end;
    // Ошибка отправки (таймаут SO_SNDTIMEO, разрыв) — немедленно закрываем
    // клиент чтобы BroadcastBinary не держал FClientLock на следующих тиках.
    if not Result then FState := wsClosed;
  finally
    FLock.Leave;
  end;
end;

function TWsClient.SendText(const S: string): Boolean;
begin
  if Length(S) = 0 then begin Result := True; Exit; end;
  Result := SendWsFrame($01, S[1], Length(S));
end;

function TWsClient.SendBinary(const Data; Len: Integer): Boolean;
begin
  Result := SendWsFrame($02, Data, Len);
end;

function TWsClient.Recv: Integer;
begin
  Result := SockRecv(FSocket, @FBuf[FBufLen], SizeOf(FBuf) - FBufLen, 0);
  if Result > 0 then Inc(FBufLen, Result);
end;

function TWsClient.BufData: PByte;
begin
  Result := @FBuf[0];
end;

function TWsClient.BufCapacity: Integer;
begin
  Result := SizeOf(FBuf);
end;

end.