ewsdr/WebUtils.pas

unit WebUtils;

{
  WebUtils.pas — Вспомогательные функции для WebServer:
    - Кросс-платформенные обёртки сокетов (Windows/Linux)
    - SHA-1 (минимальная реализация для WebSocket handshake)
    - Base64 (кодирование)
    - JSON helpers (JsonGetStr, JsonGetFloat, JsonGetInt, JsonGetBool)

  ИСПРАВЛЕНИЯ:
    - (Windows build fix) Порядок uses: стандартные RTL-юниты первыми,
      платформенные (WinSock2) последними — исключает конфликт
      идентификатора Create в режиме {$MODE Delphi} под Windows.
    - (Linux shutdown fix) Добавлена SockShutdown — вызов shutdown(SHUT_RDWR)
      перед close, что немедленно прерывает заблокированные fpAccept/fpRecv
      в других потоках и предотвращает зависание при закрытии программы.
}

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

interface

uses
  SysUtils, Math
  {$IFDEF WINDOWS}, Windows, WinSock2{$ELSE}, BaseUnix, Sockets{$ENDIF};

{ ── Кросс-платформенные константы сокетов ─────────────────────────────────── }

{$IFDEF WINDOWS}
const
  SOCK_INVALID = INVALID_SOCKET;
  SOCK_ERR     = SOCKET_ERROR;
{$ELSE}
const
  SOCK_INVALID    = TSocket(-1);
  SOCK_ERR        = -1;
  INVALID_SOCKET  = TSocket(-1);
{$ENDIF}

{ ── Обёртки системных вызовов сокетов ─────────────────────────────────────── }

function  SockClose(S: TSocket): Integer; inline;

{ SockShutdown — прерывает все блокирующие recv/accept на сокете в других
  потоках. На Linux необходимо вызывать ДО SockClose, иначе потоки не
  разблокируются и программа зависнет при завершении.
  На Windows работает через SD_BOTH. }
procedure SockShutdown(S: TSocket);

function  SockRecv(S: TSocket; Buf: Pointer; Len, Flags: Integer): Integer; inline;
function  SockSend(S: TSocket; Buf: Pointer; Len, Flags: Integer): Integer; inline;
procedure SockSetNonBlock(S: TSocket; NB: Boolean);

{ SockSetSndTimeout — ограничивает время блокирующего SockSend.
  Без таймаута SockSend может зависнуть на минуты (TCP retransmit timeout)
  если буфер клиента переполнен, держа при этом FClientLock и блокируя Stop(). }
procedure SockSetSndTimeout(S: TSocket; Ms: Integer);

{ SockSetRcvTimeout — ограничивает время блокирующего SockRecv. Нужен клиентам,
  которым между пакетами надо просыпаться самим (проверить Terminated, отдать
  накопившиеся команды): recv возвращает -1 по таймауту, соединение живо. }
procedure SockSetRcvTimeout(S: TSocket; Ms: Integer);

{ SockRecvTimedOut — последняя ошибка SockRecv означает «данных пока нет»
  (истёк SO_RCVTIMEO или сигнал), а не разрыв. Без этой проверки поток,
  просыпающийся по таймауту, не отличит тишину от закрытого сокета. }
function SockRecvTimedOut: Boolean;

{ ── SHA-1 ─────────────────────────────────────────────────────────────────── }

type
  TSHA1Digest = array[0..19] of Byte;
  TSHA1State  = array[0..4] of LongWord;

procedure SHA1Transform(var S: TSHA1State; const Block: array of Byte);
function  SHA1(const Data: string): TSHA1Digest;

{ ── Base64 ───────────────────────────────────────────────────────────────── }

function Base64EncodeBytes(const Data: array of Byte; Len: Integer): string;
function Base64EncodeStr(const S: string): string;

{ ── JSON helpers ─────────────────────────────────────────────────────────── }

function JsonGetStr(const Json, Key: string): string;
function JsonGetFloat(const Json, Key: string; Def: Double): Double;
function JsonGetInt(const Json, Key: string; Def: Integer): Integer;
function JsonGetBool(const Json, Key: string; Def: Boolean): Boolean;

implementation

{ ═══════════════════════════════════════════════════════════════════════════
  Кросс-платформенные обёртки сокетов
  ═══════════════════════════════════════════════════════════════════════════ }

{$IFDEF WINDOWS}

function SockClose(S: TSocket): Integer;
begin
  Result := closesocket(S);
end;

procedure SockShutdown(S: TSocket);
begin
  // SD_BOTH = 2 — прерывает и recv и send, разблокирует accept/recv в других потоках
  shutdown(S, SD_BOTH);
end;

function SockRecv(S: TSocket; Buf: Pointer; Len, Flags: Integer): Integer;
begin
  Result := recv(S, Buf^, Len, Flags);
end;

function SockSend(S: TSocket; Buf: Pointer; Len, Flags: Integer): Integer;
begin
  Result := send(S, Buf^, Len, Flags);
