ew8bak/ewsdr
1
0
Fork 0
mirror of https://git.vladimir.cc/vladimir/ewsdr.git synced 2026-08-25 20:37:33 +00:00
Code Issues Packages Projects Releases Wiki Activity

fix(dxcluster): резолв имени, гейт логина, TTL и мелочи UI по итогам ревизии

Browse Source 
Сеть и резолв (DXClusterClient):
- Резолв ушёл в отдельный поток: системный резолвер блокирующий и не
  прерывается, а сокета в этот момент ещё нет — Stop из UI-потока висел на
  DNS-таймауте. Сессия ждёт квантами по 200 мс, просыпаясь на FStopEvent;
  Stop теперь отрабатывает за 100-200 мс в любой фазе.
- Реестр запросов: по одному резолверу на имя, не больше DX_MAX_RESOLVERS.
  Не дождавшись, сессия оставляет запрос в реестре и на следующей попытке
  цепляется к нему же (иначе зависший резолвер плодил бы вечные потоки).
  Слотов несколько, чтобы смена адреса работала поверх зависшего прежнего;
  литеральный IP разбирается до реестра — ввод адреса руками обязан работать
  всегда. Запись живёт по счётчику ссылок, исключение в резолвере не
  оставляет слот занятым.
- getaddrinfo вместо netdb.ResolveHostByName: тот ходит в DNS сам и
  /etc/hosts не читает вовсе (getent находит localhost, ResolveHostByName —
  нет), т.е. локальный алиас кластера не работал. Заодно реентерабельно.
- WSAStartup перенесён в initialization, WSACleanup убран: Stop не ждёт
  резолвер, а тот может сидеть в gethostbyname.

Логин (DXClusterClient):
- Команды пользователя больше не уходят в незавершённый логин: очередь
  разбирается только после post-login, SendCommand говорит в лог, что
  команда ждёт.
- ONLINE не по таймеру, а по существу: LoginSettled требует ответа сервера
  после учётки (с потолком молчания), пароль ждёт своего приглашения.
  Подтверждение ставится ПОСЛЕ разбора куска, а не на приход байтов —
  иначе исход логина зависел от границ TCP-пакетов.
- Приглашения и отказы: строгий детектор (текст, заканчивающийся
  двоеточием) и для отправки пароля, и для вердикта — по вхождению слова
  пароль улетал командой от строки приветствия. Повтор приглашения пароля
  или позывного = отказ авторизации (dxsError, без реконнекта); опоздавшее
  приглашение после слепой отправки позывного отказом не считается.
  Эхо уже отвеченного приглашения гасится окном в одну строку.
- Ошибка отправки post-login рвёт сессию, а не только цикл команд;
  неотправленная очередь возвращается на следующее соединение.

UI и данные:
- QSY по споту крутит активный VFO, а не всегда A (MainForm).
- TTL спотов чистится тиком независимо от видимости оверлея (DXSpotStore
  .Purge + ServiceDXCluster).
- Выделение в окне списка держится по позывному И частоте: один позывной
  живёт на разных диапазонах (DXClusterForm).
- Кнопка DX правит и отложенную копию настроек, иначе debounce SETUP
  возвращал прежнее состояние подписей (MainForm).

