mirror of
https://git.vladimir.cc/vladimir/ewsdr.git
synced 2026-08-25 17:27:32 +00:00
fix(tci): жизненный цикл, синхронизация слайсов и WebSocket по RFC
Разбор ревью ветки. Критичное — четыре отказа жизненного цикла и один пробел синхронизации. Use-after-free стора спотов: FTCIAdapter освобождается ДО FDXStore. Команда SPOT/SPOT_DELETE, пришедшая между их гибелью, обращалась к освобождённой памяти. Bind-адрес: TCIParseIPv4 стал строгим (out + Boolean, ровно четыре октета 0..255). Кривой адрес — отказ поднимать сокет, а не молчаливый INADDR_ANY: авторизации в TCI нет. В UI порт и адрес применяются по уходу фокуса и по Close, а не на каждую букву — набор «127.0.0.1» по дороге проходил через «127.0.0.» и открывал порт наружу. Остановка при висящем Synchronize: флаг Stopping (адаптер не начинает новых Invoke), прокачка CheckSynchronize в цикле ожидания Stop и запрет освобождать клиента, чей поток не вышел. Владение переделано: клиента освобождает только тик-поток (ReapClients), клиентский лишь помечает себя закрытым. Отправка больше не блокирует вызывающего: Send/Broadcast кладут строку в очередь клиента, в сокет пишет тик-поток вне общего лока, склеивая очередь в общие кадры. Медленный клиент морозил UI на таймаут отправки за каждое движение ручки VFO; теперь он просто вылетает. Слайсы: в контроллере появилось rfSliceState (нагрузка — FSliceFreqId), его шлют сами сеттеры слайса; SyncSetVfo зовёт SliceFreqChanged, как CAT. Адаптер разворачивает Id в пару (приёмник, канал) и рассылает состояние именно этого канала, а не канала 0 каждого пана. WebSocket по RFC 6455: маска обязательна, FIN/continuation собираются, RSV и незнакомые opcode рвут соединение, control-кадры ≤125 и только целиком, 64-битная длина не сворачивается в отрицательный Integer, пустой Sec-WebSocket-Key получает 400. Хвост пакета handshake больше не выбрасывается — первая команда не теряется. Клиент после исключения в разборе не остаётся висеть в массиве. Ещё: DSP и squelch доп. приёмников читаются и пишутся из TCtrlSlice (парные сеттеры сохраняли соседние поля значениями главного тракта); параметры потоков — в TTCIClient, они клиентские по спецификации; эхо под своим локом; ApplySettings возвращает результат, отказ старта виден оператору; инициализация объявляет только существующие каналы; SET_IN_FOCUS реализован через OnFocusRequest. Осознанно не сделано и записано в doc/TCI.md §3.1: AGC_GAIN для приёмников >0 (AGC-T один на тракт), цвет спота, KEYER, TX_FOOTSWITCH, арбитраж нескольких клиентов. Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
This commit is contained in:
Claude Opus 5
+402
-99
@@ -15,6 +15,16 @@ unit TCIServer;
|
||||
• тикает OnTick (умолчание 20 мс) — по нему адаптер шлёт показания
|
||||
измерителей с индивидуальным для каждого клиента периодом.
|
||||
|
||||
Отправка НИКОГДА не блокирует того, кто зовёт Send/Broadcast: строка кладётся
|
||||
в очередь клиента, а в сокет её пишет тик-поток (FlushClients). Иначе
|
||||
медленный клиент останавливал бы UI-поток на секунду за раз — уведомления
|
||||
рождаются в OnState, то есть внутри Changed() контроллера.
|
||||
|
||||
Владение объектом клиента: создаёт accept-поток, освобождает ТОЛЬКО тик-поток
|
||||
(ReapClients) и только после того, как клиентский поток честно вышел. Никто
|
||||
больше клиентов не освобождает — поэтому указатель, взятый под FClientLock,
|
||||
остаётся валидным, пока тик-поток не сделает следующий проход.
|
||||
|
||||
Бинарные фреймы (потоки IQ/аудио, §3.4) пока не обрабатываются: этап 2,
|
||||
см. doc/TCI.md. Приходящие от клиента binary-фреймы молча отбрасываются.
|
||||
|
||||
@@ -43,14 +53,20 @@ const
|
||||
TCI_MAX_CLIENTS = 8;
|
||||
TCI_TICK_MS = 20; // период OnTick (сенсоры троттлятся адаптером)
|
||||
TCI_WS_GUID = '258EAFA5-E914-47DA-95CA-C5AB0DC85B11';
|
||||
TCI_SEND_TIMEOUT = 1000; // мс на SockSend, иначе клиент считается мёртвым
|
||||
TCI_SEND_TIMEOUT = 300; // мс на SockSend, иначе клиент считается мёртвым
|
||||
TCI_OUT_MAX = 4000; // потолок очереди отправки на клиента (строк)
|
||||
TCI_OUT_CHUNK = 3800; // склейка очереди в один фрейм, символов
|
||||
TCI_MSG_MAX = 65536; // потолок собираемого из фрагментов сообщения
|
||||
TCI_STOP_WAIT_MS = 10000; // сколько ждём выхода клиентских потоков в Stop
|
||||
|
||||
type
|
||||
TTCIServer = class;
|
||||
|
||||
{ Один подключённый клиент: WS-сокет + его личные подписки. Подписки на
|
||||
сенсоры в TCI индивидуальны (RX_SENSORS_ENABLE «отправляется только
|
||||
клиентом»), поэтому живут здесь, а не в адаптере. }
|
||||
{ Один подключённый клиент: WS-сокет, его личные подписки и очередь
|
||||
отправки. Подписки на сенсоры в TCI индивидуальны (RX_SENSORS_ENABLE
|
||||
«отправляется только клиентом»), поэтому живут здесь, а не в адаптере.
|
||||
Параметры потоков (§4.3) — тоже клиентские, их держит адаптер по ссылке
|
||||
на этот объект. }
|
||||
TTCIClient = class
|
||||
private
|
||||
FWs: TWsClient;
|
||||
@@ -61,18 +77,45 @@ type
|
||||
FTxSensors: Boolean;
|
||||
FTxSensorsMs: Integer;
|
||||
FTxSensorsAt: QWord;
|
||||
// Параметры бинарных потоков (§3.4): по спецификации это настройки
|
||||
// КЛИЕНТА, а не устройства — свои у каждого подключения.
|
||||
FIQRate: Integer;
|
||||
FAudioRate: Integer;
|
||||
FAudioSamples: Integer;
|
||||
FAudioChannels: Integer;
|
||||
FAudioSampleType: string;
|
||||
FTxBuffering: Integer;
|
||||
// Очередь отправки: пишут любые потоки, читает тик-поток.
|
||||
FOutLock: TCriticalSection;
|
||||
FOut: array of string;
|
||||
FOutCount: Integer;
|
||||
FDead: Boolean; // сокет уже не пишется — гасим соединение
|
||||
FKilled: Boolean; // shutdown сокета уже сделан
|
||||
FClosed: Boolean; // клиентский поток вышел (можно освобождать)
|
||||
public
|
||||
constructor Create(AWs: TWsClient);
|
||||
{ Текстовый фрейм клиенту. False — соединение уже мертво. }
|
||||
function Send(const S: string): Boolean;
|
||||
destructor Destroy; override;
|
||||
{ Строку в очередь клиенту. False — соединение уже мертво. Не блокирует. }
|
||||
function Send(const S: string): Boolean;
|
||||
{ Слить очередь в сокет. Зовёт только тик-поток. False — клиент умер. }
|
||||
function Flush: Boolean;
|
||||
{ Пометить мёртвым и разбудить его поток (shutdown сокета). }
|
||||
procedure Kill;
|
||||
property Ws: TWsClient read FWs;
|
||||
property Ready: Boolean read FReady write FReady;
|
||||
property Dead: Boolean read FDead;
|
||||
property RxSensors: Boolean read FRxSensors write FRxSensors;
|
||||
property RxSensorsMs: Integer read FRxSensorsMs write FRxSensorsMs;
|
||||
property RxSensorsAt: QWord read FRxSensorsAt write FRxSensorsAt;
|
||||
property TxSensors: Boolean read FTxSensors write FTxSensors;
|
||||
property TxSensorsMs: Integer read FTxSensorsMs write FTxSensorsMs;
|
||||
property TxSensorsAt: QWord read FTxSensorsAt write FTxSensorsAt;
|
||||
property IQRate: Integer read FIQRate write FIQRate;
|
||||
property AudioRate: Integer read FAudioRate write FAudioRate;
|
||||
property AudioSamples: Integer read FAudioSamples write FAudioSamples;
|
||||
property AudioChannels: Integer read FAudioChannels write FAudioChannels;
|
||||
property AudioSampleType: string read FAudioSampleType write FAudioSampleType;
|
||||
property TxBuffering: Integer read FTxBuffering write FTxBuffering;
|
||||
end;
|
||||
|
||||
TTCIClientEvent = procedure(Client: TTCIClient) of object;
|
||||
@@ -88,6 +131,7 @@ type
|
||||
FTickThread: TThread;
|
||||
FThreadCount: LongInt; // живых клиентских потоков (Interlocked*)
|
||||
FRunning: Boolean;
|
||||
FStopping: Boolean;
|
||||
FPort: Word;
|
||||
FBindIP: string;
|
||||
FOnCommand: TTCICommandEvent;
|
||||
@@ -95,13 +139,15 @@ type
|
||||
FOnDisconnect: TTCIClientEvent;
|
||||
FOnTick: TThreadMethod;
|
||||
function InitListen: Boolean;
|
||||
procedure RemoveClient(Client: TTCIClient);
|
||||
procedure ReapClients; // освободить клиентов, чьи потоки вышли
|
||||
procedure FlushClients; // слить очереди в сокеты (вне FClientLock)
|
||||
public
|
||||
constructor Create;
|
||||
destructor Destroy; override;
|
||||
|
||||
{ Настройка слушателя. Применяется при следующем Start. }
|
||||
procedure Configure(APort: Word; const ABindIP: string);
|
||||
{ Настройка слушателя. Применяется при следующем Start.
|
||||
False — адрес не разобран (порт не откроется). }
|
||||
function Configure(APort: Word; const ABindIP: string): Boolean;
|
||||
|
||||
function Start: Boolean;
|
||||
procedure Stop;
|
||||
@@ -109,10 +155,11 @@ type
|
||||
|
||||
{ Всем клиентам, прошедшим инициализацию. Skip — кого пропустить
|
||||
(обычно автора изменения не пропускаем: сервер отвечает и ему тоже,
|
||||
это и есть подтверждение установки). }
|
||||
это и есть подтверждение установки). Только кладёт в очереди. }
|
||||
procedure Broadcast(const S: string; Skip: TTCIClient = nil);
|
||||
|
||||
{ Обход клиентов под локом — для рассылки с индивидуальным периодом. }
|
||||
{ Обход клиентов под локом — для рассылки с индивидуальным периодом.
|
||||
Proc обязана быть быстрой: она держит FClientLock. }
|
||||
procedure EnumClients(Proc: TTCIClientEvent);
|
||||
|
||||
function ClientCount: Integer;
|
||||
@@ -123,14 +170,23 @@ type
|
||||
procedure HandleClient(Client: TTCIClient);
|
||||
procedure ThreadDone; // клиентский поток отработал
|
||||
|
||||
property Port: Word read FPort;
|
||||
property BindIP: string read FBindIP;
|
||||
property Port: Word read FPort;
|
||||
property BindIP: string read FBindIP;
|
||||
{ Идёт остановка: адаптер не должен начинать новых вызовов в поток
|
||||
контроллера — тот, кто нас останавливает, обычно и есть поток
|
||||
контроллера, и Synchronize из клиентского потока в него не вернётся. }
|
||||
property Stopping: Boolean read FStopping;
|
||||
property OnCommand: TTCICommandEvent read FOnCommand write FOnCommand;
|
||||
property OnConnect: TTCIClientEvent read FOnConnect write FOnConnect;
|
||||
property OnDisconnect: TTCIClientEvent read FOnDisconnect write FOnDisconnect;
|
||||
property OnTick: TThreadMethod read FOnTick write FOnTick;
|
||||
end;
|
||||
|
||||
{ IPv4 из строки в сетевом порядке. Строгий: ровно четыре десятичных октета
|
||||
0..255. '' и '0.0.0.0' — это INADDR_ANY (слушать везде), и только они:
|
||||
«ошибка разбора = слушаем всё» в протоколе без авторизации недопустима. }
|
||||
function TCIParseIPv4(const S: string; out Addr: LongWord): Boolean;
|
||||
|
||||
implementation
|
||||
|
||||
type
|
||||
@@ -187,36 +243,51 @@ end;
|
||||
procedure TTCIClientThread.Execute;
|
||||
begin
|
||||
try
|
||||
FServer.HandleClient(FClient);
|
||||
try
|
||||
FServer.HandleClient(FClient);
|
||||
except
|
||||
// Разбор фрейма рухнул — соединение всё равно закрываем штатно, иначе
|
||||
// клиент остался бы висеть в массиве до остановки сервера.
|
||||
end;
|
||||
finally
|
||||
FServer.ThreadDone; // Stop ждёт обнуления счётчика перед зачисткой
|
||||
// Освобождать себя нельзя: объект переиспользуется рассылкой из чужих
|
||||
// потоков. Помечаем «поток вышел» — освободит тик-поток (ReapClients).
|
||||
FClient.FClosed := True;
|
||||
FServer.ThreadDone;
|
||||
end;
|
||||
end;
|
||||
|
||||
{ IPv4 из строки в сетевом порядке. Свой, потому что WebServer держит такой же
|
||||
в implementation и наружу не отдаёт. }
|
||||
function TCIParseIPv4(const S: string): LongWord;
|
||||
function TCIParseIPv4(const S: string; out Addr: LongWord): Boolean;
|
||||
var
|
||||
Oct: array[0..3] of LongWord;
|
||||
N, i, Start: Integer;
|
||||
N, i, Start, V: Integer;
|
||||
Part: string;
|
||||
c: Char;
|
||||
begin
|
||||
Result := 0; // INADDR_ANY
|
||||
if (S = '') or (S = '0.0.0.0') then Exit;
|
||||
Addr := 0; // INADDR_ANY
|
||||
Result := False;
|
||||
if (Trim(S) = '') or (Trim(S) = '0.0.0.0') then Exit(True);
|
||||
|
||||
N := 0;
|
||||
Start := 1;
|
||||
for i := 1 to Length(S) + 1 do
|
||||
if (i > Length(S)) or (S[i] = '.') then
|
||||
begin
|
||||
if N > 3 then Exit;
|
||||
if N > 3 then Exit(False);
|
||||
Part := Copy(S, Start, i - Start);
|
||||
Oct[N] := LongWord(StrToIntDef(Part, 0)) and $FF;
|
||||
if (Part = '') or (Length(Part) > 3) then Exit(False);
|
||||
for c in Part do
|
||||
if (c < '0') or (c > '9') then Exit(False);
|
||||
V := StrToIntDef(Part, -1);
|
||||
if (V < 0) or (V > 255) then Exit(False);
|
||||
Oct[N] := LongWord(V);
|
||||
Inc(N);
|
||||
Start := i + 1;
|
||||
end;
|
||||
if N <> 4 then Exit;
|
||||
if N <> 4 then Exit(False);
|
||||
// Сетевой порядок байт: первый октет — младший байт in_addr.
|
||||
Result := Oct[0] or (Oct[1] shl 8) or (Oct[2] shl 16) or (Oct[3] shl 24);
|
||||
Addr := Oct[0] or (Oct[1] shl 8) or (Oct[2] shl 16) or (Oct[3] shl 24);
|
||||
Result := True;
|
||||
end;
|
||||
|
||||
{ ═══════════════════════════════════════════════════════════════════════════
|
||||
@@ -232,11 +303,109 @@ begin
|
||||
FRxSensorsMs := 200;
|
||||
FTxSensors := False;
|
||||
FTxSensorsMs := 200;
|
||||
FOutLock := TCriticalSection.Create;
|
||||
FOutCount := 0;
|
||||
SetLength(FOut, 64);
|
||||
// Умолчания параметров потоков — как в §4.3 (клиент их обычно переопределяет).
|
||||
FIQRate := 48000;
|
||||
FAudioRate := 48000;
|
||||
FAudioSamples := 2048;
|
||||
FAudioChannels := 2;
|
||||
FAudioSampleType := 'float32';
|
||||
FTxBuffering := 50;
|
||||
end;
|
||||
|
||||
destructor TTCIClient.Destroy;
|
||||
begin
|
||||
FOutLock.Free;
|
||||
inherited;
|
||||
end;
|
||||
|
||||
function TTCIClient.Send(const S: string): Boolean;
|
||||
begin
|
||||
Result := (FWs <> nil) and (FWs.State = wsOpen) and FWs.SendText(S);
|
||||
Result := False;
|
||||
if (S = '') or FDead or (FWs = nil) then Exit;
|
||||
FOutLock.Enter;
|
||||
try
|
||||
if FDead then Exit;
|
||||
// Очередь переполнилась: клиент не читает сокет быстрее, чем мы пишем.
|
||||
// Копить дальше нечестно (память + отставшее состояние), рвём соединение.
|
||||
if FOutCount >= TCI_OUT_MAX then
|
||||
begin
|
||||
FDead := True;
|
||||
Exit;
|
||||
end;
|
||||
if FOutCount >= Length(FOut) then SetLength(FOut, Length(FOut) * 2);
|
||||
FOut[FOutCount] := S;
|
||||
Inc(FOutCount);
|
||||
Result := True;
|
||||
finally
|
||||
FOutLock.Leave;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TTCIClient.Flush: Boolean;
|
||||
var
|
||||
Batch: array of string;
|
||||
N, i: Integer;
|
||||
Chunk: string;
|
||||
begin
|
||||
Result := not FDead;
|
||||
// Мёртвым клиента могла пометить и очередь (переполнилась в чужом потоке —
|
||||
// там гасить сокет нельзя, лок чужой). Добиваем здесь: без shutdown его
|
||||
// поток так и висел бы в recv, а объект никогда бы не освободился.
|
||||
if FDead then begin Kill; Exit; end;
|
||||
|
||||
FOutLock.Enter;
|
||||
try
|
||||
N := FOutCount;
|
||||
if N > 0 then
|
||||
begin
|
||||
SetLength(Batch, N);
|
||||
for i := 0 to N - 1 do
|
||||
begin
|
||||
Batch[i] := FOut[i];
|
||||
FOut[i] := '';
|
||||
end;
|
||||
FOutCount := 0;
|
||||
end;
|
||||
finally
|
||||
FOutLock.Leave;
|
||||
end;
|
||||
if N = 0 then Exit;
|
||||
|
||||
// Склейка: несколько команд в одном фрейме протокол разрешает (§3.1), а
|
||||
// syscall'ов и заголовков становится в разы меньше.
|
||||
Chunk := '';
|
||||
for i := 0 to N - 1 do
|
||||
begin
|
||||
if (Chunk <> '') and (Length(Chunk) + Length(Batch[i]) > TCI_OUT_CHUNK) then
|
||||
begin
|
||||
if not FWs.SendText(Chunk) then begin Kill; Exit(False); end;
|
||||
Chunk := '';
|
||||
end;
|
||||
Chunk := Chunk + Batch[i];
|
||||
end;
|
||||
if Chunk <> '' then
|
||||
if not FWs.SendText(Chunk) then begin Kill; Exit(False); end;
|
||||
end;
|
||||
|
||||
procedure TTCIClient.Kill;
|
||||
begin
|
||||
FOutLock.Enter;
|
||||
try
|
||||
FDead := True;
|
||||
FOutCount := 0;
|
||||
if FKilled then Exit; // shutdown уже был — второй раз незачем
|
||||
FKilled := True;
|
||||
finally
|
||||
FOutLock.Leave;
|
||||
end;
|
||||
if FWs <> nil then
|
||||
begin
|
||||
FWs.State := wsClosed;
|
||||
SockShutdown(FWs.Socket); // будим поток клиента, висящий в recv
|
||||
end;
|
||||
end;
|
||||
|
||||
{ ═══════════════════════════════════════════════════════════════════════════
|
||||
@@ -269,10 +438,12 @@ begin
|
||||
inherited;
|
||||
end;
|
||||
|
||||
procedure TTCIServer.Configure(APort: Word; const ABindIP: string);
|
||||
function TTCIServer.Configure(APort: Word; const ABindIP: string): Boolean;
|
||||
var Dummy: LongWord;
|
||||
begin
|
||||
FPort := APort;
|
||||
FBindIP := ABindIP;
|
||||
Result := (APort <> 0) and TCIParseIPv4(ABindIP, Dummy);
|
||||
end;
|
||||
|
||||
function TTCIServer.Running: Boolean;
|
||||
@@ -284,8 +455,14 @@ function TTCIServer.InitListen: Boolean;
|
||||
var
|
||||
Addr: {$IFDEF WINDOWS}TSockAddrIn{$ELSE}TInetSockAddr{$ENDIF};
|
||||
One: Integer;
|
||||
IP: LongWord;
|
||||
begin
|
||||
Result := False;
|
||||
// Кривой адрес — отказ. Молча свалиться в INADDR_ANY нельзя: в TCI нет
|
||||
// авторизации, и открытый наружу порт отдаёт управление передатчиком.
|
||||
if not TCIParseIPv4(FBindIP, IP) then Exit;
|
||||
if FPort = 0 then Exit;
|
||||
|
||||
{$IFDEF WINDOWS}
|
||||
FListenSock := socket(AF_INET, SOCK_STREAM, IPPROTO_TCP);
|
||||
{$ELSE}
|
||||
@@ -299,7 +476,7 @@ begin
|
||||
FillChar(Addr, SizeOf(Addr), 0);
|
||||
Addr.sin_family := AF_INET;
|
||||
Addr.sin_port := htons(FPort);
|
||||
Addr.sin_addr.S_addr := TCIParseIPv4(FBindIP);
|
||||
Addr.sin_addr.S_addr := IP;
|
||||
if bind(FListenSock, @Addr, SizeOf(Addr)) = SOCKET_ERROR then Exit;
|
||||
if listen(FListenSock, 5) = SOCKET_ERROR then Exit;
|
||||
{$ELSE}
|
||||
@@ -307,7 +484,7 @@ begin
|
||||
FillChar(Addr, SizeOf(Addr), 0);
|
||||
Addr.sin_family := AF_INET;
|
||||
Addr.sin_port := htons(FPort);
|
||||
Addr.sin_addr.s_addr := TCIParseIPv4(FBindIP);
|
||||
Addr.sin_addr.s_addr := IP;
|
||||
if fpBind(FListenSock, @Addr, SizeOf(Addr)) <> 0 then Exit;
|
||||
if fpListen(FListenSock, 5) <> 0 then Exit;
|
||||
{$ENDIF}
|
||||
@@ -327,7 +504,8 @@ begin
|
||||
end;
|
||||
Exit;
|
||||
end;
|
||||
FRunning := True;
|
||||
FStopping := False;
|
||||
FRunning := True;
|
||||
FAcceptThread := TTCIAcceptThread.Create(Self);
|
||||
TTCIAcceptThread(FAcceptThread).Start;
|
||||
FTickThread := TTCITickThread.Create(Self);
|
||||
@@ -339,7 +517,8 @@ procedure TTCIServer.Stop;
|
||||
var i, Waited: Integer;
|
||||
begin
|
||||
if not FRunning then Exit;
|
||||
FRunning := False;
|
||||
FStopping := True; // адаптер перестаёт звать Invoke (см. property Stopping)
|
||||
FRunning := False;
|
||||
|
||||
// Шаг 1: гасим listen-сокет. SockShutdown обязателен до close — иначе
|
||||
// fpAccept в accept-потоке не разблокируется (см. WebServer.Stop).
|
||||
@@ -354,11 +533,7 @@ begin
|
||||
FClientLock.Enter;
|
||||
try
|
||||
for i := 0 to FClientCount - 1 do
|
||||
if FClients[i] <> nil then
|
||||
begin
|
||||
FClients[i].Ws.State := wsClosed;
|
||||
SockShutdown(FClients[i].Ws.Socket);
|
||||
end;
|
||||
if FClients[i] <> nil then FClients[i].Kill;
|
||||
finally
|
||||
FClientLock.Leave;
|
||||
end;
|
||||
@@ -367,22 +542,24 @@ begin
|
||||
if FAcceptThread <> nil then begin FAcceptThread.WaitFor; FreeAndNil(FAcceptThread); end;
|
||||
if FTickThread <> nil then begin FTickThread.WaitFor; FreeAndNil(FTickThread); end;
|
||||
|
||||
// Шаг 4: даём клиентским потокам выйти самим. Освобождает клиента ТОТ,
|
||||
// кто вынул его из массива (RemoveClient в клиентском потоке), — иначе
|
||||
// Stop освободил бы объект из-под работающего потока.
|
||||
// Шаг 4: ждём выхода клиентских потоков. Прокачивая очередь Synchronize:
|
||||
// Stop зовёт поток контроллера (UI), а клиентский поток может как раз в нём
|
||||
// висеть на FController.Invoke. Без прокачки это гарантированный взаимный
|
||||
// клин, а по его истечении — освобождение объекта из-под живого потока.
|
||||
Waited := 0;
|
||||
while (FThreadCount > 0) and (Waited < 2000) do
|
||||
while (FThreadCount > 0) and (Waited < TCI_STOP_WAIT_MS) do
|
||||
begin
|
||||
Sleep(10);
|
||||
Inc(Waited, 10);
|
||||
if GetCurrentThreadId = MainThreadID then CheckSynchronize(5) else Sleep(5);
|
||||
Inc(Waited, 5);
|
||||
end;
|
||||
|
||||
// Вырожденный случай: поток завис (не должно случаться — сокеты закрыты).
|
||||
// Чистим остатки, чтобы не течь; объекты уже никем не используются.
|
||||
// Шаг 5: зачистка. Если поток всё же не вышел (не должно случаться: сокеты
|
||||
// закрыты, очередь прокачана), объект НЕ освобождаем — утечка на выходе
|
||||
// несравнимо дешевле обращения к освобождённой памяти из живого потока.
|
||||
FClientLock.Enter;
|
||||
try
|
||||
for i := 0 to FClientCount - 1 do
|
||||
if FClients[i] <> nil then
|
||||
if (FClients[i] <> nil) and FClients[i].FClosed then
|
||||
begin
|
||||
FClients[i].Ws.Free;
|
||||
FreeAndNil(FClients[i]);
|
||||
@@ -404,6 +581,7 @@ var
|
||||
ALen: {$IFDEF WINDOWS}Integer{$ELSE}TSockLen{$ENDIF};
|
||||
Client: TTCIClient;
|
||||
T: TTCIClientThread;
|
||||
Full: Boolean;
|
||||
begin
|
||||
while FRunning do
|
||||
begin
|
||||
@@ -418,46 +596,96 @@ begin
|
||||
if FRunning then Sleep(10);
|
||||
Continue;
|
||||
end;
|
||||
if FClientCount >= TCI_MAX_CLIENTS then
|
||||
if not FRunning then
|
||||
begin
|
||||
SockClose(CSock);
|
||||
Continue;
|
||||
Break;
|
||||
end;
|
||||
|
||||
SockSetSndTimeout(CSock, TCI_SEND_TIMEOUT);
|
||||
Client := TTCIClient.Create(TWsClient.Create(CSock));
|
||||
Full := False;
|
||||
FClientLock.Enter;
|
||||
try
|
||||
FClients[FClientCount] := Client;
|
||||
Inc(FClientCount);
|
||||
// Слот берём под локом: место в массиве освобождает тик-поток.
|
||||
if FClientCount >= TCI_MAX_CLIENTS then Full := True
|
||||
else
|
||||
begin
|
||||
FClients[FClientCount] := Client;
|
||||
Inc(FClientCount);
|
||||
end;
|
||||
finally
|
||||
FClientLock.Leave;
|
||||
end;
|
||||
if Full then
|
||||
begin
|
||||
Client.Ws.Free; // закрывает сокет
|
||||
Client.Free;
|
||||
Continue;
|
||||
end;
|
||||
|
||||
InterLockedIncrement(FThreadCount);
|
||||
T := TTCIClientThread.Create(Self, Client);
|
||||
T.Start;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTCIServer.RemoveClient(Client: TTCIClient);
|
||||
var i, j: Integer;
|
||||
procedure TTCIServer.ReapClients;
|
||||
// Освобождение клиентов — единственное место во всей программе. Зовёт только
|
||||
// тик-поток, поэтому указатель, взятый кем угодно под FClientLock, живёт до
|
||||
// следующего прохода тика (а вне лока указателей никто не держит).
|
||||
var
|
||||
i, j, N: Integer;
|
||||
Doomed: array[0..TCI_MAX_CLIENTS-1] of TTCIClient;
|
||||
begin
|
||||
if Client = nil then Exit;
|
||||
if Assigned(FOnDisconnect) then FOnDisconnect(Client);
|
||||
N := 0;
|
||||
FClientLock.Enter;
|
||||
try
|
||||
for i := 0 to FClientCount - 1 do
|
||||
if FClients[i] = Client then
|
||||
i := 0;
|
||||
while i < FClientCount do
|
||||
if (FClients[i] <> nil) and FClients[i].FClosed then
|
||||
begin
|
||||
Doomed[N] := FClients[i];
|
||||
Inc(N);
|
||||
for j := i to FClientCount - 2 do FClients[j] := FClients[j + 1];
|
||||
FClients[FClientCount - 1] := nil;
|
||||
Dec(FClientCount);
|
||||
Break;
|
||||
end
|
||||
else
|
||||
Inc(i);
|
||||
finally
|
||||
FClientLock.Leave;
|
||||
end;
|
||||
|
||||
for i := 0 to N - 1 do
|
||||
begin
|
||||
if Assigned(FOnDisconnect) then FOnDisconnect(Doomed[i]);
|
||||
Doomed[i].Ws.Free; // закрывает сокет
|
||||
Doomed[i].Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTCIServer.FlushClients;
|
||||
// Запись в сокеты — вне FClientLock: медленный клиент не должен держать лок,
|
||||
// иначе Broadcast из потока контроллера снова начнёт ждать сеть.
|
||||
var
|
||||
Snap: array[0..TCI_MAX_CLIENTS-1] of TTCIClient;
|
||||
i, N: Integer;
|
||||
begin
|
||||
N := 0;
|
||||
FClientLock.Enter;
|
||||
try
|
||||
for i := 0 to FClientCount - 1 do
|
||||
if (FClients[i] <> nil) and not FClients[i].FClosed then
|
||||
begin
|
||||
Snap[N] := FClients[i];
|
||||
Inc(N);
|
||||
end;
|
||||
finally
|
||||
FClientLock.Leave;
|
||||
end;
|
||||
Client.Ws.Free; // закрывает сокет
|
||||
Client.Free;
|
||||
for i := 0 to N - 1 do
|
||||
Snap[i].Flush;
|
||||
end;
|
||||
|
||||
{ ═══════════════════════════════════════════════════════════════════════════
|
||||
@@ -470,13 +698,15 @@ var
|
||||
R, HeaderEnd: Integer;
|
||||
Header, HeaderLC, Key, AcceptKey, Response, Text: string;
|
||||
Raw: array[0..4095] of Byte;
|
||||
RawLen: Integer;
|
||||
RawLen, Rest: Integer;
|
||||
B0, B1: Byte;
|
||||
Masked: Boolean;
|
||||
Masked, Fin, Pending: Boolean;
|
||||
PayLen, Need, i, j, Consumed, KPos, KEnd: Integer;
|
||||
Hi32: LongWord;
|
||||
Mask: array[0..3] of Byte;
|
||||
Payload: array of Byte;
|
||||
Opcode: Byte;
|
||||
Opcode, MsgOp: Byte;
|
||||
Frag: string;
|
||||
Cmds: TStringList;
|
||||
begin
|
||||
Ws := Client.Ws;
|
||||
@@ -494,12 +724,10 @@ begin
|
||||
HeaderEnd := System.Pos(#13#10#13#10, Header);
|
||||
until (HeaderEnd > 0) or (RawLen >= SizeOf(Raw));
|
||||
|
||||
if (Ws.State = wsClosed) or (HeaderEnd = 0) then
|
||||
begin
|
||||
RemoveClient(Client); Exit;
|
||||
end;
|
||||
if (Ws.State = wsClosed) or (HeaderEnd = 0) then Exit;
|
||||
|
||||
Header := Copy(Header, 1, HeaderEnd + 3);
|
||||
Consumed := HeaderEnd + 3; // длина заголовков вместе с CRLFCRLF
|
||||
Header := Copy(Header, 1, Consumed);
|
||||
HeaderLC := LowerCase(Header);
|
||||
|
||||
// Путь не проверяем: клиенты ходят на '/', но протокол его не оговаривает.
|
||||
@@ -508,7 +736,7 @@ begin
|
||||
Response := 'HTTP/1.1 426 Upgrade Required'#13#10 +
|
||||
'Content-Length: 0'#13#10'Connection: close'#13#10#13#10;
|
||||
Ws.SendRaw(Response[1], Length(Response));
|
||||
RemoveClient(Client); Exit;
|
||||
Exit;
|
||||
end;
|
||||
|
||||
Key := '';
|
||||
@@ -520,37 +748,60 @@ begin
|
||||
if KEnd > 0 then Key := Copy(Key, 1, KEnd - 1);
|
||||
Key := Trim(Key);
|
||||
end;
|
||||
// Пустой ключ = не WebSocket-клиент (или сломанный): Accept без ключа
|
||||
// формально считается валидным, и такое «соединение» потом молча висит.
|
||||
if Key = '' then
|
||||
begin
|
||||
Response := 'HTTP/1.1 400 Bad Request'#13#10 +
|
||||
'Content-Length: 0'#13#10'Connection: close'#13#10#13#10;
|
||||
Ws.SendRaw(Response[1], Length(Response));
|
||||
Exit;
|
||||
end;
|
||||
|
||||
AcceptKey := Base64EncodeBytes(SHA1(Key + TCI_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;
|
||||
if not Ws.SendRaw(Response[1], Length(Response)) then
|
||||
begin
|
||||
RemoveClient(Client); Exit;
|
||||
end;
|
||||
if not Ws.SendRaw(Response[1], Length(Response)) then Exit;
|
||||
Ws.State := wsOpen;
|
||||
|
||||
// Хвост первого пакета: клиент вправе прислать первый WS-фрейм в том же
|
||||
// сегменте, что и заголовки. Выбросить его — потерять первую команду.
|
||||
Rest := RawLen - Consumed;
|
||||
if Rest > 0 then Move(Raw[Consumed], Ws.BufData[0], Rest);
|
||||
Ws.BufLen := Rest;
|
||||
|
||||
// Пачка инициализации + текущее состояние (§3.1) — дело адаптера.
|
||||
if Assigned(FOnConnect) then FOnConnect(Client);
|
||||
|
||||
// ── Цикл WS-сообщений ────────────────────────────────────────────────────
|
||||
Cmds := TStringList.Create;
|
||||
Cmds := TStringList.Create;
|
||||
Frag := '';
|
||||
MsgOp := 0;
|
||||
Pending := Rest > 0; // хвост handshake разбираем до первого recv
|
||||
try
|
||||
Ws.BufLen := 0;
|
||||
while FRunning and (Ws.State = wsOpen) do
|
||||
while FRunning and (Ws.State = wsOpen) and not Client.Dead do
|
||||
begin
|
||||
R := Ws.Recv;
|
||||
if R <= 0 then Break;
|
||||
if not Pending then
|
||||
begin
|
||||
R := Ws.Recv;
|
||||
if R <= 0 then Break;
|
||||
end;
|
||||
Pending := False;
|
||||
|
||||
while Ws.BufLen >= 2 do
|
||||
begin
|
||||
B0 := Ws.BufData[0];
|
||||
B1 := Ws.BufData[1];
|
||||
Fin := (B0 and $80) <> 0;
|
||||
Opcode := B0 and $0F;
|
||||
Masked := (B1 and $80) <> 0;
|
||||
PayLen := B1 and $7F;
|
||||
|
||||
// RSV1..3 без согласованных расширений обязаны быть нулями.
|
||||
if (B0 and $70) <> 0 then begin Ws.State := wsClosed; Break; end;
|
||||
|
||||
Need := 2;
|
||||
if PayLen = 126 then Inc(Need, 2)
|
||||
else if PayLen = 127 then Inc(Need, 8);
|
||||
@@ -565,16 +816,34 @@ begin
|
||||
end
|
||||
else if PayLen = 127 then
|
||||
begin
|
||||
PayLen := (Ws.BufData[6] shl 24) or (Ws.BufData[7] shl 16) or
|
||||
(Ws.BufData[8] shl 8) or Ws.BufData[9];
|
||||
// 64-битная длина: старшие четыре байта обязаны быть нулём, иначе
|
||||
// значение не помещается в Integer и превращается в отрицательное.
|
||||
Hi32 := (LongWord(Ws.BufData[2]) shl 24) or (LongWord(Ws.BufData[3]) shl 16) or
|
||||
(LongWord(Ws.BufData[4]) shl 8) or LongWord(Ws.BufData[5]);
|
||||
if Hi32 <> 0 then begin Ws.State := wsClosed; Break; end;
|
||||
Hi32 := (LongWord(Ws.BufData[6]) shl 24) or (LongWord(Ws.BufData[7]) shl 16) or
|
||||
(LongWord(Ws.BufData[8]) shl 8) or LongWord(Ws.BufData[9]);
|
||||
if Hi32 > LongWord(SizeOf(Raw)) then begin Ws.State := wsClosed; Break; end;
|
||||
PayLen := Integer(Hi32);
|
||||
Inc(i, 8);
|
||||
end;
|
||||
|
||||
// Клиент ОБЯЗАН маскировать (RFC 6455 §5.1). Незамаскированный кадр —
|
||||
// либо не клиент, либо попытка прогнать через нас чужой трафик.
|
||||
if not Masked then begin Ws.State := wsClosed; Break; end;
|
||||
|
||||
// Управляющие кадры: только короткие и только целиком (§5.5).
|
||||
if (Opcode >= $08) and ((PayLen > 125) or (not Fin)) then
|
||||
begin
|
||||
Ws.State := wsClosed;
|
||||
Break;
|
||||
end;
|
||||
|
||||
// Фрейм крупнее приёмного буфера TWsClient никогда не соберётся —
|
||||
// BufLen упрётся в потолок и цикл встанет намертво. Рвём соединение:
|
||||
// команд такой длины у TCI нет, а бинарные потоки от клиента (TX-аудио)
|
||||
// мы пока не принимаем.
|
||||
if Need + PayLen > 4096 then
|
||||
if Need + PayLen > SizeOf(Raw) then
|
||||
begin
|
||||
Ws.State := wsClosed;
|
||||
Break;
|
||||
@@ -582,20 +851,16 @@ begin
|
||||
|
||||
if Ws.BufLen < Need + PayLen then Break;
|
||||
|
||||
if Masked then
|
||||
begin
|
||||
Mask[0] := Ws.BufData[i]; Mask[1] := Ws.BufData[i+1];
|
||||
Mask[2] := Ws.BufData[i+2]; Mask[3] := Ws.BufData[i+3];
|
||||
Inc(i, 4);
|
||||
end;
|
||||
Mask[0] := Ws.BufData[i]; Mask[1] := Ws.BufData[i+1];
|
||||
Mask[2] := Ws.BufData[i+2]; Mask[3] := Ws.BufData[i+3];
|
||||
Inc(i, 4);
|
||||
|
||||
SetLength(Payload, PayLen);
|
||||
if PayLen > 0 then
|
||||
begin
|
||||
Move(Ws.BufData[i], Payload[0], PayLen);
|
||||
if Masked then
|
||||
for j := 0 to PayLen - 1 do
|
||||
Payload[j] := Payload[j] xor Mask[j and 3];
|
||||
for j := 0 to PayLen - 1 do
|
||||
Payload[j] := Payload[j] xor Mask[j and 3];
|
||||
end;
|
||||
|
||||
Consumed := i + PayLen;
|
||||
@@ -604,18 +869,49 @@ begin
|
||||
Ws.BufLen := Ws.BufLen - Consumed;
|
||||
|
||||
case Opcode of
|
||||
$01: // текст — одна или несколько команд в одном фрейме
|
||||
$00, $01, $02: // данные: продолжение / текст / binary
|
||||
begin
|
||||
SetLength(Text, PayLen);
|
||||
if PayLen > 0 then Move(Payload[0], Text[1], PayLen);
|
||||
if Assigned(FOnCommand) then
|
||||
if Opcode = $00 then
|
||||
begin
|
||||
TCISplit(Text, Cmds);
|
||||
for j := 0 to Cmds.Count - 1 do
|
||||
FOnCommand(Client, Cmds[j]);
|
||||
// Продолжение без начала — рассинхрон, дальше читать нечего.
|
||||
if MsgOp = 0 then begin Ws.State := wsClosed; Break; end;
|
||||
end
|
||||
else
|
||||
begin
|
||||
// Новое сообщение поверх недособранного — тоже рассинхрон.
|
||||
if MsgOp <> 0 then begin Ws.State := wsClosed; Break; end;
|
||||
MsgOp := Opcode;
|
||||
Frag := '';
|
||||
end;
|
||||
|
||||
// Копим только текст: binary — это TX-аудио от клиента, этап 2.
|
||||
if MsgOp = $01 then
|
||||
begin
|
||||
if Length(Frag) + PayLen > TCI_MSG_MAX then
|
||||
begin
|
||||
Ws.State := wsClosed;
|
||||
Break;
|
||||
end;
|
||||
if PayLen > 0 then
|
||||
begin
|
||||
SetLength(Text, PayLen);
|
||||
Move(Payload[0], Text[1], PayLen);
|
||||
Frag := Frag + Text;
|
||||
end;
|
||||
end;
|
||||
|
||||
if Fin then
|
||||
begin
|
||||
if (MsgOp = $01) and Assigned(FOnCommand) and (Frag <> '') then
|
||||
begin
|
||||
TCISplit(Frag, Cmds);
|
||||
for j := 0 to Cmds.Count - 1 do
|
||||
FOnCommand(Client, Cmds[j]);
|
||||
end;
|
||||
MsgOp := 0;
|
||||
Frag := '';
|
||||
end;
|
||||
end;
|
||||
$02: ; // binary: TX-аудио от клиента — этап 2, пока игнорируем
|
||||
$08: // close
|
||||
begin
|
||||
Ws.State := wsClosed;
|
||||
@@ -624,14 +920,17 @@ begin
|
||||
$09: // ping → pong
|
||||
if PayLen > 0 then Ws.SendWsFrame($0A, Payload[0], PayLen)
|
||||
else Ws.SendWsFrame($0A, PayLen, 0);
|
||||
$0A: ; // pong — ничего не ждём
|
||||
else
|
||||
// Незнакомый opcode: по RFC соединение обязано закрыться.
|
||||
Ws.State := wsClosed;
|
||||
Break;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
finally
|
||||
Cmds.Free;
|
||||
end;
|
||||
|
||||
RemoveClient(Client);
|
||||
end;
|
||||
|
||||
{ ═══════════════════════════════════════════════════════════════════════════
|
||||
@@ -644,6 +943,8 @@ begin
|
||||
if S = '' then Exit;
|
||||
FClientLock.Enter;
|
||||
try
|
||||
// Send только кладёт строку в очередь клиента — лок держится микросекунды,
|
||||
// сколько бы клиент ни тормозил. В сокеты пишет тик-поток.
|
||||
for i := 0 to FClientCount - 1 do
|
||||
if (FClients[i] <> nil) and (FClients[i] <> Skip) and FClients[i].Ready then
|
||||
FClients[i].Send(S);
|
||||
@@ -659,7 +960,7 @@ begin
|
||||
FClientLock.Enter;
|
||||
try
|
||||
for i := 0 to FClientCount - 1 do
|
||||
if FClients[i] <> nil then Proc(FClients[i]);
|
||||
if (FClients[i] <> nil) and not FClients[i].FClosed then Proc(FClients[i]);
|
||||
finally
|
||||
FClientLock.Leave;
|
||||
end;
|
||||
@@ -681,7 +982,9 @@ begin
|
||||
begin
|
||||
Sleep(TCI_TICK_MS);
|
||||
if not FRunning then Break;
|
||||
ReapClients; // отключившиеся — освобождаем только здесь
|
||||
if (FClientCount > 0) and Assigned(FOnTick) then FOnTick;
|
||||
FlushClients; // очереди → сокеты
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
Reference in New Issue
Block a user