end;

procedure SockSetNonBlock(S: TSocket; NB: Boolean);
var Mode: LongWord;
begin
  Mode := Ord(NB);
  ioctlsocket(S, FIONBIO, @Mode);
end;

procedure SockSetSndTimeout(S: TSocket; Ms: Integer);
var T: DWORD;
begin
  T := Ms;
  setsockopt(S, SOL_SOCKET, SO_SNDTIMEO, @T, SizeOf(T));
end;

procedure SockSetRcvTimeout(S: TSocket; Ms: Integer);
var T: DWORD;
begin
  T := Ms;
  setsockopt(S, SOL_SOCKET, SO_RCVTIMEO, @T, SizeOf(T));
end;

function SockRecvTimedOut: Boolean;
var E: Integer;
begin
  E := WSAGetLastError;
  Result := (E = WSAETIMEDOUT) or (E = WSAEWOULDBLOCK) or (E = WSAEINTR);
end;

{$ELSE}

function SockClose(S: TSocket): Integer;
begin
  Result := fpClose(S);
end;

procedure SockShutdown(S: TSocket);
begin
  // SHUT_RDWR = 2 — прерывает все блокирующие fpAccept/fpRecv в других потоках.
  // На Linux одного fpClose недостаточно — он не прерывает системный вызов
  // в чужом потоке. После shutdown поток получит 0 или ECONNRESET и выйдет.
  fpShutdown(S, 2 {SHUT_RDWR});
end;

function SockRecv(S: TSocket; Buf: Pointer; Len, Flags: Integer): Integer;
begin
  Result := fpRecv(S, Buf, Len, Flags);
end;

function SockSend(S: TSocket; Buf: Pointer; Len, Flags: Integer): Integer;
begin
  // MSG_NOSIGNAL обязателен: запись в сокет, который клиент уже закрыл, иначе
  // приходит SIGPIPE, а он по умолчанию убивает процесс целиком. С ним send
  // просто возвращает -1/EPIPE, и вызывающий штатно выбрасывает клиента.
  Result := fpSend(S, Buf, Len, Flags or MSG_NOSIGNAL);
end;

procedure SockSetNonBlock(S: TSocket; NB: Boolean);
var Flags: Integer;
begin
  Flags := fpFcntl(S, F_GETFL, 0);
  if NB then Flags := Flags or  O_NONBLOCK
        else Flags := Flags and (not O_NONBLOCK);
  fpFcntl(S, F_SETFL, Flags);
end;

procedure SockSetSndTimeout(S: TSocket; Ms: Integer);
var TV: TTimeVal;
begin
  TV.tv_sec  := Ms div 1000;
  TV.tv_usec := (Ms mod 1000) * 1000;
  fpSetSockOpt(S, SOL_SOCKET, SO_SNDTIMEO, @TV, SizeOf(TV));
end;

procedure SockSetRcvTimeout(S: TSocket; Ms: Integer);
var TV: TTimeVal;
begin
  TV.tv_sec  := Ms div 1000;
  TV.tv_usec := (Ms mod 1000) * 1000;
  fpSetSockOpt(S, SOL_SOCKET, SO_RCVTIMEO, @TV, SizeOf(TV));
end;

function SockRecvTimedOut: Boolean;
var E: Integer;
begin
  E := fpgeterrno;
  Result := (E = ESysEAGAIN) or (E = ESysEWOULDBLOCK) or (E = ESysEINTR);
end;

{$ENDIF}

{ ═══════════════════════════════════════════════════════════════════════════
  SHA-1 (минимальная реализация для WebSocket handshake)
  ═══════════════════════════════════════════════════════════════════════════ }

procedure SHA1Transform(var S: TSHA1State; const Block: array of Byte);
var
  W: array[0..79] of LongWord;
  i: Integer;
  a, b, c, d, e, t, f, k: LongWord;
begin
  for i := 0 to 15 do
    W[i] := (Block[i*4] shl 24) or (Block[i*4+1] shl 16) or
            (Block[i*4+2] shl 8) or Block[i*4+3];
  for i := 16 to 79 do
  begin
    t    := W[i-3] xor W[i-8] xor W[i-14] xor W[i-16];
    W[i] := (t shl 1) or (t shr 31);
  end;
  a := S[0]; b := S[1]; c := S[2]; d := S[3]; e := S[4];
  for i := 0 to 79 do
  begin
    if      i < 20 then begin f := (b and c) or ((not b) and d);          k := $5A827999; end
    else if i < 40 then begin f := b xor c xor d;                         k := $6ED9EBA1; end
    else if i < 60 then begin f := (b and c) or (b and d) or (c and d);   k := $8F1BBCDC; end
    else                begin f := b xor c xor d;                         k := $CA62C1D6; end;
    t := ((a shl 5) or (a shr 27)) + f + e + k + W[i];
    e := d; d := c; c := (b shl 30) or (b shr 2); b := a; a := t;
  end;
  Inc(S[0], a); Inc(S[1], b); Inc(S[2], c); Inc(S[3], d); Inc(S[4], e);
