ew8bak/ewsdr
1
0
Fork 0
mirror of https://git.vladimir.cc/vladimir/ewsdr.git synced 2026-08-25 19:45:09 +00:00
Code Issues Packages Projects Releases Wiki Activity
Files
22832a1163d9ed7f10e22fa3b675bdfe225a0053
ewsdr/WebServer.pas
T
ew8bak 77d380acfd fix fft, waterfall
2026-04-22 22:09:42 +03:00

1244 lines
45 KiB
ObjectPascal
Raw Blame History

This file contains ambiguous Unicode characters
This file contains Unicode characters that might be confused with other characters. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.
unit WebServer;
{
WebServer.pas — HTTP + WebSocket сервер для удалённого управления трансивером.
Архитектура (по образцу OpenWebRX):
─────────────────────────────────
HTTP GET / → index.html (см. WebPageHtml)
HTTP GET /ws → Upgrade: WebSocket
WebSocket сессия:
• Сервер → клиент:
- каждые ~50 ms: бинарный фрейм типа 'S' + 1024×Float32 спектр
- каждые ~50 ms: бинарный фрейм типа 'W' + N×Float32 waterfall строка
- каждые ~100ms: бинарный фрейм типа 'A' + Opus-пакет (48kHz mono)
- каждые ~200ms: JSON-текст со state (freq, mode, smeter, …)
• Клиент → сервер: JSON-команды
"cmd":"freq","hz":14200000
"cmd":"mode","mode":1
"cmd":"filter","bw":2700
"cmd":"agc","mode":1
"cmd":"agctop","db":90
"cmd":"band","idx":5
"cmd":"span","hz":192000
"cmd":"volume","v":70
"cmd":"wfagc","on":true
"cmd":"wfnf","on":true
Аудио: 48kHz mono Float32 → Opus (20ms frames, 32 kbps)
Спектр: 1024 Float32 dBm значений
Авторизация: Basic Auth через HTTP заголовок при первом запросе
Зависимости: WebUtils, WsClient, WebPageHtml + RTL + libopus (динамическая загрузка)
Платформы: Windows + Linux (Winsock2 / BSD sockets)
ИСПРАВЛЕНИЯ:
- (Windows build fix) SyncObjs перенесён в конец блока uses — устраняет
конфликт идентификатора Create с символами из WinSock2 в {$MODE Delphi}.
- (Windows runtime fix) Добавлены WSAStartup/WSACleanup в конструктор и
деструктор — без этого socket/bind/listen возвращают WSANOTINITIALISED.
- (Linux shutdown fix) В Stop: перед SockClose вызывается SockShutdown для
listen-сокета и для каждого клиентского сокета. На Linux закрытие
дескриптора не прерывает блокирующий fpAccept/fpRecv в чужом потоке —
только shutdown(SHUT_RDWR) гарантированно разблокирует их, позволяя
потокам выйти и WaitFor завершиться без зависания.
- (Audio fix 1) Исправлена константа OPUS_APPLICATION_AUDIO: было 2101
(невалидное значение), стало 2049 — правильное значение. Неверная
константа приводила к Err!=0 из opus_encoder_create, FOpusEnc=nil,
FOpusReady=false — аудио не кодировалось совсем.
- (Audio fix 2) Заголовки COOP/COEP убраны — они блокировали WebSocket
и загрузку CDN ресурсов (fonts, opus-decoder), из-за чего
FWebClientActive никогда не становился true и десктоп звук не
отключался при подключении веб-клиента.
- (Audio fix 3) В JS исправлен вызов декодера: decodeFrame → decode
(актуальный API opus-decoder@0.7.7). decodeFrame не существует в этой
версии — silent fail, звука нет.
- (Audio fix 4) Добавлен оверлей "Click to start audio" — AudioContext
нельзя создать из WebSocket callback (не user gesture). Оверлей
гарантирует создание AudioContext при первом кликe пользователя.
- (Audio fix 5) Буферизация Opus-пакетов пока WASM не инициализирован —
первые пакеты больше не теряются при медленной загрузке CDN.
}
{$IFDEF FPC}
{$MODE Delphi}
{$LONGSTRINGS ON}
{$ENDIF}
interface
uses
Classes, SysUtils, Math,
WebUtils, WsClient, WebPageHtml
{$IFDEF WINDOWS}, Windows, WinSock2{$ELSE}, BaseUnix, Sockets{$ENDIF},
SyncObjs; // ← после платформенных юнитов: исключает конфликт идентификатора Create
const
WEB_PORT = 8080;
OPUS_SAMPLE_RATE = 48000;
OPUS_FRAME_MS = 20;
OPUS_FRAME_SAMP = OPUS_SAMPLE_RATE * OPUS_FRAME_MS div 1000; // 960 samples
OPUS_BITRATE = 32000;
OPUS_CHANNELS = 1;
MAX_WS_CLIENTS = 4;
WS_GUID = '258EAFA5-E914-47DA-95CA-C5AB0DC85B11';
// Типы бинарных фреймов (первый байт = тип)
WS_MSG_SPECTRUM = Byte(Ord('S')); // S + 1024×Float32
WS_MSG_WATERFALL = Byte(Ord('W')); // W + N×Float32
WS_MSG_AUDIO = Byte(Ord('A')); // A + Opus bytes
WS_MSG_AUDIO_PCM = Byte(Ord('P')); // P + N×Float32 (mono 48k)
WS_MSG_STATE = Byte(Ord('J')); // J + JSON text
type
// ── Opus dynamic binding ──────────────────────────────────────────────────
POpusEncoder = Pointer;
TOpus_encoder_create = function(Fs, channels, application: Integer;
error: PInteger): POpusEncoder; cdecl;
TOpus_encoder_destroy = procedure(st: POpusEncoder); cdecl;
TOpus_encode_float = function(st: POpusEncoder;
pcm: PSingle; frame_size: Integer;
data: PByte; max_data_bytes: Integer): Integer; cdecl;
TOpus_encoder_ctl_set = function(st: POpusEncoder;
request: Integer; value: Integer): Integer; cdecl;
// ── Callbacks в MainForm ──────────────────────────────────────────────────
TWebCmdFreq = procedure(Hz: Double) of object;
TWebCmdMode = procedure(Mode: Integer) of object;
TWebCmdFilter = procedure(BW: Integer) of object;
TWebCmdAGC = procedure(Mode: Integer) of object;
TWebCmdAGCTop = procedure(DB: Integer) of object;
TWebCmdBand = procedure(Idx: Integer) of object;
TWebCmdSpan = procedure(Hz: Integer) of object;
TWebCmdVolume = procedure(V: Integer) of object;
TWebCmdWfAGC = procedure(On_: Boolean) of object;
TWebCmdWfNF = procedure(On_: Boolean) of object;
TWebCmdRun = procedure(On_: Boolean) of object;
TWebCmdMute = procedure(On_: Boolean) of object;
TWebCmdCtun = procedure(On_: Boolean) of object;
TWebCmdNRMode = procedure(Mode: Integer) of object;
TWebCmdNBMode = procedure(Mode: Integer) of object;
TWebCmdSNB = procedure(On_: Boolean) of object;
TWebCmdANF = procedure(On_: Boolean) of object;
TWebCmdFreqB = procedure(Hz: Double) of object;
TWebCmdActiveVfo = procedure(Idx: Integer) of object;
TWebCmdCenter = procedure(Hz: Double) of object;
TWebCmdMOX = procedure(On_: Boolean) of object;
TWebCmdDrive = procedure(V: Integer) of object;
// ── Главный класс сервера ─────────────────────────────────────────────────
TWebServer = class
private
// ── Opus ──
FOpusLib: THandle;
FOpusEnc: POpusEncoder;
FOpusCreate: TOpus_encoder_create;
FOpusDestroy: TOpus_encoder_destroy;
FOpusEncode: TOpus_encode_float;
FOpusCtl: TOpus_encoder_ctl_set;
FOpusBuf: array[0..OPUS_FRAME_SAMP-1] of Single;
FOpusBufPos: Integer;
FOpusOut: array[0..3999] of Byte;
FOpusReady: Boolean;
// ── TCP ──
FListenSock: TSocket;
FClients: array[0..MAX_WS_CLIENTS-1] of TWsClient;
FClientCount: Integer;
FClientLock: TCriticalSection;
// ── Потоки ──
FAcceptThread: TThread;
FPushThread: TThread;
FRunning: Boolean;
// ── Авторизация ──
FAuthToken: string; // Base64(user:pass)
// ── Состояние (обновляется из MainForm) ──
FSpectrumBuf: array[0..1023] of Single;
FWfBuf: array[0..1023] of Single;
FWfCount: Integer;
FSMeter: Double;
FFreq: Double;
FMode: Integer;
FFilterBW: Integer;
FAGCMode: Integer;
FAGCTop: Integer;
FSpanHz: Double;
FVolume: Integer;
FWfAGC: Boolean;
FWfNF: Boolean;
FBandIdx: Integer;
FConnected: Boolean;
FTrxRunning: Boolean;
FMuted: Boolean;
FCtun: Boolean;
FNRMode: Integer;
FNBMode: Integer;
FSNB: Boolean;
FANF: Boolean;
FCenterHz: Double;
FFilterIdx: Integer;
FVfoB: Double;
FActiveVfo: Integer; // 0=A, 1=B
FStateLock: TCriticalSection;
// ── Callbacks ──
FOnFreq: TWebCmdFreq;
FOnMode: TWebCmdMode;
FOnFilter: TWebCmdFilter;
FOnAGC: TWebCmdAGC;
FOnAGCTop: TWebCmdAGCTop;
FOnBand: TWebCmdBand;
FOnSpan: TWebCmdSpan;
FOnVolume: TWebCmdVolume;
FOnWfAGC: TWebCmdWfAGC;
FOnWfNF: TWebCmdWfNF;
FOnRun: TWebCmdRun;
FOnMute: TWebCmdMute;
FOnCtun: TWebCmdCtun;
FOnNR: TWebCmdNRMode;
FOnNB: TWebCmdNBMode;
FOnSNB: TWebCmdSNB;
FOnANF: TWebCmdANF;
FOnFreqB: TWebCmdFreqB;
FOnActiveVfo: TWebCmdActiveVfo;
FOnCenter: TWebCmdCenter;
FOnMOX: TWebCmdMOX;
FOnDrive: TWebCmdDrive;
FTransmitting: Boolean;
FDriveLevel: Integer;
FWebClientActive: Boolean;
// ── Внутренние методы ──
function LoadOpus: Boolean;
procedure UnloadOpus;
function InitListen: Boolean;
procedure AcceptLoop;
procedure PushLoop;
procedure HandleClient(Client: TWsClient);
procedure ProcessCommand(Client: TWsClient; const Json: string);
procedure BroadcastBinary(const Data; Len: Integer);
procedure BroadcastText(const S: string);
procedure RemoveClient(Client: TWsClient);
function BuildStateJson: string;
function CheckAuth(const Header: string): Boolean;
procedure SendHttp(Client: TWsClient; Code: Integer; const ContentType, Body: string);
// Stub-методы (реализация встроена в HandleClient)
procedure DoHandshake(Client: TWsClient);
procedure ProcessWsFrame(Client: TWsClient; const Data: array of Byte; Len: Integer; Opcode: Byte);
public
constructor Create(const Username, Password: string);
destructor Destroy; override;
function Start: Boolean;
procedure Stop;
// Вызывается из DSP-потока (аудио, 48kHz mono)
procedure PushAudio(const Samples: PSingle; Count: Integer);
// Вызывается из таймера спектра (UI thread)
procedure PushSpectrum(
const Buf: array of Single; Count: Integer;
const WfBuf_: array of Single;
SMeter: Double;
Freq: Double; Mode, FilterBW, AGCMode, AGCTop: Integer;
SpanHz: Double; Volume: Integer;
WfAGC, WfNF: Boolean; BandIdx: Integer;
TrxConnected: Boolean;
TrxRunning, Muted, Ctun: Boolean;
NRMode, NBMode: Integer; SNB, ANF: Boolean;
CenterHz: Double; FilterIdx: Integer;
VfoB: Double; ActiveVfo: Integer;
Transmitting: Boolean; DriveLevel: Integer);
property WebClientActive: Boolean read FWebClientActive;
property OnFreq: TWebCmdFreq read FOnFreq write FOnFreq;
property OnMode: TWebCmdMode read FOnMode write FOnMode;
property OnFilter: TWebCmdFilter read FOnFilter write FOnFilter;
property OnAGC: TWebCmdAGC read FOnAGC write FOnAGC;
property OnAGCTop: TWebCmdAGCTop read FOnAGCTop write FOnAGCTop;
property OnBand: TWebCmdBand read FOnBand write FOnBand;
property OnSpan: TWebCmdSpan read FOnSpan write FOnSpan;
property OnVolume: TWebCmdVolume read FOnVolume write FOnVolume;
property OnWfAGC: TWebCmdWfAGC read FOnWfAGC write FOnWfAGC;
property OnWfNF: TWebCmdWfNF read FOnWfNF write FOnWfNF;
property OnRun: TWebCmdRun read FOnRun write FOnRun;
property OnMute: TWebCmdMute read FOnMute write FOnMute;
property OnCtun: TWebCmdCtun read FOnCtun write FOnCtun;
property OnNR: TWebCmdNRMode read FOnNR write FOnNR;
property OnNB: TWebCmdNBMode read FOnNB write FOnNB;
property OnSNB: TWebCmdSNB read FOnSNB write FOnSNB;
property OnANF: TWebCmdANF read FOnANF write FOnANF;
property OnFreqB: TWebCmdFreqB read FOnFreqB write FOnFreqB;
property OnActiveVfo: TWebCmdActiveVfo read FOnActiveVfo write FOnActiveVfo;
property OnCenter: TWebCmdCenter read FOnCenter write FOnCenter;
property OnMOX: TWebCmdMOX read FOnMOX write FOnMOX;
property OnDrive: TWebCmdDrive read FOnDrive write FOnDrive;
end;
implementation
{ ═══════════════════════════════════════════════════════════════════════════
Внутренние классы потоков
═══════════════════════════════════════════════════════════════════════════ }
type
TAcceptThread = class(TThread)
private FServer: TWebServer;
protected procedure Execute; override;
public constructor Create(AServer: TWebServer);
end;
TPushThread = class(TThread)
private FServer: TWebServer;
protected procedure Execute; override;
public constructor Create(AServer: TWebServer);
end;
TClientThread = class(TThread)
private FServer: TWebServer; FClient: TWsClient;
protected procedure Execute; override;
public constructor Create(AServer: TWebServer; AClient: TWsClient);
end;
constructor TAcceptThread.Create(AServer: TWebServer);
begin
inherited Create(True);
FServer := AServer;
FreeOnTerminate := False;
end;
procedure TAcceptThread.Execute;
begin
FServer.AcceptLoop;
end;
constructor TPushThread.Create(AServer: TWebServer);
begin
inherited Create(True);
FServer := AServer;
FreeOnTerminate := False;
end;
procedure TPushThread.Execute;
begin
FServer.PushLoop;
end;
constructor TClientThread.Create(AServer: TWebServer; AClient: TWsClient);
begin
inherited Create(True);
FServer := AServer;
FClient := AClient;
FreeOnTerminate := True;
end;
procedure TClientThread.Execute;
begin
FServer.HandleClient(FClient);
end;
{ ═══════════════════════════════════════════════════════════════════════════
TWebServer — конструктор / деструктор
═══════════════════════════════════════════════════════════════════════════ }
constructor TWebServer.Create(const Username, Password: string);
{$IFDEF WINDOWS}
var
WSAData: TWSAData;
{$ENDIF}
begin
{$IFDEF WINDOWS}
// Инициализация Winsock2 — обязательна перед любыми вызовами socket API
WSAStartup($0202, WSAData);
{$ENDIF}
inherited Create;
FAuthToken := Base64EncodeStr(Username + ':' + Password);
FListenSock := SOCK_INVALID;
FRunning := False;
FClientCount := 0;
FOpusReady := False;
FOpusBufPos := 0;
FWebClientActive := False;
FClientLock := TCriticalSection.Create;
FStateLock := TCriticalSection.Create;
// Начальные значения состояния
FFreq := 14200000;
FMode := 1;
FFilterBW:= 2700;
FAGCMode := 1;
FAGCTop := 90;
FSpanHz := 192000;
FVolume := 70;
FSMeter := -120;
FBandIdx := 5;
end;
destructor TWebServer.Destroy;
begin
Stop;
FClientLock.Free;
FStateLock.Free;
inherited;
{$IFDEF WINDOWS}
// Освобождение ресурсов Winsock2
WSACleanup;
{$ENDIF}
end;
{ ═══════════════════════════════════════════════════════════════════════════
Загрузка / выгрузка Opus
═══════════════════════════════════════════════════════════════════════════ }
function TWebServer.LoadOpus: Boolean;
const
{$IFDEF WINDOWS} LIBNAME = 'libopus-0.dll';
{$ELSE} LIBNAME = 'libopus.so.0';
{$ENDIF}
var Err: Integer;
begin
Result := False;
FOpusLib := LoadLibrary(LIBNAME);
if FOpusLib = 0 then Exit;
FOpusCreate := TOpus_encoder_create( GetProcAddress(FOpusLib, 'opus_encoder_create'));
FOpusDestroy := TOpus_encoder_destroy(GetProcAddress(FOpusLib, 'opus_encoder_destroy'));
FOpusEncode := TOpus_encode_float( GetProcAddress(FOpusLib, 'opus_encode_float'));
FOpusCtl := TOpus_encoder_ctl_set(GetProcAddress(FOpusLib, 'opus_encoder_ctl'));
if not Assigned(FOpusCreate) or not Assigned(FOpusEncode) then
begin
FreeLibrary(FOpusLib); FOpusLib := 0; Exit;
end;
FOpusEnc := FOpusCreate(OPUS_SAMPLE_RATE, OPUS_CHANNELS,
2049 {OPUS_APPLICATION_AUDIO}, @Err);
if (FOpusEnc = nil) or (Err <> 0) then
begin
FreeLibrary(FOpusLib); FOpusLib := 0; Exit;
end;
// OPUS_SET_BITRATE_REQUEST = 4002
if Assigned(FOpusCtl) then
FOpusCtl(FOpusEnc, 4002, OPUS_BITRATE);
FOpusBufPos := 0;
FOpusReady := True;
Result := True;
end;
procedure TWebServer.UnloadOpus;
begin
if FOpusReady and Assigned(FOpusDestroy) and (FOpusEnc <> nil) then
FOpusDestroy(FOpusEnc);
FOpusEnc := nil;
FOpusReady := False;
if FOpusLib <> 0 then
begin
FreeLibrary(FOpusLib);
FOpusLib := 0;
end;
end;
{ ═══════════════════════════════════════════════════════════════════════════
Start / Stop
═══════════════════════════════════════════════════════════════════════════ }
function TWebServer.InitListen: Boolean;
var
Addr: {$IFDEF WINDOWS}TSockAddrIn{$ELSE}TInetSockAddr{$ENDIF};
One: Integer;
begin
Result := False;
{$IFDEF WINDOWS}
FListenSock := socket(AF_INET, SOCK_STREAM, IPPROTO_TCP);
{$ELSE}
FListenSock := fpSocket(AF_INET, SOCK_STREAM, IPPROTO_TCP);
{$ENDIF}
if FListenSock = SOCK_INVALID then Exit;
One := 1;
{$IFDEF WINDOWS}
setsockopt(FListenSock, SOL_SOCKET, SO_REUSEADDR, @One, SizeOf(One));
FillChar(Addr, SizeOf(Addr), 0);
Addr.sin_family := AF_INET;
Addr.sin_port := htons(WEB_PORT);
Addr.sin_addr.S_addr := INADDR_ANY;
if bind(FListenSock, @Addr, SizeOf(Addr)) = SOCKET_ERROR then Exit;
if listen(FListenSock, 5) = SOCKET_ERROR then Exit;
{$ELSE}
fpSetSockOpt(FListenSock, SOL_SOCKET, SO_REUSEADDR, @One, SizeOf(One));
FillChar(Addr, SizeOf(Addr), 0);
Addr.sin_family := AF_INET;
Addr.sin_port := htons(WEB_PORT);
Addr.sin_addr.s_addr := htonl(INADDR_ANY);
if fpBind(FListenSock, @Addr, SizeOf(Addr)) <> 0 then Exit;
if fpListen(FListenSock, 5) <> 0 then Exit;
{$ENDIF}
Result := True;
end;
function TWebServer.Start: Boolean;
begin
Result := False;
if FRunning then Exit;
if not LoadOpus then ; // Opus опционален — продолжаем без него
if not InitListen then Exit;
FRunning := True;
FAcceptThread := TAcceptThread.Create(Self);
TAcceptThread(FAcceptThread).Start;
FPushThread := TPushThread.Create(Self);
TPushThread(FPushThread).Start;
Result := True;
end;
procedure TWebServer.Stop;
var i: Integer;
begin
if not FRunning then Exit;
FRunning := False;
// ── Шаг 1: shutdown + close listen-сокета ────────────────────────────────
// SockShutdown ОБЯЗАТЕЛЕН перед SockClose на Linux: закрытие дескриптора
// не прерывает fpAccept в AcceptThread — только shutdown разблокирует его.
// На Windows это тоже корректно (SD_BOTH).
if FListenSock <> SOCK_INVALID then
begin
SockShutdown(FListenSock);
SockClose(FListenSock);
FListenSock := SOCK_INVALID;
end;
// ── Шаг 2: shutdown всех клиентских сокетов ──────────────────────────────
// Разблокирует все HandleClient, заблокированные в Client.Recv (fpRecv).
// FreeOnTerminate=True у TClientThread — они освободятся сами после выхода.
FClientLock.Enter;
try
for i := 0 to FClientCount - 1 do
if FClients[i] <> nil then
begin
FClients[i].State := wsClosed;
SockShutdown(FClients[i].Socket); // ← разблокирует fpRecv в клиентском потоке
end;
finally
FClientLock.Leave;
end;
// ── Шаг 3: ждём завершения фоновых потоков ───────────────────────────────
// После shutdown потоки получат ошибку из recv/accept и выйдут сами.
if FAcceptThread <> nil then begin FAcceptThread.WaitFor; FreeAndNil(FAcceptThread); end;
if FPushThread <> nil then begin FPushThread.WaitFor; FreeAndNil(FPushThread); end;
// ── Шаг 4: освобождаем клиентов ──────────────────────────────────────────
FClientLock.Enter;
try
for i := 0 to FClientCount - 1 do FreeAndNil(FClients[i]);
FClientCount := 0;
finally
FClientLock.Leave;
end;
UnloadOpus;
end;
{ ═══════════════════════════════════════════════════════════════════════════
Accept loop
═══════════════════════════════════════════════════════════════════════════ }
procedure TWebServer.AcceptLoop;
var
CSock: TSocket;
Addr: {$IFDEF WINDOWS}TSockAddrIn{$ELSE}TInetSockAddr{$ENDIF};
ALen: {$IFDEF WINDOWS}Integer{$ELSE}TSockLen{$ENDIF};
Client: TWsClient;
T: TClientThread;
begin
while FRunning do
begin
ALen := SizeOf(Addr);
{$IFDEF WINDOWS}
CSock := accept(FListenSock, @Addr, @ALen);
{$ELSE}
CSock := fpAccept(FListenSock, @Addr, @ALen);
{$ENDIF}
if CSock = SOCK_INVALID then
begin
if FRunning then Sleep(10);
Continue;
end;
if FClientCount >= MAX_WS_CLIENTS then
begin
SockClose(CSock);
Continue;
end;
Client := TWsClient.Create(CSock);
FClientLock.Enter;
try
FClients[FClientCount] := Client;
Inc(FClientCount);
finally
FClientLock.Leave;
end;
T := TClientThread.Create(Self, Client);
T.Start;
end;
end;
{ ═══════════════════════════════════════════════════════════════════════════
HTTP / WebSocket обработчик клиента
═══════════════════════════════════════════════════════════════════════════ }
function TWebServer.CheckAuth(const Header: string): Boolean;
var
Pos_: Integer;
Token, HeaderLC: string;
begin
Result := False;
HeaderLC := LowerCase(Header);
Pos_ := System.Pos('authorization: basic ', HeaderLC);
if Pos_ = 0 then Exit;
Token := Copy(Header, Pos_ + 21, 200);
Pos_ := System.Pos(#13, Token); if Pos_ > 0 then Token := Copy(Token, 1, Pos_ - 1);
Pos_ := System.Pos(#10, Token); if Pos_ > 0 then Token := Copy(Token, 1, Pos_ - 1);
Token := Trim(Token);
Result := (Token = FAuthToken);
end;
procedure TWebServer.SendHttp(Client: TWsClient; Code: Integer;
const ContentType, Body: string);
var
StatusText, Response: string;
begin
case Code of
200: StatusText := 'OK';
401: StatusText := 'Unauthorized';
404: StatusText := 'Not Found';
else StatusText := 'Error';
end;
Response := Format('HTTP/1.1 %d %s'#13#10 +
'Content-Type: %s'#13#10 +
'Content-Length: %d'#13#10 +
'Connection: close'#13#10 +
#13#10 + '%s', [Code, StatusText, ContentType, Length(Body), Body]);
Client.SendRaw(Response[1], Length(Response));
end;
procedure TWebServer.HandleClient(Client: TWsClient);
var
R, HeaderEnd: Integer;
Header, HeaderLC, Key, Path, AcceptKey: string;
Response: string;
WsHandled: Boolean;
IsWsRequest: Boolean;
// WS frame parsing
B0, B1: Byte;
Masked: Boolean;
PayLen: Integer;
Mask: array[0..3] of Byte;
Payload: array of Byte;
Opcode: Byte;
i, Need: Integer;
j: Integer;
P1, P2: Integer;
KPos, KEnd: Integer;
Consumed: Integer;
Raw: array[0..8191] of Byte;
RawLen: Integer;
begin
WsHandled := False;
RawLen := 0;
// ── Фаза 1: чтение HTTP-запроса ──────────────────────────────────────────
Header := '';
repeat
R := SockRecv(Client.Socket, @Raw[RawLen], SizeOf(Raw) - RawLen, 0);
if R <= 0 then begin Client.State := wsClosed; Break; end;
Inc(RawLen, R);
SetLength(Header, RawLen);
Move(Raw[0], Header[1], RawLen);
HeaderEnd := System.Pos(#13#10#13#10, Header);
until (HeaderEnd > 0) or (RawLen >= SizeOf(Raw));
if (Client.State = wsClosed) or (HeaderEnd = 0) then
begin
RemoveClient(Client); Exit;
end;
Header := Copy(Header, 1, HeaderEnd + 3);
HeaderLC := LowerCase(Header);
// Извлечь путь
Path := '';
if System.Pos('GET /', Header) > 0 then
begin
P1 := System.Pos('GET ', Header) + 4;
P2 := System.Pos(' HTTP', Header);
if P2 > P1 then Path := Copy(Header, P1, P2 - P1);
end;
IsWsRequest := (Path = '/ws') and (System.Pos('upgrade: websocket', HeaderLC) > 0);
// Basic Auth (только для HTTP-страниц; WS handshake без авторизации)
if (not IsWsRequest) and (not CheckAuth(Header)) then
begin
Response := 'HTTP/1.1 401 Unauthorized'#13#10 +
'WWW-Authenticate: Basic realm="HPSDR"'#13#10 +
'Content-Length: 0'#13#10 +
'Connection: close'#13#10#13#10;
Client.SendRaw(Response[1], Length(Response));
RemoveClient(Client); Exit;
end;
// WebSocket upgrade
if System.Pos('upgrade: websocket', HeaderLC) > 0 then
begin
KPos := System.Pos('sec-websocket-key: ', HeaderLC);
if KPos > 0 then
begin
Key := Copy(Header, KPos + 19, 100);
KEnd := System.Pos(#13, Key);
if KEnd > 0 then Key := Copy(Key, 1, KEnd - 1);
Key := Trim(Key);
end;
AcceptKey := Base64EncodeBytes(SHA1(Key + WS_GUID), 20);
Response := 'HTTP/1.1 101 Switching Protocols'#13#10 +
'Upgrade: websocket'#13#10 +
'Connection: Upgrade'#13#10 +
'Sec-WebSocket-Accept: ' + AcceptKey + #13#10#13#10;
Client.SendRaw(Response[1], Length(Response));
Client.State := wsOpen;
FStateLock.Enter;
FWebClientActive := True;
FStateLock.Leave;
Client.SendText(BuildStateJson);
WsHandled := True;
end
else if Path = '/' then
begin
SendHttp(Client, 200, 'text/html; charset=utf-8', GetIndexHtml);
RemoveClient(Client); Exit;
end
else
begin
SendHttp(Client, 404, 'text/plain', 'Not Found');
RemoveClient(Client); Exit;
end;
if not WsHandled then begin RemoveClient(Client); Exit; end;
// ── Фаза 2: цикл WebSocket-сообщений ─────────────────────────────────────
Client.BufLen := 0;
while FRunning and (Client.State = wsOpen) do
begin
R := Client.Recv;
if R <= 0 then Break;
while Client.BufLen >= 2 do
begin
B0 := Client.BufData[0];
B1 := Client.BufData[1];
Opcode := B0 and $0F;
Masked := (B1 and $80) <> 0;
PayLen := B1 and $7F;
Need := 2;
if PayLen = 126 then Inc(Need, 2)
else if PayLen = 127 then Inc(Need, 8);
if Masked then Inc(Need, 4);
if Client.BufLen < Need then Break;
i := 2;
if PayLen = 126 then
begin
PayLen := (Client.BufData[2] shl 8) or Client.BufData[3];
Inc(i, 2);
end
else if PayLen = 127 then
begin
PayLen := (Client.BufData[6] shl 24) or (Client.BufData[7] shl 16) or
(Client.BufData[8] shl 8) or Client.BufData[9];
Inc(i, 8);
end;
if Client.BufLen < Need + PayLen then Break;
if Masked then
begin
Mask[0] := Client.BufData[i]; Mask[1] := Client.BufData[i+1];
Mask[2] := Client.BufData[i+2]; Mask[3] := Client.BufData[i+3];
Inc(i, 4);
end;
SetLength(Payload, PayLen);
if PayLen > 0 then
begin
Move(Client.BufData[i], Payload[0], PayLen);
if Masked then
for j := 0 to PayLen - 1 do
Payload[j] := Payload[j] xor Mask[j and 3];
end;
Consumed := i + PayLen;
if Client.BufLen > Consumed then
Move(Client.BufData[Consumed], Client.BufData[0], Client.BufLen - Consumed);
Client.BufLen := Client.BufLen - Consumed;
case Opcode of
$01: // Text → команда
begin
SetLength(Header, PayLen);
if PayLen > 0 then Move(Payload[0], Header[1], PayLen);
ProcessCommand(Client, Header);
end;
$08: // Close
begin
Client.State := wsClosed;
Break;
end;
$09: // Ping → Pong
Client.SendWsFrame($0A, Payload[0], PayLen);
end;
end;
end;
FStateLock.Enter;
FWebClientActive := (FClientCount > 1);
FStateLock.Leave;
RemoveClient(Client);
end;
procedure TWebServer.RemoveClient(Client: TWsClient);
var i, j: Integer;
begin
FClientLock.Enter;
try
for i := 0 to FClientCount - 1 do
if FClients[i] = Client then
begin
FClients[i].Free;
for j := i to FClientCount - 2 do FClients[j] := FClients[j+1];
FClients[FClientCount-1] := nil;
Dec(FClientCount);
Break;
end;
FWebClientActive := False;
for i := 0 to FClientCount - 1 do
if (FClients[i] <> nil) and (FClients[i].State = wsOpen) then
begin FWebClientActive := True; Break; end;
finally
FClientLock.Leave;
end;
end;
{ ═══════════════════════════════════════════════════════════════════════════
Обработка JSON-команд от браузера
═══════════════════════════════════════════════════════════════════════════ }
procedure TWebServer.ProcessCommand(Client: TWsClient; const Json: string);
var
Cmd: string;
HzF: Double;
HzI, ModeValue, BW, DB, Idx, V: Integer;
On_: Boolean;
begin
Cmd := JsonGetStr(Json, 'cmd');
if Cmd = 'freq' then
begin
HzF := JsonGetFloat(Json, 'hz', FFreq);
FStateLock.Enter; FFreq := HzF; FStateLock.Leave;
if Assigned(FOnFreq) then FOnFreq(HzF);
end
else if Cmd = 'mode' then
begin
ModeValue := JsonGetInt(Json, 'mode', FMode);
FStateLock.Enter; FMode := ModeValue; FStateLock.Leave;
if Assigned(FOnMode) then FOnMode(ModeValue);
end
else if Cmd = 'filter' then
begin
BW := JsonGetInt(Json, 'bw', FFilterBW);
FStateLock.Enter; FFilterBW := BW; FStateLock.Leave;
if Assigned(FOnFilter) then FOnFilter(BW);
end
else if Cmd = 'agc' then
begin
ModeValue := JsonGetInt(Json, 'mode', FAGCMode);
FStateLock.Enter; FAGCMode := ModeValue; FStateLock.Leave;
if Assigned(FOnAGC) then FOnAGC(ModeValue);
end
else if Cmd = 'agctop' then
begin
DB := JsonGetInt(Json, 'db', FAGCTop);
FStateLock.Enter; FAGCTop := DB; FStateLock.Leave;
if Assigned(FOnAGCTop) then FOnAGCTop(DB);
end
else if Cmd = 'band' then
begin
Idx := JsonGetInt(Json, 'idx', FBandIdx);
FStateLock.Enter; FBandIdx := Idx; FStateLock.Leave;
if Assigned(FOnBand) then FOnBand(Idx);
end
else if Cmd = 'span' then
begin
HzI := JsonGetInt(Json, 'hz', Round(FSpanHz));
FStateLock.Enter; FSpanHz := HzI; FStateLock.Leave;
if Assigned(FOnSpan) then FOnSpan(HzI);
end
else if Cmd = 'volume' then
begin
V := JsonGetInt(Json, 'v', FVolume);
FStateLock.Enter; FVolume := V; FStateLock.Leave;
if Assigned(FOnVolume) then FOnVolume(V);
end
else if Cmd = 'wfagc' then
begin
On_ := JsonGetBool(Json, 'on', FWfAGC);
FStateLock.Enter; FWfAGC := On_; FStateLock.Leave;
if Assigned(FOnWfAGC) then FOnWfAGC(On_);
end
else if Cmd = 'wfnf' then
begin
On_ := JsonGetBool(Json, 'on', FWfNF);
FStateLock.Enter; FWfNF := On_; FStateLock.Leave;
if Assigned(FOnWfNF) then FOnWfNF(On_);
end
else if Cmd = 'set_run' then
begin
On_ := JsonGetBool(Json, 'on', FTrxRunning);
FStateLock.Enter; FTrxRunning := On_; FStateLock.Leave;
if Assigned(FOnRun) then FOnRun(On_);
end
else if Cmd = 'set_mute' then
begin
On_ := JsonGetBool(Json, 'on', FMuted);
FStateLock.Enter; FMuted := On_; FStateLock.Leave;
if Assigned(FOnMute) then FOnMute(On_);
end
else if Cmd = 'set_ctun' then
begin
On_ := JsonGetBool(Json, 'on', FCtun);
FStateLock.Enter; FCtun := On_; FStateLock.Leave;
if Assigned(FOnCtun) then FOnCtun(On_);
end
else if Cmd = 'set_nr' then
begin
On_ := JsonGetBool(Json, 'on', FNRMode <> 0);
ModeValue := Ord(On_);
FStateLock.Enter; FNRMode := ModeValue; FStateLock.Leave;
if Assigned(FOnNR) then FOnNR(ModeValue);
end
else if Cmd = 'set_nr_mode' then
begin
ModeValue := JsonGetInt(Json, 'mode', FNRMode);
if ModeValue < 0 then ModeValue := 0;
if ModeValue > 4 then ModeValue := 4;
FStateLock.Enter; FNRMode := ModeValue; FStateLock.Leave;
if Assigned(FOnNR) then FOnNR(ModeValue);
end
else if Cmd = 'set_nb' then
begin
On_ := JsonGetBool(Json, 'on', FNBMode <> 0);
ModeValue := Ord(On_);
FStateLock.Enter; FNBMode := ModeValue; FStateLock.Leave;
if Assigned(FOnNB) then FOnNB(ModeValue);
end
else if Cmd = 'set_nb_mode' then
begin
ModeValue := JsonGetInt(Json, 'mode', FNBMode);
if ModeValue < 0 then ModeValue := 0;
if ModeValue > 2 then ModeValue := 2;
FStateLock.Enter; FNBMode := ModeValue; FStateLock.Leave;
if Assigned(FOnNB) then FOnNB(ModeValue);
end
else if Cmd = 'set_snb' then
begin
On_ := JsonGetBool(Json, 'on', FSNB);
FStateLock.Enter; FSNB := On_; FStateLock.Leave;
if Assigned(FOnSNB) then FOnSNB(On_);
end
else if Cmd = 'set_anf' then
begin
On_ := JsonGetBool(Json, 'on', FANF);
FStateLock.Enter; FANF := On_; FStateLock.Leave;
if Assigned(FOnANF) then FOnANF(On_);
end
else if Cmd = 'freq_b' then
begin
HzF := JsonGetFloat(Json, 'hz', FVfoB);
FStateLock.Enter; FVfoB := HzF; FStateLock.Leave;
if Assigned(FOnFreqB) then FOnFreqB(HzF);
end
else if Cmd = 'set_active_vfo' then
begin
ModeValue := JsonGetInt(Json, 'idx', FActiveVfo);
if ModeValue < 0 then ModeValue := 0;
if ModeValue > 1 then ModeValue := 1;
FStateLock.Enter; FActiveVfo := ModeValue; FStateLock.Leave;
if Assigned(FOnActiveVfo) then FOnActiveVfo(ModeValue);
end
else if Cmd = 'set_center' then
begin
HzF := JsonGetFloat(Json, 'hz', FCenterHz);
FStateLock.Enter; FCenterHz := HzF; FStateLock.Leave;
if Assigned(FOnCenter) then FOnCenter(HzF);
end
else if Cmd = 'set_mox' then
begin
On_ := JsonGetBool(Json, 'on', FTransmitting);
FStateLock.Enter; FTransmitting := On_; FStateLock.Leave;
if Assigned(FOnMOX) then FOnMOX(On_);
end
else if Cmd = 'drive' then
begin
V := JsonGetInt(Json, 'v', FDriveLevel);
if V < 0 then V := 0;
if V > 100 then V := 100;
FStateLock.Enter; FDriveLevel := V; FStateLock.Leave;
if Assigned(FOnDrive) then FOnDrive(V);
end;
end;
{ ═══════════════════════════════════════════════════════════════════════════
Push-цикл — рассылает спектр / водопад / состояние всем клиентам
═══════════════════════════════════════════════════════════════════════════ }
procedure TWebServer.PushLoop;
var
Tick, StateLastTick: QWord;
SpecBuf: array[0..4096] of Byte;
WfBuf: array[0..4096] of Byte;
i: Integer;
HasClients: Boolean;
begin
StateLastTick := GetTickCount64;
while FRunning do
begin
Sleep(50); // 20 fps
Tick := GetTickCount64;
FClientLock.Enter;
HasClients := FClientCount > 0;
FClientLock.Leave;
if not HasClients then Continue;
FStateLock.Enter;
try
SpecBuf[0] := WS_MSG_SPECTRUM;
for i := 0 to 1023 do
PSingle(Pointer(PByte(@SpecBuf[1]) + i*4))^ := FSpectrumBuf[i];
WfBuf[0] := WS_MSG_WATERFALL;
for i := 0 to 1023 do
PSingle(Pointer(PByte(@WfBuf[1]) + i*4))^ := FWfBuf[i];
finally
FStateLock.Leave;
end;
BroadcastBinary(SpecBuf[0], 1 + 1024*4);
BroadcastBinary(WfBuf[0], 1 + 1024*4);
if Tick - StateLastTick >= 200 then
begin
StateLastTick := Tick;
BroadcastText(BuildStateJson);
end;
end;
end;
procedure TWebServer.BroadcastBinary(const Data; Len: Integer);
var i: Integer;
begin
FClientLock.Enter;
try
for i := 0 to FClientCount - 1 do
if (FClients[i] <> nil) and (FClients[i].State = wsOpen) then
FClients[i].SendBinary(Data, Len);
finally
FClientLock.Leave;
end;
end;
procedure TWebServer.BroadcastText(const S: string);
var i: Integer;
begin
FClientLock.Enter;
try
for i := 0 to FClientCount - 1 do
if (FClients[i] <> nil) and (FClients[i].State = wsOpen) then
FClients[i].SendText(S);
finally
FClientLock.Leave;
end;
end;
{ ═══════════════════════════════════════════════════════════════════════════
Формирование JSON-состояния
═══════════════════════════════════════════════════════════════════════════ }
function TWebServer.BuildStateJson: string;
const
MODE_N: array[0..7] of string =
('LSB','USB','DSB','CWL','CWU','FM','AM','SAM');
begin
FStateLock.Enter;
try
Result := Format(
'{"vfo_a_hz":%.0f,"vfo_b_hz":%.0f,"active_vfo":%d,' +
'"mode":%d,"mode_name":"%s",' +
'"filter":%d,"filter_bw":%d,' +
'"agc_mode":%d,"agc_top":%d,' +
'"span_hz":%.0f,"center_hz":%.0f,"volume":%d,' +
'"wf_agc":%s,"wf_nf":%s,"band_idx":%d,"smeter_dbm":%.1f,' +
'"running":%s,"mute":%s,"ctun":%s,' +
'"nr_mode":%d,"nr":%s,"nb_mode":%d,"nb":%s,"snb":%s,"anf":%s,"connected":%s,' +
'"transmitting":%s,"drive":%d}',
[FFreq, FVfoB, FActiveVfo,
FMode, MODE_N[FMode mod 8],
FFilterIdx, FFilterBW,
FAGCMode, FAGCTop,
FSpanHz, FCenterHz, FVolume,
BoolToStr(FWfAGC, 'true', 'false'),
BoolToStr(FWfNF, 'true', 'false'),
FBandIdx, FSMeter,
BoolToStr(FTrxRunning, 'true', 'false'),
BoolToStr(FMuted, 'true', 'false'),
BoolToStr(FCtun, 'true', 'false'),
FNRMode,
BoolToStr(FNRMode <> 0, 'true', 'false'),
FNBMode,
BoolToStr(FNBMode <> 0, 'true', 'false'),
BoolToStr(FSNB, 'true', 'false'),
BoolToStr(FANF, 'true', 'false'),
BoolToStr(FConnected, 'true', 'false'),
BoolToStr(FTransmitting, 'true', 'false'),
FDriveLevel
]);
finally
FStateLock.Leave;
end;
end;
{ ═══════════════════════════════════════════════════════════════════════════
Аудио push (вызывается из DSP-потока)
═══════════════════════════════════════════════════════════════════════════ }
procedure TWebServer.PushAudio(const Samples: PSingle; Count: Integer);
var
HasWs: Boolean;
i, n, Enc: Integer;
Pkt: array of Byte;
begin
if not FRunning then Exit;
FClientLock.Enter;
HasWs := FClientCount > 0;
FClientLock.Leave;
if not HasWs then Exit;
if (Samples = nil) or (Count <= 0) then Exit;
if not FOpusReady then Exit;
i := 0;
while i < Count do
begin
n := Count - i;
if n > OPUS_FRAME_SAMP - FOpusBufPos then
n := OPUS_FRAME_SAMP - FOpusBufPos;
Move(Samples[i], FOpusBuf[FOpusBufPos], n * SizeOf(Single));
Inc(FOpusBufPos, n);
Inc(i, n);
if FOpusBufPos >= OPUS_FRAME_SAMP then
begin
Enc := FOpusEncode(FOpusEnc, @FOpusBuf[0], OPUS_FRAME_SAMP,
@FOpusOut[0], SizeOf(FOpusOut));
if Enc > 0 then
begin
SetLength(Pkt, 1 + Enc);
Pkt[0] := WS_MSG_AUDIO;
Move(FOpusOut[0], Pkt[1], Enc);
BroadcastBinary(Pkt[0], Length(Pkt));
end;
FOpusBufPos := 0;
end;
end;
end;
{ ═══════════════════════════════════════════════════════════════════════════
Обновление состояния из MainForm (UI thread, из таймера спектра)
═══════════════════════════════════════════════════════════════════════════ }
procedure TWebServer.PushSpectrum(
const Buf: array of Single; Count: Integer;
const WfBuf_: array of Single;
SMeter: Double;
Freq: Double; Mode, FilterBW, AGCMode, AGCTop: Integer;
SpanHz: Double; Volume: Integer;
WfAGC, WfNF: Boolean; BandIdx: Integer;
TrxConnected: Boolean;
TrxRunning, Muted, Ctun: Boolean;
NRMode, NBMode: Integer; SNB, ANF: Boolean;
CenterHz: Double; FilterIdx: Integer;
VfoB: Double; ActiveVfo: Integer;
Transmitting: Boolean; DriveLevel: Integer);
var N, i: Integer;
begin
if not FRunning then Exit;
N := Min(Count, 1024);
FStateLock.Enter;
try
for i := 0 to N-1 do FSpectrumBuf[i] := Buf[i];
for i := 0 to Min(High(WfBuf_), 1023) do FWfBuf[i] := WfBuf_[i];
FSMeter := SMeter;
FFreq := Freq;
FMode := Mode;
FFilterBW := FilterBW;
FAGCMode := AGCMode;
FAGCTop := AGCTop;
FSpanHz := SpanHz;
FVolume := Volume;
FWfAGC := WfAGC;
FWfNF := WfNF;
FBandIdx := BandIdx;
FConnected := TrxConnected;
FTrxRunning := TrxRunning;
FMuted := Muted;
FCtun := Ctun;
FNRMode := NRMode;
FNBMode := NBMode;
FSNB := SNB;
FANF := ANF;
FCenterHz := CenterHz;
FFilterIdx := FilterIdx;
FVfoB := VfoB;
FActiveVfo := ActiveVfo;
FTransmitting := Transmitting;
FDriveLevel := DriveLevel;
finally
FStateLock.Leave;
end;
end;
{ ═══════════════════════════════════════════════════════════════════════════
Stub-методы (реализация встроена в HandleClient)
═══════════════════════════════════════════════════════════════════════════ }
procedure TWebServer.DoHandshake(Client: TWsClient);
begin
// Not used separately — handshake is in HandleClient
end;
procedure TWebServer.ProcessWsFrame(Client: TWsClient;
const Data: array of Byte; Len: Integer; Opcode: Byte);
begin
// Not used separately — frame processing is inlined in HandleClient
end;
end.
Reference in New Issue View Git Blame Copy Permalink