Проверено на фейковом кластере: приглашения с CRLF и без, границы
TCP-пакетов, отказ по паролю и по позывному, опоздавшее приглашение,
ловушки ложного срабатывания.

Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
This commit is contained in:
ew8bak
2026-08-16 22:00:41 +03:00
co-authored by Claude Opus 5
parent eb4af61fad
commit 6ed1be3dc7
4 changed files with 692 additions and 85 deletions
Download Patch File Download Diff File Expand all files Collapse all files
DXClusterClient.pas
+642 -77
View File
@@ -3,8 +3,9 @@ unit DXClusterClient;
{
DXClusterClient.pas — telnet-клиент DX-кластера (одно соединение).
Один рабочий поток: резолв → connect (неблокирующий + select, чтобы не висеть
минуту на мёртвом хосте) → логин позывным → чтение строк. Разобранные споты
Один рабочий поток: резолв (в отдельном одноразовом потоке — см. ниже) →
connect (неблокирующий + select, чтобы не висеть минуту на мёртвом хосте) →
логин позывным → чтение строк. Разобранные споты
кладутся ПРЯМО в TDXSpotStore (он потокобезопасен), лог соединения — во
внутреннее кольцо. В главный поток ничего не маршалим: UI сам замечает
изменения по Version стора и по LogVersion — как оверлеи замечают смену вида
@@ -14,6 +15,25 @@ unit DXClusterClient;
SockShutdown, что разблокирует recv в потоке (на Linux одного close мало —
см. WebUtils.SockShutdown).
★Резолв имени вынесен в ОТДЕЛЬНЫЙ поток. Системный резолвер (getaddrinfo на
unix, gethostbyname на Windows) блокирующий и не прерывается ничем: пока он
молчит, сокета ещё нет, рвать Stop()'у нечего, а Stop зовётся из UI-потока и
делает WaitFor — окно висело бы весь DNS-таймаут. Поэтому сессия ждёт результат
КВАНТАМИ, проверяя Terminated и FStopEvent.
★Реестр запросов GResolvePending: по одному резолверу НА ИМЯ и не больше
DX_MAX_RESOLVERS одновременно. Не дождавшись, сессия НЕ бросает запрос, а
оставляет его в реестре и на следующей попытке цепляется к тому же — иначе на
зависшем системном резолвере каждая попытка реконнекта плодила бы новый вечный
поток. Слотов несколько, а не один, чтобы смена адреса в SETUP давала попытку
по новому имени даже поверх зависшего прежнего; литеральный IP разбирается
вообще до реестра (TryLiteralIP) — ввод адреса руками обязан работать всегда.
Запись запроса живёт по счётчику ссылок (Refs: резолвер + ожидающие); кто
уронил счётчик в ноль, тот и Dispose.
★Имя разрешается через getaddrinfo, а НЕ через netdb.ResolveHostByName: тот
ходит в DNS напрямую и /etc/hosts не читает вовсе (проверено: getent находит
localhost, ResolveHostByName — нет), т.е. локальный алиас кластера не работал
бы; вдобавок он держит глобальное состояние, а getaddrinfo реентерабелен.
Формат спота (общий для DXSpider / AR-Cluster / CC Cluster):
DX de UA3XYZ: 14025.0 DL1ABC CW 599 tnx qso 1832Z
Всё, что не начинается с 'DX de ', в стор не идёт — только в лог.
@@ -38,7 +58,7 @@ uses
{$IFDEF MSWINDOWS}
, WinSock2
{$ELSE}
, BaseUnix, Sockets, netdb
, BaseUnix, Sockets, netdb, ctypes
{$ENDIF};
const
@@ -46,11 +66,16 @@ const
DX_DEFAULT_PORT = 8000;
DX_CONNECT_MS = 8000; // потолок ожидания connect
DX_CONNECT_SLICE_MS = 200; // квант ожидания connect (чтобы Stop не ждал 8 с)
DX_DNS_MS = 10000; // потолок ожидания резолва имени
DX_DNS_SLICE_MS = 200; // квант ожидания резолва (чтобы Stop не ждал DNS)
DX_MAX_RESOLVERS = 4; // одновременных резолвер-потоков на процесс
DX_RECV_MS = 1000; // квант recv: просыпаемся проверить Terminated/очередь
DX_RECONNECT_MIN = 5; // с
DX_RECONNECT_MAX = 60; // с
DX_LOGIN_GRACE_S = 6; // не увидели приглашение — шлём позывной сами
DX_POSTLOGIN_S = 2; // пауза после позывного перед post-login командами
DX_POSTLOGIN_S = 2; // пауза после последнего шага логина
DX_PASSWORD_WAIT_S = 8; // ждём приглашение пароля, потом считаем, что его не будет
DX_LOGIN_MAX_S = 20; // сервер молчит после позывного — идём дальше вслепую
DX_LOG_LINES = 300; // кольцо лога соединения
DX_SEND_RETRIES = 20; // повторов send по таймауту буфера, потом разрыв
@@ -129,6 +154,34 @@ function DXStateName(St: TDXClusterState): string;
implementation
type
// Запрос на резолв, общий для сессии и одноразового резолвер-потока. Живёт в
// куче по счётчику ссылок: одна у резолвера, по одной у каждой ждущей сессии.
// Кто уронил Refs в ноль под GResolveLock, тот и делает Dispose — так
// брошенный DNS никого не переживает и ничего не течёт.
PDXResolveReq = ^TDXResolveReq;
TDXResolveReq = record
Host: string;
Addr: LongWord; // сетевой порядок байт
Ok: Boolean;
Done: Boolean; // резолвер отработал
Refs: Integer;
end;
// Чем кончилось ожидание резолва — от этого зависит, что писать в лог.
TDXResolveOutcome = (droOk, // имя разрешено
droFailed, // резолвер ответил «нет такого имени»
droTimeout, // не дождались (или нас остановили)
droBusy); // в полёте резолв ДРУГОГО имени
TDXResolverThread = class(TThread)
private
FReq: PDXResolveReq;
protected
procedure Execute; override;
public
constructor Create(AReq: PDXResolveReq);
end;
TDXClusterThread = class(TThread)
private
FOwner: TDXClusterClient;
@@ -143,12 +196,23 @@ type
FPostLogin: string;
FLoginSent: Boolean;
FLoginByPrompt: Boolean; // позывной ушёл в ответ на приглашение, не вслепую
FPassSent: Boolean;
FPostSent: Boolean;
FLoginAt: TDateTime;
FLoginAt: TDateTime; // когда ушёл позывной
FLoginStepAt: TDateTime; // когда ушла последняя порция учётки (позывной/пароль)
FSawAfterLogin: Boolean; // после учётки сервер что-то прислал
FConnectAt: TDateTime;
FFatal: Boolean; // отказ авторизации — реконнект бессмыслен
// Приглашение, на которое мы только что ответили, разобрав НЕЗАВЕРШЁННЫЙ
// хвост. Оно остаётся в буфере и со следующим куском доедет целой строкой —
// окно ровно на одну строку, чтобы не счесть собственное эхо новым вопросом.
FAnsweredPrompt: string;
function Resolve(const Host: string; out Addr: LongWord): Boolean;
procedure FailAuth(const Reason: string);
function LoginSettled: Boolean;
function SendPostLogin: Boolean;
function Resolve(const Host: string; out Addr: LongWord): TDXResolveOutcome;
function ConnectSock: Boolean;
procedure CloseSock;
function SendAll(const Data: string): Boolean;
@@ -156,7 +220,7 @@ type
procedure FlushOutQueue;
procedure HandleChunk(const Data: string);
procedure HandleLine(const Line: string);
procedure CheckPrompts(const Tail: string);
procedure CheckPrompts(const Tail: string; IsTail: Boolean);
function Session: Boolean; // одно соединение; False — выйти совсем
protected
procedure Execute; override;
@@ -164,6 +228,18 @@ type
constructor Create(AOwner: TDXClusterClient);
end;
var
// Один на все запросы резолва: они редки (одна попытка на соединение), а общий
// лок избавляет запись запроса от собственной критической секции — иначе её
// пришлось бы освобождать ровно тому, кто освобождает саму запись.
GResolveLock: TCriticalSection;
// Запросы «в полёте», по одному на имя. Слот занят ⇒ по этому имени уже
// работает резолвер-поток, и второго по нему мы не заводим (см. шапку юнита).
GResolvePending: array[0..DX_MAX_RESOLVERS - 1] of PDXResolveReq;
{$IFDEF MSWINDOWS}
GWSAData: TWSAData;
{$ENDIF}
function DXStateName(St: TDXClusterState): string;
begin
case St of
@@ -284,9 +360,6 @@ end;
{ ── TDXClusterClient ─────────────────────────────────────────────────────── }
constructor TDXClusterClient.Create(AStore: TDXSpotStore);
{$IFDEF MSWINDOWS}
var wsa: TWSAData;
{$ENDIF}
begin
inherited Create;
FStore := AStore;
@@ -301,9 +374,7 @@ begin
FLogVer := 0;
FSpotCount := 0;
FActiveSock := SOCK_INVALID;
{$IFDEF MSWINDOWS}
WSAStartup($0202, wsa);
{$ENDIF}
// WSAStartup/WSACleanup здесь БЫЛИ и убраны — см. initialization юнита.
end;
destructor TDXClusterClient.Destroy;
@@ -312,9 +383,6 @@ begin
FOutQueue.Free;
FStopEvent.Free;
FLock.Free;
{$IFDEF MSWINDOWS}
WSACleanup;
{$ENDIF}
inherited Destroy;
end;
@@ -339,6 +407,15 @@ end;
procedure TDXClusterClient.Start;
begin
// Поток прошлой сессии мог завершиться сам (кластер отверг логин) — прибираем
// его, иначе Start молча ничего бы не сделал и кнопка CONNECT в окне
// кластера перестала бы работать до перезапуска программы.
if (FThread <> nil) and FThread.Finished then
begin
FThread.WaitFor; // уже завершён — не ждёт
FThread.Free;
FThread := nil;
end;
if FThread <> nil then Exit;
FLock.Enter;
try
@@ -400,8 +477,10 @@ begin
end;
function TDXClusterClient.Running: Boolean;
// Завершившийся сам поток (отказ авторизации) — уже не «работаем»: иначе окно
// кластера показывало бы DISCONNECT у мёртвого соединения.
begin
Result := FThread <> nil;
Result := (FThread <> nil) and (not FThread.Finished);
end;
procedure TDXClusterClient.PublishSock(S: TSocket);
@@ -465,14 +544,20 @@ begin
end;
procedure TDXClusterClient.SendCommand(const S: string);
var Queued: Boolean;
begin
if Trim(S) = '' then Exit;
FLock.Enter;
try
FOutQueue.Add(S);
Queued := FState <> dxsOnline;
finally
FLock.Leave;
end;
// До конца логина поток очередь не разбирает (иначе команда ушла бы вместо
// позывного или пароля). Молча «проглоченная» команда выглядела бы как
// потеря — говорим в лог, что она ждёт.
if Queued then AddLog('*** queued until login completes: ' + S);
end;
procedure TDXClusterClient.AddLog(const S: string);
@@ -522,45 +607,275 @@ begin
inherited Create(False);
end;
function TDXClusterThread.Resolve(const Host: string; out Addr: LongWord): Boolean;
// Возвращает адрес в СЕТЕВОМ порядке байт (готов для sin_addr).
{ ── Резолв имени ─────────────────────────────────────────────────────────── }
{$IFNDEF MSWINDOWS}
var HE: THostEntry; HA: THostAddr;
// getaddrinfo(3) объявляем сами: в RTL его нет (netdb использует его только
// под FPC_USE_LIBC, а этой сборки у нас нет), а тащить ради него устаревший
// пакет libc не хочется. Порядок полей структуры фиксирован ABI; BSD/macOS
// меняет местами ai_canonname и ai_addr — единственное расхождение.
{$PACKRECORDS C}
type
PCAddrInfo = ^TCAddrInfo;
TCAddrInfo = record
ai_flags: cint;
ai_family: cint;
ai_socktype: cint;
ai_protocol: cint;
ai_addrlen: cuint32;
{$IFDEF DARWIN}
ai_canonname: PChar;
ai_addr: Pointer;
{$ELSE}
ai_addr: Pointer;
ai_canonname: PChar;
{$ENDIF}
ai_next: PCAddrInfo;
end;
PSockAddrIn4 = ^TInetSockAddr;
{$PACKRECORDS DEFAULT}
function c_getaddrinfo(node, service: PChar; hints: PCAddrInfo;
out res: PCAddrInfo): cint; cdecl; external 'c' name 'getaddrinfo';
procedure c_freeaddrinfo(res: PCAddrInfo); cdecl; external 'c' name 'freeaddrinfo';
{$ENDIF}
function TryLiteralIP(const Host: string; out Addr: LongWord): Boolean;
// Литеральный адрес разбирается БЕЗ резолвера — строкой, мгновенно. Отдельной
// функцией он нужен для того, чтобы вводом IP всегда можно было выбраться из
// повисшего системного резолвера: ждать очереди в реестре запросов ради
// «127.0.0.1» было бы издевательством. Возвращает СЕТЕВОЙ порядок байт.
{$IFDEF MSWINDOWS}
var L: LongWord;
begin
Addr := 0;
L := inet_addr(PChar(Host));
Result := L <> INADDR_NONE; // inet_addr уже в сетевом порядке
if Result then Addr := L;
end;
{$ELSE}
var PH: PHostEnt; L: LongWord;
var HA: THostAddr;
begin
Addr := 0;
// TryStrToHostAddr отдаёт ХОСТОВЫЙ порядок — разворачиваем.
Result := TryStrToHostAddr(Host, HA);
if Result then Addr := htonl(HA.s_addr);
end;
{$ENDIF}
function ResolveHostSync(const Host: string; out Addr: LongWord): Boolean;
// Блокирующий системный резолв. Возвращает адрес в СЕТЕВОМ порядке байт
// (готов для sin_addr). Зовётся ТОЛЬКО из TDXResolverThread — прервать его
// нечем, поэтому ждать его результат напрямую нельзя (см. шапку юнита).
{$IFNDEF MSWINDOWS}
var Hints: TCAddrInfo; Res, AI: PCAddrInfo;
{$ELSE}
var PH: PHostEnt;
{$ENDIF}
begin
Result := False;
Addr := 0;
if Host = '' then Exit;
if TryLiteralIP(Host, Addr) then Exit(True);
{$IFDEF MSWINDOWS}
L := inet_addr(PChar(Host));
if L <> INADDR_NONE then // литеральный IP (уже в сетевом порядке)
begin
Addr := L;
Exit(True);
end;
PH := gethostbyname(PChar(Host));
if (PH = nil) or (PH^.h_addr_list = nil) or (PH^.h_addr_list^ = nil) then Exit;
Move(PH^.h_addr_list^^, Addr, 4); // hostent отдаёт сетевой порядок
Result := True;
{$ELSE}
// Литеральный IP: TryStrToHostAddr отдаёт ХОСТОВЫЙ порядок — разворачиваем.
if TryStrToHostAddr(Host, HA) then
begin
Addr := htonl(HA.s_addr);
Exit(True);
end;
// DNS (netdb читает /etc/resolv.conf и /etc/hosts). Здесь адрес приходит
// прямо из DNS-ответа, т.е. УЖЕ в сетевом порядке — второй раз не вертим.
if ResolveHostByName(Host, HE) then
begin
Addr := HE.Addr.s_addr;
Exit(True);
// Системный путь: getaddrinfo идёт через NSS ⇒ видит /etc/hosts, mDNS,
// systemd-resolved — всё, что настроено у пользователя. Адрес в ai_addr уже
// в сетевом порядке, второй раз не вертим.
FillChar(Hints, SizeOf(Hints), 0);
Hints.ai_family := AF_INET; // сокет мы поднимаем IPv4
Hints.ai_socktype := SOCK_STREAM;
Res := nil;
if (c_getaddrinfo(PChar(Host), nil, @Hints, Res) <> 0) or (Res = nil) then Exit;
try
AI := Res;
while AI <> nil do
begin
if (AI^.ai_family = AF_INET) and (AI^.ai_addr <> nil) then
begin
Addr := PSockAddrIn4(AI^.ai_addr)^.sin_addr.s_addr;
Exit(True);
end;
AI := AI^.ai_next;
end;
finally
c_freeaddrinfo(Res);
end;
{$ENDIF}
end;
procedure ReleaseResolveLocked(Req: PDXResolveReq);
// Зовётся ТОЛЬКО под GResolveLock. Последний ушедший гасит свет.
begin
Dec(Req^.Refs);
if Req^.Refs <= 0 then Dispose(Req);
end;
procedure UnlistResolveLocked(Req: PDXResolveReq);
// Снять запрос с реестра «в полёте». Только под GResolveLock.
var i: Integer;
begin
for i := 0 to High(GResolvePending) do
if GResolvePending[i] = Req then GResolvePending[i] := nil;
end;
function AcquireResolve(const Host: string;
out Req: PDXResolveReq): TDXResolveOutcome;
// droOk — Req наш (ссылку обязательно вернуть через ReleaseResolveLocked).
// droBusy — все слоты заняты ЗАВИСШИМИ резолвами ЧУЖИХ имён.
// droFailed — поток не создался.
var i, Slot: Integer;
begin
Result := droBusy;
Req := nil;
GResolveLock.Enter;
try
Slot := -1;
for i := 0 to High(GResolvePending) do
if GResolvePending[i] = nil then
begin
if Slot < 0 then Slot := i;
end
else if GResolvePending[i]^.Host = Host then
begin
// Тот же хост — цепляемся к уже летящему запросу вместо второго потока.
// Именно это и держит число резолверов конечным, когда системный
// резолвер завис: КАЖДАЯ следующая попытка ждёт ТОТ ЖЕ запрос.
Req := GResolvePending[i];
Inc(Req^.Refs);
Exit(droOk);
end;
// Слотов несколько, а не один, ради простой вещи: сменив в SETUP адрес
// кластера, пользователь обязан получить попытку по НОВОМУ имени даже если
// предыдущее намертво зависло в системном резолвере. Потолок оставлен,
// чтобы такие «вечные» потоки не копились без счёта.
if Slot < 0 then Exit;
New(Req);
Req^.Host := Host;
Req^.Addr := 0;
Req^.Ok := False;
Req^.Done := False;
Req^.Refs := 2; // резолвер + мы
GResolvePending[Slot] := Req;
try
TDXResolverThread.Create(Req);
except
GResolvePending[Slot] := nil; // поток не родился — запись ничья
Dispose(Req);
Req := nil;
Exit(droFailed);
end;
Result := droOk;
finally
GResolveLock.Leave;
end;
end;
constructor TDXResolverThread.Create(AReq: PDXResolveReq);
begin
FReq := AReq;
FreeOnTerminate := True; // сессия его не ждёт и не освобождает
inherited Create(False);
end;
procedure TDXResolverThread.Execute;
var
A: LongWord;
Ok: Boolean;
begin
A := 0;
Ok := False;
try
// Host записан до старта потока и больше никем не трогается — без лока.
Ok := ResolveHostSync(FReq^.Host, A);
except
// ★Любое исключение здесь обязано ЗАВЕРШИТЬСЯ снятием запроса с реестра.
// Иначе слот остался бы занят навсегда: то же имя давало бы вечные
// таймауты (Done никогда не выставится), а остальные — вечный DNS busy.
// TThread исключение проглатывает (кладёт в FatalException), так что без
// этого except мы бы даже не заметили.
Ok := False;
end;
GResolveLock.Enter;
try
FReq^.Addr := A;
FReq^.Ok := Ok;
FReq^.Done := True;
// Снимаемся с «в полёте»: следующая попытка начнёт свежий резолв, а этот
// результат достанется лишь тому, кто его уже ждёт.
UnlistResolveLocked(FReq);
ReleaseResolveLocked(FReq); // наша ссылка
finally
GResolveLock.Leave;
end;
FReq := nil;
end;
function TDXClusterThread.Resolve(const Host: string;
out Addr: LongWord): TDXResolveOutcome;
// Ждём резолвер квантами, чтобы Stop/Terminate не упирались в системный
// DNS-таймаут. Не дождались — ссылку отдаём, но сам запрос остаётся в реестре:
// следующая попытка подождёт его же, а не заведёт второй вечный поток.
var
Req: PDXResolveReq;
Waited: Integer;
Ready: Boolean;
begin
Addr := 0;
Result := droFailed;
if Host = '' then Exit;
// ★Литеральный адрес разбираем ЗДЕСЬ, до всякого реестра: иначе, когда
// системный резолвер завис, ввод IP руками — единственный способ выбраться —
// упирался бы в чужой занятый слот ровно так же, как имя.
if TryLiteralIP(Host, Addr) then Exit(droOk);
Result := AcquireResolve(Host, Req);
if Result <> droOk then Exit; // все слоты заняты / поток не создался
Result := droFailed; // дальше исход решает ожидание ниже
try
Waited := 0;
while not Terminated do
begin
GResolveLock.Enter;
try
Ready := Req^.Done;
finally
GResolveLock.Leave;
end;
if Ready or (Waited >= DX_DNS_MS) then Break;
// Ждём на FStopEvent, а не Sleep: Stop будит нас немедленно.
if FOwner.FStopEvent.WaitFor(DX_DNS_SLICE_MS) = wrSignaled then Break;
Inc(Waited, DX_DNS_SLICE_MS);
end;
finally
// Ссылку отдаём при любом исходе, включая исключение в ожидании: иначе
// запись зависла бы с лишней ссылкой и не освободилась никогда.
GResolveLock.Enter;
try
if not Req^.Done then
Result := droTimeout
else if Req^.Ok then
begin
Addr := Req^.Addr;
Result := droOk;
end
else
Result := droFailed;
ReleaseResolveLocked(Req);
finally
GResolveLock.Leave;
end;
end;
if Terminated then Result := droTimeout; // уходим — адрес уже не нужен
end;
function TDXClusterThread.ConnectSock: Boolean;
// Неблокирующий connect + select: мёртвый хост не держит поток минуту на
// системном таймауте TCP, и Stop() отрабатывает быстро.
@@ -574,12 +889,28 @@ var
{$IFDEF MSWINDOWS}ErrLen: Integer;{$ELSE}ErrLen: TSockLen;{$ENDIF}
begin
Result := False;
if not Resolve(FHost, IP) then
begin
case Resolve(FHost, IP) of
droOk: ;
droBusy:
begin
FOwner.SetState(dxsRetry, 'DNS busy');
FOwner.AddLog('*** DNS: previous lookup still running — retrying later');
Exit;
end;
droTimeout:
begin
if Terminated then Exit; // это не отказ DNS, а наш же Stop
FOwner.SetState(dxsRetry, 'DNS timeout: ' + FHost);
FOwner.AddLog('*** DNS: no answer for ' + FHost);
Exit;
end;
else
if Terminated then Exit;
FOwner.SetState(dxsRetry, 'cannot resolve ' + FHost);
FOwner.AddLog('*** DNS: cannot resolve ' + FHost);
Exit;
end;
if Terminated then Exit;
{$IFDEF MSWINDOWS}
FSocket := socket(AF_INET, SOCK_STREAM, IPPROTO_TCP);
@@ -716,7 +1047,7 @@ end;
procedure TDXClusterThread.FlushOutQueue;
var
Pending: TStringList;
i: Integer;
i, j: Integer;
begin
Pending := nil;
FOwner.FLock.Enter;
@@ -732,24 +1063,102 @@ begin
end;
if Pending = nil then Exit;
try
for i := 0 to Pending.Count - 1 do
i := 0;
while i < Pending.Count do
begin
if not SendLine(Pending[i]) then Break; // сокет умер — остальное на реконнект
if not SendLine(Pending[i]) then Break; // сокет умер
FOwner.AddLog('> ' + Pending[i]);
Inc(i);
end;
// ★Не ушедшее (начиная с той самой команды) возвращаем в НАЧАЛО очереди:
// очередь выгребается целиком до отправки, и без возврата всё, до чего
// не дошли, просто пропадало бы — а обещано «отправим после реконнекта».
// В начало, потому что порядок для кластера значим (set/filter до sh/dx).
if i < Pending.Count then
begin
FOwner.FLock.Enter;
try
for j := Pending.Count - 1 downto i do
FOwner.FOutQueue.Insert(0, Pending[j]);
finally
FOwner.FLock.Leave;
end;
FOwner.AddLog(Format('*** %d command(s) held for the next connection',
[Pending.Count - i]));
end;
finally
Pending.Free;
end;
end;
procedure TDXClusterThread.CheckPrompts(const Tail: string);
function PromptEndsWith(const U, Key: string): Boolean;
// U (уже в нижнем регистре) заканчивается ПРИГЛАШЕНИЕМ вида '…password:'.
// Двоеточие в конце — то, что отличает вопрос кластера от упоминания слова в
// приветствии («you can set a password with set/password»): на таком упоминании
// вывод «пароль отвергнут» порвал бы живое соединение.
var S: string; P: Integer;
begin
Result := False;
S := TrimRight(U);
if S = '' then Exit;
if S[Length(S)] <> ':' then Exit;
// ★Ищем ПОСЛЕДНЕЕ вхождение: в 'invalid password, enter password:' первое
// стоит далеко от конца и по нему приглашение не опозналось бы вовсе.
P := RPos(Key, S);
// Ключ должен стоять у самого конца: '…password (again):' считаем тем же.
Result := (P > 0) and (Length(S) - (P + Length(Key) - 1) <= 10);
end;
function IsLoginPrompt(const U: string): Boolean;
// Строгая форма вопроса о позывном: 'login:', 'call:', 'callsign:', 'your
// call:'. Свободный поиск слова здесь не годится — по нему приветствие с
// упоминанием позывного сошло бы за повторный вопрос, т.е. за отказ.
begin
Result := PromptEndsWith(U, 'login') or PromptEndsWith(U, 'call');
end;
function LooksLikeAuthFailure(const U: string): Boolean;
// Типовые формулировки отказа. Список НАМЕРЕННО короткий и из точных фраз:
// проверяется он только в окне «учётка отправлена, логин ещё не завершён», но
// ложное срабатывание всё равно стоило бы рабочего соединения.
const
MARKS: array[0..6] of string = (
'invalid password', 'incorrect password', 'password incorrect',
'wrong password', 'login incorrect', 'access denied',
'authentication failed');
var i: Integer;
begin
Result := True;
for i := Low(MARKS) to High(MARKS) do
if Pos(MARKS[i], U) > 0 then Exit;
Result := False;
end;
procedure TDXClusterThread.FailAuth(const Reason: string);
// Отказ авторизации — не разрыв: реконнект с той же учёткой упрётся в то же
// самое. Гасим сессию совсем и говорим прямо; пользователь правит настройки, а
// это само поднимет клиент заново (ApplyDXConnection видит смену логина).
begin
if FFatal then Exit;
FFatal := True;
FOwner.AddLog('*** ' + Reason + ' — giving up, check callsign/password');
FOwner.SetState(dxsError, Reason);
end;
procedure TDXClusterThread.CheckPrompts(const Tail: string; IsTail: Boolean);
// Приглашения логина И пароля обычно приходят БЕЗ перевода строки, поэтому
// ищем их и в незавершённом хвосте буфера, а не только в целых строках.
// Флаги FLoginSent/FPassSent держат отправку однократной: хвост проверяется
// заново с каждым пришедшим куском.
// ★IsTail говорит лишь о том, ОТКУДА пришёл текст: незавершённый хвост или
// целая строка. Отвеченный хвост остаётся в буфере и со следующим куском доедет
// целой строкой — чтобы не счесть это эхо повторным вопросом (т.е. отказом),
// ответив по хвосту, мы запоминаем его в FAnsweredPrompt, и HandleLine гасит
// ровно ОДНУ следующую строку, если она совпала. Запрещать проверки для целых
// строк нельзя: приглашения вида 'Password:\r\n' — совершенно обычное дело.
var U: string;
begin
if Tail = '' then Exit;
if (Tail = '') or FFatal then Exit;
U := LowerCase(Tail);
if not FLoginSent then
@@ -760,28 +1169,147 @@ begin
begin
if not SendLine(FLogin) then Exit;
FOwner.AddLog('> ' + FLogin);
FLoginSent := True;
FLoginAt := Now;
if IsTail then FAnsweredPrompt := TrimRight(U);
FLoginSent := True;
FLoginByPrompt := True; // ответили на вопрос, а не выстрелили вслепую
FLoginAt := Now;
FLoginStepAt := FLoginAt;
FSawAfterLogin := False; // ждём ответ именно на позывной
FOwner.SetState(dxsLogin, '');
end;
Exit;
end;
if (FPassword <> '') and (not FPassSent) and (Pos('password', U) > 0) then
// Кластер снова просит позывной. Если наш ушёл ПО ПРИГЛАШЕНИЮ — его не
// приняли, второй раз слать тот же нечего. Если же мы стреляли вслепую
// (приглашения не дождались за DX_LOGIN_GRACE_S, а кластер спросил только
// сейчас), то это не отказ, а опоздавший вопрос — отвечаем ещё раз, ровно
// один: после этого FLoginByPrompt уже True.
if IsLoginPrompt(U) then
begin
if FLoginByPrompt then
begin
FailAuth('callsign rejected');
Exit;
end;
if not SendLine(FLogin) then Exit;
FOwner.AddLog('> ' + FLogin + ' (prompt arrived late)');
if IsTail then FAnsweredPrompt := TrimRight(U);
FLoginByPrompt := True;
// ★FLoginAt тоже заново: от него считается ожидание приглашения ПАРОЛЯ, а
// ждать его надо от позывного, на который кластер реально отвечает. Оставив
// старую отметку (слепой выстрел), при поздно пришедшем приглашении мы бы
// пароля уже не ждали вовсе — и по первой же приветственной строке
// высыпали бы post-login прямо перед вопросом о пароле.
FLoginAt := Now;
FLoginStepAt := FLoginAt;
FSawAfterLogin := False;
Exit;
end;
// Приглашение пароля. И отправка, и вывод «не приняли» идут по ОДНОМУ И ТОМУ
// ЖЕ строгому детектору: по вхождению слова (как было) пароль улетел бы
// командой в кластер от одной лишь строки приветствия вида «you can set a
// password with set/password».
if PromptEndsWith(U, 'password') then
begin
// Спрашивают снова после того, как мы уже ответили, — не приняли.
if FPassSent then
begin
FailAuth('password rejected');
Exit;
end;
if FPassword = '' then
begin
FailAuth('cluster asks for a password, none configured');
Exit;
end;
if not SendLine(FPassword) then Exit;
FOwner.AddLog('> ********');
FPassSent := True;
if IsTail then FAnsweredPrompt := TrimRight(U);
FPassSent := True;
FLoginStepAt := Now;
// Ответ на пароль ещё впереди: вопрос о пароле ответом не считается.
FSawAfterLogin := False;
end;
end;
function TDXClusterThread.LoginSettled: Boolean;
// Логин завершён, когда: позывной ушёл; пароль либо не нужен, либо отправлен,
// либо приглашения так и не было; сервер ОТВЕТИЛ хоть чем-то после нашей
// учётки (или молчит уже неприлично долго); и прошла пауза, за которую кластер
// успевает дожевать регистрацию. Раньше здесь стояли просто «две секунды после
// позывного» — при этом post-login команды и команды пользователя улетали в
// ещё не пройденный логин, ломая авторизацию (sh/dx вместо пароля).
var SinceLogin, SinceStep: Integer;
begin
Result := False;
if not FLoginSent then Exit;
SinceLogin := SecondsBetween(Now, FLoginAt);
SinceStep := SecondsBetween(Now, FLoginStepAt);
// Приглашение пароля ждём от отправки позывного…
if (FPassword <> '') and (not FPassSent) and (SinceLogin < DX_PASSWORD_WAIT_S) then Exit;
// …а молчание сервера считаем от ПОСЛЕДНЕЙ отправленной учётки: после пароля
// ждать ответ надо заново, иначе «принят ли пароль» никто не проверит.
if (not FSawAfterLogin) and (SinceStep < DX_LOGIN_MAX_S) then Exit;
Result := SinceStep >= DX_POSTLOGIN_S;
end;
function TDXClusterThread.SendPostLogin: Boolean;
// False — сокет умер на отправке. Это разрыв ВСЕЙ сессии: продолжать на мёртвом
// соединении значило бы объявить ONLINE и вычерпать очередь команд в никуда.
var
PL: TStringList;
i: Integer;
begin
Result := True;
if Trim(FPostLogin) = '' then Exit;
PL := TStringList.Create;
try
PL.Text := FPostLogin;
for i := 0 to PL.Count - 1 do
if Trim(PL[i]) <> '' then
begin
if not SendLine(Trim(PL[i])) then Exit(False);
FOwner.AddLog('> ' + Trim(PL[i]));
end;
finally
PL.Free;
end;
end;
procedure TDXClusterThread.HandleLine(const Line: string);
var
Spot: TDXSpot;
Echo: Boolean;
begin
if Line = '' then Exit;
FOwner.AddLog(Line);
// Эхо приглашения, на которое мы уже ответили по хвосту (см. CheckPrompts).
// Окно ровно на одну строку: следующая строка — уже настоящая новость, и
// такое же приглашение в ней будет означать, что нас переспрашивают.
if FAnsweredPrompt <> '' then
begin
Echo := TrimRight(LowerCase(Line)) = FAnsweredPrompt;
FAnsweredPrompt := '';
if Echo then Exit; // ответом сервера это НЕ считается
end;
// Отказ ищем до всего прочего и, главное, до отметки «сервер ответил»: иначе
// «Invalid password» само же и подтверждало бы успешный логин. Окно узкое —
// учётка ушла, логин не завершён; дальше в строках обычный трафик кластера,
// где такие слова бывают в чьём угодно комментарии к споту.
if FLoginSent and (not FPostSent) and LooksLikeAuthFailure(LowerCase(Line)) then
begin
FailAuth('cluster rejected login: ' + Trim(Line));
Exit;
end;
// Вот теперь это действительно ответ сервера по существу: не эхо нашего же
// приглашения и не отказ. Только такое и подтверждает, что логин продвинулся.
if FLoginSent then FSawAfterLogin := True;
if ParseDXSpot(Line, Spot) then
begin
FOwner.FStore.Add(Spot);
@@ -795,7 +1323,7 @@ begin
Exit;
end;
CheckPrompts(Line);
CheckPrompts(Line, False);
end;
procedure TDXClusterThread.HandleChunk(const Data: string);
@@ -816,8 +1344,26 @@ begin
HandleLine(TrimRight(Line));
end;
// Хвост без перевода строки — возможно, это приглашение логина или пароля.
if FRxBuf <> '' then CheckPrompts(FRxBuf);
// Хвост без перевода строки — возможно, это приглашение логина или пароля…
if FRxBuf <> '' then
begin
// …а возможно, и сообщение об отказе: его тоже присылают без перевода
// строки, и без этой проверки оно ушло бы в «сервер ответил», т.е. в
// подтверждение логина.
if FLoginSent and (not FPostSent) and LooksLikeAuthFailure(LowerCase(FRxBuf)) then
FailAuth('cluster rejected login: ' + Trim(FRxBuf))
else
begin
CheckPrompts(FRxBuf, True);
// Хвост подтверждает логин, только если пережил разбор: не отказ, не
// приглашение, которое мы только что отвечали (там флаг сбрасывается), и
// не остаток уже отвеченного приглашения. Считать его ответом нужно —
// многие кластеры шлют приглашение сессии БЕЗ перевода строки, и без
// этого post-login ждал бы потолка молчания на ровном месте.
if FLoginSent and (not FFatal) and (FAnsweredPrompt = '') then
FSawAfterLogin := True;
end;
end;
// Защита от мусора без переводов строк.
if Length(FRxBuf) > 8192 then FRxBuf := '';
end;
@@ -827,14 +1373,18 @@ var
Buf: array[0..4095] of Byte;
N: Integer;
Chunk: string;
PL: TStringList;
i: Integer;
begin
Result := True;
FRxBuf := '';
FLoginSent := False;
FLoginByPrompt := False;
FPassSent := False;
FPostSent := False;
FSawAfterLogin := False;
FFatal := False;
FAnsweredPrompt := '';
FLoginAt := Now;
FLoginStepAt := Now;
FConnectAt := Now;
FOwner.SetState(dxsConnecting, FHost + ':' + IntToStr(FPort));
@@ -851,7 +1401,13 @@ begin
begin
SetLength(Chunk, N);
Move(Buf[0], Chunk[1], N);
// ★FSawAfterLogin здесь НЕ ставится. Приход байтов — факт транспортный, а
// не протокольный: отдельным пакетом может доехать один лишь '\r\n',
// закрывающий приглашение, на которое мы уже ответили, и «подтверждение
// логина» зависело бы от того, как TCP порезал поток. Флаг ставит
// HandleChunk/HandleLine — после разбора, по существу пришедшего.
HandleChunk(Chunk);
if FFatal then Break; // логин отвергнут — реконнект не поможет
end
else if N = 0 then
begin
@@ -872,38 +1428,29 @@ begin
begin
if not SendLine(FLogin) then Break; // сокет умер — на реконнект
FOwner.AddLog('> ' + FLogin + ' (no prompt seen)');
FLoginSent := True;
FLoginAt := Now;
FLoginSent := True;
FLoginByPrompt := False; // вслепую: опоздавшее приглашение = не отказ
FLoginAt := Now;
FLoginStepAt := FLoginAt;
FSawAfterLogin := False; // ждём ответ именно на позывной
end;
// Post-login команды — один раз, чуть погодя после позывного.
if FLoginSent and (not FPostSent) and
(SecondsBetween(Now, FLoginAt) >= DX_POSTLOGIN_S) then
// Post-login команды — один раз, когда логин действительно пройден.
if (not FPostSent) and LoginSettled then
begin
FPostSent := True;
if Trim(FPostLogin) <> '' then
begin
PL := TStringList.Create;
try
PL.Text := FPostLogin;
for i := 0 to PL.Count - 1 do
if Trim(PL[i]) <> '' then
begin
if not SendLine(Trim(PL[i])) then Break;
FOwner.AddLog('> ' + Trim(PL[i]));
end;
finally
PL.Free;
end;
end;
if not SendPostLogin then Break; // сокет умер — вся сессия на реконнект
if FOwner.State <> dxsOnline then FOwner.SetState(dxsOnline, '');
end;
FlushOutQueue;
// Команды пользователя — только после логина: до него кластер ждёт позывной
// и пароль, и любая наша строка ушла бы вместо них. Очередь никуда не
// девается, отправим следом.
if FPostSent then FlushOutQueue;
end;
CloseSock;
Result := not Terminated;
Result := (not Terminated) and (not FFatal);
end;
procedure TDXClusterThread.Execute;
@@ -938,4 +1485,22 @@ begin
CloseSock;
end;
initialization
GResolveLock := TCriticalSection.Create;
FillChar(GResolvePending, SizeOf(GResolvePending), 0);
{$IFDEF MSWINDOWS}
// ★Winsock поднимается ОДИН раз на процесс и НЕ выгружается. Раньше это
// делали конструктор и деструктор клиента — но Stop не ждёт (и не может
// ждать) резолвер-поток, а тот может в этот момент сидеть внутри
// gethostbyname: WSACleanup из-под него = обращение к выгруженному Winsock,
// то есть падение на выходе или при пересоздании клиента. Winsock освободит
// сам процесс.
WSAStartup($0202, GWSAData);
{$ENDIF}
// ★finalization НЕТ намеренно, по той же причине: брошенный резолвер может
// стоять в системном резолвере и после выхода из программы, а прервать его
// нечем. Освободив GResolveLock, мы дали бы ему упасть на Enter уже
// освобождённой секции; один живущий до конца процесса объект — не утечка.
end.