end;

function SHA1(const Data: string): TSHA1Digest;
var
  S:      TSHA1State;
  Buf:    array[0..63] of Byte;
  Len, BitLen, i, Pad: Integer;
begin
  S[0] := $67452301; S[1] := $EFCDAB89;
  S[2] := $98BADCFE; S[3] := $10325476; S[4] := $C3D2E1F0;
  Len    := Length(Data);
  BitLen := Len * 8;
  i := 0;
  while i + 64 <= Len do
  begin
    Move(Data[i+1], Buf[0], 64);
    SHA1Transform(S, Buf);
    Inc(i, 64);
  end;
  Pad := Len - i;
  FillChar(Buf[0], 64, 0);
  if Pad > 0 then Move(Data[i+1], Buf[0], Pad);
  Buf[Pad] := $80;
  if Pad >= 55 then
  begin
    SHA1Transform(S, Buf);
    FillChar(Buf[0], 64, 0);
  end;
  Buf[63] := Byte(BitLen);        Buf[62] := Byte(BitLen shr 8);
  Buf[61] := Byte(BitLen shr 16); Buf[60] := Byte(BitLen shr 24);
  SHA1Transform(S, Buf);
  for i := 0 to 4 do
  begin
    Result[i*4]   := Byte(S[i] shr 24); Result[i*4+1] := Byte(S[i] shr 16);
    Result[i*4+2] := Byte(S[i] shr 8);  Result[i*4+3] := Byte(S[i]);
  end;
end;

{ ═══════════════════════════════════════════════════════════════════════════
  Base64
  ═══════════════════════════════════════════════════════════════════════════ }

const
  B64Chars = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';

function Base64EncodeBytes(const Data: array of Byte; Len: Integer): string;
var
  i, j, n: Integer;
begin
  Result := '';
  i := 0;
  while i < Len do
  begin
    n := Data[i] shl 16;
    if i+1 < Len then n := n or (Data[i+1] shl 8);
    if i+2 < Len then n := n or  Data[i+2];
    Result := Result
      + B64Chars[(n shr 18) and 63 + 1]
      + B64Chars[(n shr 12) and 63 + 1]
      + B64Chars[(n shr  6) and 63 + 1]
      + B64Chars[ n         and 63 + 1];
    Inc(i, 3);
  end;
  j := Len mod 3;
  if      j = 1 then begin Result[Length(Result)-1] := '='; Result[Length(Result)] := '='; end
  else if j = 2 then        Result[Length(Result)]   := '=';
end;

function Base64EncodeStr(const S: string): string;
var
  B: array of Byte;
  i: Integer;
begin
  SetLength(B, Length(S));
  for i := 1 to Length(S) do B[i-1] := Ord(S[i]);
  Result := Base64EncodeBytes(B, Length(S));
end;

{ ═══════════════════════════════════════════════════════════════════════════
  JSON helpers (минимальный парсер без зависимостей)
  ═══════════════════════════════════════════════════════════════════════════ }

function JsonGetStr(const Json, Key: string): string;
var
  P, P2: Integer;
  K: string;
begin
  Result := '';
  // Ищем "key": — с двоеточием, чтобы не совпасть с "key" внутри значения
  // Например в {"cmd":"mode","mode":1} поиск "mode": не найдёт "mode" как значение cmd
  K := '"' + Key + '":';
  P := System.Pos(K, Json);
  if P = 0 then Exit;
  Inc(P, Length(K));
  // Пропускаем пробелы после двоеточия
  while (P <= Length(Json)) and (Json[P] = ' ') do Inc(P);
  if P > Length(Json) then Exit;
  if Json[P] = '"' then
  begin
    Inc(P); P2 := P;
    while (P2 <= Length(Json)) and (Json[P2] <> '"') do Inc(P2);
    Result := Copy(Json, P, P2 - P);
  end
  else
  begin
    P2 := P;
    while (P2 <= Length(Json)) and not (Json[P2] in [',', '}']) do Inc(P2);
    Result := Trim(Copy(Json, P, P2 - P));
  end;
end;

function JsonGetFloat(const Json, Key: string; Def: Double): Double;
var S: string;
begin
  S := JsonGetStr(Json, Key);
  if S = '' then
    Result := Def
  else
  begin
    val(S, Result);
    if IsNaN(Result) then Result := Def;
  end;
end;

function JsonGetInt(const Json, Key: string; Def: Integer): Integer;
begin
  Result := Round(JsonGetFloat(Json, Key, Def));
end;

function JsonGetBool(const Json, Key: string; Def: Boolean): Boolean;
var S: string;
begin
  S := JsonGetStr(Json, Key);
  if S = '' then Result := Def
  else           Result := (S = 'true') or (S = '1');
end;

end.