mirror of
https://git.vladimir.cc/vladimir/ewsdr.git
synced 2026-08-25 18:43:51 +00:00
feat(dxcluster): споты DX-кластера на панадаптере
Telnet-клиент DX-кластера, база спотов и подписи позывных прямо на спектре на своих частотах. Разложено на три слоя, как бэндплан и лупа маяка. DXClusterClient.pas — один рабочий поток: резолв, неблокирующий connect с select квантами по 200 мс (Stop не ждёт таймаут соединения), логин позывным, чтение строк, реконнект с backoff. Приглашения логина И пароля ловятся в незавершённом хвосте буфера — типичный telnet-prompt приходит без CR/LF. Ошибки recv отличаются от таймаута кванта (EAGAIN/EINTR/WSAETIMEDOUT), иначе на ECONNRESET поток крутился бы в пустом цикле вместо реконнекта. Отправка дописывает частичный send. LCL-free. DXSpotStore.pas — потокобезопасная база: дедуп по позывному, TTL, потолок записей, монотонный Version. Единственная точка обмена потока с UI: никакого Synchronize, UI сам замечает правки по Version, как оверлеи — по ключам кэша. DXSpotOverlay.pas — рендер по модели BandPlanOverlay/VfoOverlay: кэшируется только полоса подписей (W × BandH) в key-color битмап, пересборка строго по dirty-ключу, на кадр — один keyed-композит. Штрихи от полосы до низа спектра рисует вызывающая сторона теми же примитивами, что и прочие маркеры: CPU — RawVLine внутри RawBegin/RawEnd, GL — DrawLine по готовому списку X/цвет. GL берёт тот же битмап текстурой и заливает её только при смене RenderVersion. Пересекающиеся подписи раскладываются лесенкой, цвет гаснет с возрастом, свой позывной выделен; палитра парная под тёмную и светлую тему. DXClusterForm.pas — окно списка: споты, лог соединения, строка команды кластеру (диалект set/filter у всех свой — не угадываем). Двойной клик или Enter = QSY. Данные тянутся поллингом по Version/LogVersion. Интеграция: кнопка DX в тулбаре (ЛКМ — подписи на спектре, ПКМ — окно), клик по подписи спота = QSY с автовыбором моды по комментарию кластера, страница SETUP → DX Cluster с персистом в секции "dxcluster". Правки SETUP прилетают посимвольно, поэтому запись конфига, TTL стора и переподключение откладываются до паузы в наборе — иначе набор позывного стоил бы шесть реконнектов, а промежуточный TTL «3» необратимо выбросил бы споты. Частота спота кладётся как есть и сравнивается с GetViewWindow: на QO-100 кластеры постят downlink 10489.xxx, что совпадает со шкалой пана само собой. Побочно в общих юнитах: WebUtils.SockSetRcvTimeout, FlatMemo.OnChange, FlatListBox.OnKeyDown, BlendBitmapKey вынесен в interface VfoOverlay (одна копия дворд-блендера на проект). Проверено на локальном фейковом кластере: логин и пароль по prompt без CR/LF, разбор спотов (включая QO-100), уход в RETRY по RST, Stop за 200 мс на висящем connect. На железе рендер не проверялся. Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
This commit is contained in:
Claude Opus 5
@@ -0,0 +1,883 @@
|
||||
unit DXClusterClient;
|
||||
|
||||
{
|
||||
DXClusterClient.pas — telnet-клиент DX-кластера (одно соединение).
|
||||
|
||||
Один рабочий поток: резолв → connect (неблокирующий + select, чтобы не висеть
|
||||
минуту на мёртвом хосте) → логин позывным → чтение строк. Разобранные споты
|
||||
кладутся ПРЯМО в TDXSpotStore (он потокобезопасен), лог соединения — во
|
||||
внутреннее кольцо. В главный поток ничего не маршалим: UI сам замечает
|
||||
изменения по Version стора и по LogVersion — как оверлеи замечают смену вида
|
||||
по ключам кэша. Никаких LCL-зависимостей.
|
||||
|
||||
Разрыв → реконнект с backoff (RECONNECT_MIN..RECONNECT_MAX). Stop() делает
|
||||
SockShutdown, что разблокирует recv в потоке (на Linux одного close мало —
|
||||
см. WebUtils.SockShutdown).
|
||||
|
||||
Формат спота (общий для DXSpider / AR-Cluster / CC Cluster):
|
||||
DX de UA3XYZ: 14025.0 DL1ABC CW 599 tnx qso 1832Z
|
||||
Всё, что не начинается с 'DX de ', в стор не идёт — только в лог.
|
||||
}
|
||||
|
||||
{$IFDEF FPC}
|
||||
{$MODE Delphi}
|
||||
{$LONGSTRINGS ON}
|
||||
{$ENDIF}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, SyncObjs, StrUtils, DateUtils,
|
||||
WebUtils, // SockClose/SockShutdown/SockRecv/SockSend/SOCK_INVALID
|
||||
DXSpotStore
|
||||
{$IFDEF MSWINDOWS}
|
||||
, Windows, WinSock2
|
||||
{$ELSE}
|
||||
, BaseUnix, Sockets, netdb
|
||||
{$ENDIF};
|
||||
|
||||
const
|
||||
DX_DEFAULT_HOST = 'cluster.dxfun.com';
|
||||
DX_DEFAULT_PORT = 8000;
|
||||
DX_CONNECT_MS = 8000; // потолок ожидания connect
|
||||
DX_CONNECT_SLICE_MS = 200; // квант ожидания connect (чтобы Stop не ждал 8 с)
|
||||
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_LOG_LINES = 300; // кольцо лога соединения
|
||||
DX_SEND_RETRIES = 20; // повторов send по таймауту буфера, потом разрыв
|
||||
|
||||
type
|
||||
TDXClusterState = (dxsOff, dxsConnecting, dxsLogin, dxsOnline, dxsRetry, dxsError);
|
||||
|
||||
TDXClusterClient = class
|
||||
private
|
||||
FThread: TThread;
|
||||
FLock: TCriticalSection; // защищает конфиг, лог, очередь, состояние
|
||||
FStopEvent: TEvent;
|
||||
|
||||
// конфиг (копия под FLock — поток читает её через GetConfig)
|
||||
FHost: string;
|
||||
FPort: Integer;
|
||||
FLogin: string;
|
||||
FPassword: string;
|
||||
FPostLogin: string; // строки через LineEnding
|
||||
|
||||
FStore: TDXSpotStore; // не владеет
|
||||
|
||||
FState: TDXClusterState;
|
||||
FStatusMsg: string;
|
||||
FSpotCount: Int64; // сколько спотов принято за сессию
|
||||
|
||||
FLog: array[0..DX_LOG_LINES-1] of string;
|
||||
FLogHead: Integer; // индекс следующей записи
|
||||
FLogCount: Integer;
|
||||
FLogVer: Int64;
|
||||
|
||||
FOutQueue: TStringList; // строки на отправку в кластер
|
||||
|
||||
procedure SetState(St: TDXClusterState; const Msg: string);
|
||||
public
|
||||
constructor Create(AStore: TDXSpotStore);
|
||||
destructor Destroy; override;
|
||||
|
||||
procedure Configure(const AHost: string; APort: Integer;
|
||||
const ALogin, APassword, APostLogin: string);
|
||||
procedure Start;
|
||||
procedure Stop;
|
||||
function Running: Boolean;
|
||||
|
||||
// Отправить сырую строку в кластер (окно списка: sh/dx, set/filter, …).
|
||||
procedure SendCommand(const S: string);
|
||||
|
||||
// Лог соединения — снимок в порядке приёма (старые → новые).
|
||||
procedure GetLog(Dst: TStrings);
|
||||
function LogVersion: Int64;
|
||||
procedure AddLog(const S: string);
|
||||
|
||||
function State: TDXClusterState;
|
||||
function StateText: string;
|
||||
function StatusMessage: string;
|
||||
function SpotsReceived: Int64;
|
||||
|
||||
property Store: TDXSpotStore read FStore;
|
||||
end;
|
||||
|
||||
// Разбор строки кластера. True — это спот (Spot заполнен).
|
||||
function ParseDXSpot(const Line: string; out Spot: TDXSpot): Boolean;
|
||||
function DXStateName(St: TDXClusterState): string;
|
||||
|
||||
implementation
|
||||
|
||||
type
|
||||
TDXClusterThread = class(TThread)
|
||||
private
|
||||
FOwner: TDXClusterClient;
|
||||
FSocket: TSocket;
|
||||
FRxBuf: string; // хвост неполной строки
|
||||
|
||||
// конфиг сессии (снимок на время соединения)
|
||||
FHost: string;
|
||||
FPort: Integer;
|
||||
FLogin: string;
|
||||
FPassword: string;
|
||||
FPostLogin: string;
|
||||
|
||||
FLoginSent: Boolean;
|
||||
FPassSent: Boolean;
|
||||
FPostSent: Boolean;
|
||||
FLoginAt: TDateTime;
|
||||
FConnectAt: TDateTime;
|
||||
|
||||
function Resolve(const Host: string; out Addr: LongWord): Boolean;
|
||||
function ConnectSock: Boolean;
|
||||
procedure CloseSock;
|
||||
function SendAll(const Data: string): Boolean;
|
||||
function SendLine(const S: string): Boolean;
|
||||
procedure FlushOutQueue;
|
||||
procedure HandleChunk(const Data: string);
|
||||
procedure HandleLine(const Line: string);
|
||||
procedure CheckPrompts(const Tail: string);
|
||||
function Session: Boolean; // одно соединение; False — выйти совсем
|
||||
protected
|
||||
procedure Execute; override;
|
||||
public
|
||||
constructor Create(AOwner: TDXClusterClient);
|
||||
end;
|
||||
|
||||
function DXStateName(St: TDXClusterState): string;
|
||||
begin
|
||||
case St of
|
||||
dxsOff: Result := 'OFF';
|
||||
dxsConnecting: Result := 'CONNECTING';
|
||||
dxsLogin: Result := 'LOGIN';
|
||||
dxsOnline: Result := 'ONLINE';
|
||||
dxsRetry: Result := 'RETRY';
|
||||
else Result := 'ERROR';
|
||||
end;
|
||||
end;
|
||||
|
||||
function SockWouldBlock: Boolean;
|
||||
// Последняя ошибка сокета означает «данных пока нет / истёк SO_RCVTIMEO /
|
||||
// прерван сигналом» — соединение живо. Всё остальное (ECONNRESET, ENOTCONN,
|
||||
// EPIPE…) — разрыв: без этой проверки поток крутил бы recv в пустом цикле,
|
||||
// вместо того чтобы уйти на реконнект.
|
||||
var E: Integer;
|
||||
begin
|
||||
{$IFDEF MSWINDOWS}
|
||||
E := WSAGetLastError;
|
||||
Result := (E = WSAEWOULDBLOCK) or (E = WSAETIMEDOUT) or (E = WSAEINTR);
|
||||
{$ELSE}
|
||||
E := fpgeterrno;
|
||||
Result := (E = ESysEAGAIN) or (E = ESysEWOULDBLOCK) or (E = ESysEINTR);
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
{ ── Разбор строки спота ──────────────────────────────────────────────────── }
|
||||
|
||||
function ParseDXSpot(const Line: string; out Spot: TDXSpot): Boolean;
|
||||
// 'DX de <spotter>: <кГц> <позывной> <комментарий> <HHMM>Z [грид]'
|
||||
var
|
||||
S, Rest, FreqStr, TimeTok: string;
|
||||
P, i: Integer;
|
||||
KHz: Double;
|
||||
FS: TFormatSettings;
|
||||
begin
|
||||
Result := False;
|
||||
FillChar(Spot, SizeOf(Spot), 0);
|
||||
Spot.Call := ''; Spot.Spotter := ''; Spot.Comment := ''; Spot.TimeUTC := '';
|
||||
|
||||
S := Trim(Line);
|
||||
if Length(S) < 12 then Exit;
|
||||
if not SameText(Copy(S, 1, 6), 'DX de ') then Exit;
|
||||
|
||||
Rest := Copy(S, 7, MaxInt);
|
||||
P := Pos(':', Rest);
|
||||
if P <= 1 then Exit;
|
||||
Spot.Spotter := Trim(Copy(Rest, 1, P - 1));
|
||||
Rest := Trim(Copy(Rest, P + 1, MaxInt));
|
||||
|
||||
// частота (кГц) — первый токен
|
||||
P := Pos(' ', Rest);
|
||||
if P <= 1 then Exit;
|
||||
FreqStr := Copy(Rest, 1, P - 1);
|
||||
Rest := TrimLeft(Copy(Rest, P + 1, MaxInt));
|
||||
|
||||
FS := DefaultFormatSettings;
|
||||
FS.DecimalSeparator := '.';
|
||||
FreqStr := StringReplace(FreqStr, ',', '.', [rfReplaceAll]);
|
||||
if not TryStrToFloat(FreqStr, KHz, FS) then Exit;
|
||||
if (KHz <= 0) or (KHz > 100000000.0) then Exit; // мусор/битая строка
|
||||
Spot.FreqHz := KHz * 1000.0;
|
||||
|
||||
// позывной DX — второй токен
|
||||
P := Pos(' ', Rest);
|
||||
if P > 0 then
|
||||
begin
|
||||
Spot.Call := Copy(Rest, 1, P - 1);
|
||||
Rest := TrimLeft(Copy(Rest, P + 1, MaxInt));
|
||||
end
|
||||
else
|
||||
begin
|
||||
Spot.Call := Rest;
|
||||
Rest := '';
|
||||
end;
|
||||
if Spot.Call = '' then Exit;
|
||||
|
||||
// Время: последний токен вида HHMMZ. Всё до него — комментарий, всё после
|
||||
// (обычно грид спотера) приклеиваем к комментарию — терять жалко.
|
||||
Rest := TrimRight(Rest);
|
||||
P := 0;
|
||||
for i := Length(Rest) - 4 downto 1 do
|
||||
if (Rest[i] in ['0'..'9']) and (Rest[i+1] in ['0'..'9']) and
|
||||
(Rest[i+2] in ['0'..'9']) and (Rest[i+3] in ['0'..'9']) and
|
||||
(UpCase(Rest[i+4]) = 'Z') and
|
||||
((i = 1) or (Rest[i-1] = ' ')) then
|
||||
begin
|
||||
P := i;
|
||||
Break;
|
||||
end;
|
||||
if P > 0 then
|
||||
begin
|
||||
TimeTok := Copy(Rest, P, 4);
|
||||
Spot.TimeUTC := TimeTok;
|
||||
Spot.Comment := Trim(Copy(Rest, 1, P - 1));
|
||||
Rest := Trim(Copy(Rest, P + 5, MaxInt));
|
||||
if Rest <> '' then Spot.Comment := Trim(Spot.Comment + ' ' + Rest);
|
||||
end
|
||||
else
|
||||
Spot.Comment := Trim(Rest);
|
||||
|
||||
Spot.Mode := DXModeFromComment(Spot.Comment);
|
||||
Spot.Stamp := Now;
|
||||
Result := True;
|
||||
end;
|
||||
|
||||
{ ── TDXClusterClient ─────────────────────────────────────────────────────── }
|
||||
|
||||
constructor TDXClusterClient.Create(AStore: TDXSpotStore);
|
||||
{$IFDEF MSWINDOWS}
|
||||
var wsa: TWSAData;
|
||||
{$ENDIF}
|
||||
begin
|
||||
inherited Create;
|
||||
FStore := AStore;
|
||||
FLock := TCriticalSection.Create;
|
||||
FStopEvent := TEvent.Create(nil, True, False, '');
|
||||
FOutQueue := TStringList.Create;
|
||||
FHost := DX_DEFAULT_HOST;
|
||||
FPort := DX_DEFAULT_PORT;
|
||||
FState := dxsOff;
|
||||
FLogHead := 0;
|
||||
FLogCount := 0;
|
||||
FLogVer := 0;
|
||||
FSpotCount := 0;
|
||||
{$IFDEF MSWINDOWS}
|
||||
WSAStartup($0202, wsa);
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
destructor TDXClusterClient.Destroy;
|
||||
begin
|
||||
Stop;
|
||||
FOutQueue.Free;
|
||||
FStopEvent.Free;
|
||||
FLock.Free;
|
||||
{$IFDEF MSWINDOWS}
|
||||
WSACleanup;
|
||||
{$ENDIF}
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
procedure TDXClusterClient.Configure(const AHost: string; APort: Integer;
|
||||
const ALogin, APassword, APostLogin: string);
|
||||
begin
|
||||
FLock.Enter;
|
||||
try
|
||||
// Смена адреса/учётки — команды, набранные для ПРЕЖНЕГО кластера, теряют
|
||||
// смысл (и ушли бы на новый). Чистим очередь.
|
||||
if (FHost <> Trim(AHost)) or (FPort <> APort) or (FLogin <> Trim(ALogin)) then
|
||||
FOutQueue.Clear;
|
||||
FHost := Trim(AHost);
|
||||
FPort := APort;
|
||||
FLogin := Trim(ALogin);
|
||||
FPassword := APassword;
|
||||
FPostLogin := APostLogin;
|
||||
finally
|
||||
FLock.Leave;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TDXClusterClient.Start;
|
||||
begin
|
||||
if FThread <> nil then Exit;
|
||||
FLock.Enter;
|
||||
try
|
||||
if (FHost = '') or (FLogin = '') then
|
||||
begin
|
||||
FState := dxsError;
|
||||
FStatusMsg := 'host or callsign not set';
|
||||
Exit;
|
||||
end;
|
||||
finally
|
||||
FLock.Leave;
|
||||
end;
|
||||
FStopEvent.ResetEvent;
|
||||
SetState(dxsConnecting, '');
|
||||
FThread := TDXClusterThread.Create(Self);
|
||||
end;
|
||||
|
||||
procedure TDXClusterClient.Stop;
|
||||
var T: TThread;
|
||||
begin
|
||||
// Всё, что не успели отправить, к следующему соединению уже неактуально.
|
||||
FLock.Enter;
|
||||
try
|
||||
FOutQueue.Clear;
|
||||
finally
|
||||
FLock.Leave;
|
||||
end;
|
||||
|
||||
T := FThread;
|
||||
if T = nil then
|
||||
begin
|
||||
SetState(dxsOff, '');
|
||||
Exit;
|
||||
end;
|
||||
FThread := nil;
|
||||
T.Terminate;
|
||||
FStopEvent.SetEvent;
|
||||
// Сокет закрывает сам поток (TDXClusterThread.CloseSock из Execute);
|
||||
// FStopEvent + Terminate выводят его из ожиданий, а recv рвётся по таймауту.
|
||||
T.WaitFor;
|
||||
T.Free;
|
||||
SetState(dxsOff, '');
|
||||
end;
|
||||
|
||||
function TDXClusterClient.Running: Boolean;
|
||||
begin
|
||||
Result := FThread <> nil;
|
||||
end;
|
||||
|
||||
procedure TDXClusterClient.SetState(St: TDXClusterState; const Msg: string);
|
||||
begin
|
||||
FLock.Enter;
|
||||
try
|
||||
FState := St;
|
||||
FStatusMsg := Msg;
|
||||
Inc(FLogVer); // UI перечитает и статус тоже
|
||||
finally
|
||||
FLock.Leave;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TDXClusterClient.State: TDXClusterState;
|
||||
begin
|
||||
FLock.Enter;
|
||||
try
|
||||
Result := FState;
|
||||
finally
|
||||
FLock.Leave;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TDXClusterClient.StateText: string;
|
||||
begin
|
||||
Result := DXStateName(State);
|
||||
end;
|
||||
|
||||
function TDXClusterClient.StatusMessage: string;
|
||||
begin
|
||||
FLock.Enter;
|
||||
try
|
||||
Result := FStatusMsg;
|
||||
finally
|
||||
FLock.Leave;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TDXClusterClient.SpotsReceived: Int64;
|
||||
begin
|
||||
FLock.Enter;
|
||||
try
|
||||
Result := FSpotCount;
|
||||
finally
|
||||
FLock.Leave;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TDXClusterClient.SendCommand(const S: string);
|
||||
begin
|
||||
if Trim(S) = '' then Exit;
|
||||
FLock.Enter;
|
||||
try
|
||||
FOutQueue.Add(S);
|
||||
finally
|
||||
FLock.Leave;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TDXClusterClient.AddLog(const S: string);
|
||||
begin
|
||||
FLock.Enter;
|
||||
try
|
||||
FLog[FLogHead] := S;
|
||||
FLogHead := (FLogHead + 1) mod DX_LOG_LINES;
|
||||
if FLogCount < DX_LOG_LINES then Inc(FLogCount);
|
||||
Inc(FLogVer);
|
||||
finally
|
||||
FLock.Leave;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TDXClusterClient.GetLog(Dst: TStrings);
|
||||
var i, Start: Integer;
|
||||
begin
|
||||
if Dst = nil then Exit;
|
||||
FLock.Enter;
|
||||
try
|
||||
Start := (FLogHead - FLogCount + DX_LOG_LINES) mod DX_LOG_LINES;
|
||||
for i := 0 to FLogCount - 1 do
|
||||
Dst.Add(FLog[(Start + i) mod DX_LOG_LINES]);
|
||||
finally
|
||||
FLock.Leave;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TDXClusterClient.LogVersion: Int64;
|
||||
begin
|
||||
FLock.Enter;
|
||||
try
|
||||
Result := FLogVer;
|
||||
finally
|
||||
FLock.Leave;
|
||||
end;
|
||||
end;
|
||||
|
||||
{ ── TDXClusterThread ─────────────────────────────────────────────────────── }
|
||||
|
||||
constructor TDXClusterThread.Create(AOwner: TDXClusterClient);
|
||||
begin
|
||||
FOwner := AOwner;
|
||||
FSocket := SOCK_INVALID;
|
||||
FreeOnTerminate := False;
|
||||
inherited Create(False);
|
||||
end;
|
||||
|
||||
function TDXClusterThread.Resolve(const Host: string; out Addr: LongWord): Boolean;
|
||||
// Возвращает адрес в СЕТЕВОМ порядке байт (готов для sin_addr).
|
||||
{$IFNDEF MSWINDOWS}
|
||||
var HE: THostEntry; HA: THostAddr;
|
||||
{$ELSE}
|
||||
var PH: PHostEnt; L: LongWord;
|
||||
{$ENDIF}
|
||||
begin
|
||||
Result := False;
|
||||
Addr := 0;
|
||||
if Host = '' then Exit;
|
||||
{$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);
|
||||
end;
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
function TDXClusterThread.ConnectSock: Boolean;
|
||||
// Неблокирующий connect + select: мёртвый хост не держит поток минуту на
|
||||
// системном таймауте TCP, и Stop() отрабатывает быстро.
|
||||
var
|
||||
Addr: {$IFDEF MSWINDOWS}TSockAddrIn{$ELSE}TInetSockAddr{$ENDIF};
|
||||
IP: LongWord;
|
||||
R, SoErr: Integer;
|
||||
FDS: TFDSet;
|
||||
TV: TTimeVal;
|
||||
One, Waited: Integer;
|
||||
{$IFDEF MSWINDOWS}ErrLen: Integer;{$ELSE}ErrLen: TSockLen;{$ENDIF}
|
||||
begin
|
||||
Result := False;
|
||||
if not Resolve(FHost, IP) then
|
||||
begin
|
||||
FOwner.SetState(dxsRetry, 'cannot resolve ' + FHost);
|
||||
FOwner.AddLog('*** DNS: cannot resolve ' + FHost);
|
||||
Exit;
|
||||
end;
|
||||
|
||||
{$IFDEF MSWINDOWS}
|
||||
FSocket := socket(AF_INET, SOCK_STREAM, IPPROTO_TCP);
|
||||
{$ELSE}
|
||||
FSocket := fpSocket(AF_INET, SOCK_STREAM, IPPROTO_TCP);
|
||||
{$ENDIF}
|
||||
if FSocket = SOCK_INVALID then
|
||||
begin
|
||||
FOwner.SetState(dxsRetry, 'cannot create socket');
|
||||
Exit;
|
||||
end;
|
||||
|
||||
FillChar(Addr, SizeOf(Addr), 0);
|
||||
Addr.sin_family := AF_INET;
|
||||
Addr.sin_port := htons(FPort);
|
||||
Addr.sin_addr.s_addr := IP;
|
||||
|
||||
SockSetNonBlock(FSocket, True);
|
||||
{$IFDEF MSWINDOWS}
|
||||
R := WinSock2.connect(FSocket, @Addr, SizeOf(Addr));
|
||||
{$ELSE}
|
||||
R := fpConnect(FSocket, @Addr, SizeOf(Addr));
|
||||
{$ENDIF}
|
||||
if R <> 0 then
|
||||
begin
|
||||
// ожидаемо: EINPROGRESS / WSAEWOULDBLOCK — ждём готовности на запись.
|
||||
// Ждём НЕ одним select на 8 с, а квантами по DX_CONNECT_SLICE_MS: иначе
|
||||
// Stop() (закрытие программы) висел бы до конца таймаута соединения.
|
||||
Waited := 0;
|
||||
R := 0;
|
||||
while (Waited < DX_CONNECT_MS) and (not Terminated) do
|
||||
begin
|
||||
TV.tv_sec := DX_CONNECT_SLICE_MS div 1000;
|
||||
TV.tv_usec := (DX_CONNECT_SLICE_MS mod 1000) * 1000;
|
||||
{$IFDEF MSWINDOWS}
|
||||
FD_ZERO(FDS);
|
||||
FD_SET(FSocket, FDS);
|
||||
R := select(0, nil, @FDS, nil, @TV);
|
||||
{$ELSE}
|
||||
fpFD_ZERO(FDS);
|
||||
fpFD_SET(FSocket, FDS);
|
||||
R := fpSelect(FSocket + 1, nil, @FDS, nil, @TV);
|
||||
{$ENDIF}
|
||||
if R <> 0 then Break; // готов или ошибка select
|
||||
Inc(Waited, DX_CONNECT_SLICE_MS);
|
||||
end;
|
||||
if Terminated then
|
||||
begin
|
||||
CloseSock;
|
||||
Exit;
|
||||
end;
|
||||
if R <= 0 then
|
||||
begin
|
||||
CloseSock;
|
||||
FOwner.SetState(dxsRetry, 'connect timeout: ' + FHost);
|
||||
FOwner.AddLog('*** no answer from ' + FHost + ':' + IntToStr(FPort));
|
||||
Exit;
|
||||
end;
|
||||
SoErr := 0; ErrLen := SizeOf(SoErr);
|
||||
{$IFDEF MSWINDOWS}
|
||||
getsockopt(FSocket, SOL_SOCKET, SO_ERROR, PChar(@SoErr), ErrLen);
|
||||
{$ELSE}
|
||||
fpGetSockOpt(FSocket, SOL_SOCKET, SO_ERROR, @SoErr, @ErrLen);
|
||||
{$ENDIF}
|
||||
if SoErr <> 0 then
|
||||
begin
|
||||
CloseSock;
|
||||
FOwner.SetState(dxsRetry, 'connection refused');
|
||||
FOwner.AddLog('*** refused: ' + FHost + ':' + IntToStr(FPort));
|
||||
Exit;
|
||||
end;
|
||||
end;
|
||||
|
||||
SockSetNonBlock(FSocket, False);
|
||||
SockSetRcvTimeout(FSocket, DX_RECV_MS);
|
||||
SockSetSndTimeout(FSocket, 5000);
|
||||
One := 1;
|
||||
{$IFDEF MSWINDOWS}
|
||||
setsockopt(FSocket, SOL_SOCKET, SO_KEEPALIVE, PChar(@One), SizeOf(One));
|
||||
{$ELSE}
|
||||
fpSetSockOpt(FSocket, SOL_SOCKET, SO_KEEPALIVE, @One, SizeOf(One));
|
||||
{$ENDIF}
|
||||
Result := True;
|
||||
end;
|
||||
|
||||
procedure TDXClusterThread.CloseSock;
|
||||
begin
|
||||
if FSocket <> SOCK_INVALID then
|
||||
begin
|
||||
SockShutdown(FSocket);
|
||||
SockClose(FSocket);
|
||||
FSocket := SOCK_INVALID;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TDXClusterThread.SendAll(const Data: string): Boolean;
|
||||
// TCP вправе отправить меньше запрошенного — дописываем остаток. Таймаут
|
||||
// (SO_SNDTIMEO) и EINTR — не ошибка соединения, пробуем ещё, но не бесконечно.
|
||||
var
|
||||
Sent, N, Tries: Integer;
|
||||
begin
|
||||
Result := False;
|
||||
if (FSocket = SOCK_INVALID) or (Data = '') then Exit;
|
||||
Sent := 0;
|
||||
Tries := 0;
|
||||
while Sent < Length(Data) do
|
||||
begin
|
||||
if Terminated then Exit;
|
||||
N := SockSend(FSocket, @Data[Sent + 1], Length(Data) - Sent, 0);
|
||||
if N > 0 then
|
||||
begin
|
||||
Inc(Sent, N);
|
||||
Tries := 0;
|
||||
end
|
||||
else
|
||||
begin
|
||||
if not SockWouldBlock then Exit; // настоящая ошибка сокета
|
||||
Inc(Tries);
|
||||
if Tries > DX_SEND_RETRIES then Exit; // не отдаёт буфер — считаем разрывом
|
||||
end;
|
||||
end;
|
||||
Result := True;
|
||||
end;
|
||||
|
||||
function TDXClusterThread.SendLine(const S: string): Boolean;
|
||||
begin
|
||||
Result := SendAll(S + #13#10);
|
||||
if not Result then
|
||||
FOwner.AddLog('*** send failed, dropping connection');
|
||||
end;
|
||||
|
||||
procedure TDXClusterThread.FlushOutQueue;
|
||||
var
|
||||
Pending: TStringList;
|
||||
i: Integer;
|
||||
begin
|
||||
Pending := nil;
|
||||
FOwner.FLock.Enter;
|
||||
try
|
||||
if FOwner.FOutQueue.Count > 0 then
|
||||
begin
|
||||
Pending := TStringList.Create;
|
||||
Pending.Assign(FOwner.FOutQueue);
|
||||
FOwner.FOutQueue.Clear;
|
||||
end;
|
||||
finally
|
||||
FOwner.FLock.Leave;
|
||||
end;
|
||||
if Pending = nil then Exit;
|
||||
try
|
||||
for i := 0 to Pending.Count - 1 do
|
||||
begin
|
||||
if not SendLine(Pending[i]) then Break; // сокет умер — остальное на реконнект
|
||||
FOwner.AddLog('> ' + Pending[i]);
|
||||
end;
|
||||
finally
|
||||
Pending.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TDXClusterThread.CheckPrompts(const Tail: string);
|
||||
// Приглашения логина И пароля обычно приходят БЕЗ перевода строки, поэтому
|
||||
// ищем их и в незавершённом хвосте буфера, а не только в целых строках.
|
||||
// Флаги FLoginSent/FPassSent держат отправку однократной: хвост проверяется
|
||||
// заново с каждым пришедшим куском.
|
||||
var U: string;
|
||||
begin
|
||||
if Tail = '' then Exit;
|
||||
U := LowerCase(Tail);
|
||||
|
||||
if not FLoginSent then
|
||||
begin
|
||||
if (Pos('login:', U) > 0) or (Pos('call:', U) > 0) or
|
||||
(Pos('callsign', U) > 0) or (Pos('your call', U) > 0) or
|
||||
(Pos('enter your', U) > 0) then
|
||||
begin
|
||||
if not SendLine(FLogin) then Exit;
|
||||
FOwner.AddLog('> ' + FLogin);
|
||||
FLoginSent := True;
|
||||
FLoginAt := Now;
|
||||
FOwner.SetState(dxsLogin, '');
|
||||
end;
|
||||
Exit;
|
||||
end;
|
||||
|
||||
if (FPassword <> '') and (not FPassSent) and (Pos('password', U) > 0) then
|
||||
begin
|
||||
if not SendLine(FPassword) then Exit;
|
||||
FOwner.AddLog('> ********');
|
||||
FPassSent := True;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TDXClusterThread.HandleLine(const Line: string);
|
||||
var
|
||||
Spot: TDXSpot;
|
||||
begin
|
||||
if Line = '' then Exit;
|
||||
FOwner.AddLog(Line);
|
||||
|
||||
if ParseDXSpot(Line, Spot) then
|
||||
begin
|
||||
FOwner.FStore.Add(Spot);
|
||||
FOwner.FLock.Enter;
|
||||
try
|
||||
Inc(FOwner.FSpotCount);
|
||||
finally
|
||||
FOwner.FLock.Leave;
|
||||
end;
|
||||
if FOwner.State <> dxsOnline then FOwner.SetState(dxsOnline, '');
|
||||
Exit;
|
||||
end;
|
||||
|
||||
CheckPrompts(Line);
|
||||
end;
|
||||
|
||||
procedure TDXClusterThread.HandleChunk(const Data: string);
|
||||
var
|
||||
P: Integer;
|
||||
Line: string;
|
||||
begin
|
||||
FRxBuf := FRxBuf + Data;
|
||||
while True do
|
||||
begin
|
||||
P := 1;
|
||||
while (P <= Length(FRxBuf)) and not (FRxBuf[P] in [#10, #13]) do Inc(P);
|
||||
if P > Length(FRxBuf) then Break; // перевода строки ещё нет
|
||||
Line := Copy(FRxBuf, 1, P - 1);
|
||||
// съедаем весь конец строки (CR, LF или CRLF)
|
||||
while (P <= Length(FRxBuf)) and (FRxBuf[P] in [#10, #13]) do Inc(P);
|
||||
Delete(FRxBuf, 1, P - 1);
|
||||
HandleLine(TrimRight(Line));
|
||||
end;
|
||||
|
||||
// Хвост без перевода строки — возможно, это приглашение логина или пароля.
|
||||
if FRxBuf <> '' then CheckPrompts(FRxBuf);
|
||||
// Защита от мусора без переводов строк.
|
||||
if Length(FRxBuf) > 8192 then FRxBuf := '';
|
||||
end;
|
||||
|
||||
function TDXClusterThread.Session: Boolean;
|
||||
var
|
||||
Buf: array[0..4095] of Byte;
|
||||
N: Integer;
|
||||
Chunk: string;
|
||||
PL: TStringList;
|
||||
i: Integer;
|
||||
begin
|
||||
Result := True;
|
||||
FRxBuf := '';
|
||||
FLoginSent := False;
|
||||
FPassSent := False;
|
||||
FPostSent := False;
|
||||
FConnectAt := Now;
|
||||
|
||||
FOwner.SetState(dxsConnecting, FHost + ':' + IntToStr(FPort));
|
||||
FOwner.AddLog('*** connecting to ' + FHost + ':' + IntToStr(FPort));
|
||||
if not ConnectSock then Exit;
|
||||
|
||||
FOwner.AddLog('*** connected');
|
||||
FOwner.SetState(dxsLogin, '');
|
||||
|
||||
while not Terminated do
|
||||
begin
|
||||
N := SockRecv(FSocket, @Buf[0], SizeOf(Buf), 0);
|
||||
if N > 0 then
|
||||
begin
|
||||
SetLength(Chunk, N);
|
||||
Move(Buf[0], Chunk[1], N);
|
||||
HandleChunk(Chunk);
|
||||
end
|
||||
else if N = 0 then
|
||||
begin
|
||||
FOwner.AddLog('*** connection closed by peer');
|
||||
Break;
|
||||
end
|
||||
else if not SockWouldBlock then
|
||||
begin
|
||||
// Не таймаут кванта recv, а настоящая ошибка сокета — уходим на реконнект.
|
||||
FOwner.AddLog('*** connection lost (socket error)');
|
||||
Break;
|
||||
end;
|
||||
|
||||
if Terminated then Break;
|
||||
|
||||
// Приглашения не дождались — шлём позывной сами (часть кластеров молчит).
|
||||
if (not FLoginSent) and (SecondsBetween(Now, FConnectAt) >= DX_LOGIN_GRACE_S) then
|
||||
begin
|
||||
if not SendLine(FLogin) then Break; // сокет умер — на реконнект
|
||||
FOwner.AddLog('> ' + FLogin + ' (no prompt seen)');
|
||||
FLoginSent := True;
|
||||
FLoginAt := Now;
|
||||
end;
|
||||
|
||||
// Post-login команды — один раз, чуть погодя после позывного.
|
||||
if FLoginSent and (not FPostSent) and
|
||||
(SecondsBetween(Now, FLoginAt) >= DX_POSTLOGIN_S) 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 FOwner.State <> dxsOnline then FOwner.SetState(dxsOnline, '');
|
||||
end;
|
||||
|
||||
FlushOutQueue;
|
||||
end;
|
||||
|
||||
CloseSock;
|
||||
Result := not Terminated;
|
||||
end;
|
||||
|
||||
procedure TDXClusterThread.Execute;
|
||||
var
|
||||
Backoff: Integer;
|
||||
begin
|
||||
Backoff := DX_RECONNECT_MIN;
|
||||
// Снимок конфига на всю жизнь потока: Configure во время работы применяется
|
||||
// следующим Start (так же ведёт себя веб-сервер при смене порта).
|
||||
FOwner.FLock.Enter;
|
||||
try
|
||||
FHost := FOwner.FHost;
|
||||
FPort := FOwner.FPort;
|
||||
FLogin := FOwner.FLogin;
|
||||
FPassword := FOwner.FPassword;
|
||||
FPostLogin := FOwner.FPostLogin;
|
||||
finally
|
||||
FOwner.FLock.Leave;
|
||||
end;
|
||||
|
||||
while not Terminated do
|
||||
begin
|
||||
if not Session then Break;
|
||||
if Terminated then Break;
|
||||
|
||||
FOwner.SetState(dxsRetry, 'reconnecting in ' + IntToStr(Backoff) + ' s');
|
||||
FOwner.AddLog('*** reconnecting in ' + IntToStr(Backoff) + ' s');
|
||||
if FOwner.FStopEvent.WaitFor(Backoff * 1000) = wrSignaled then Break;
|
||||
Backoff := Backoff * 2;
|
||||
if Backoff > DX_RECONNECT_MAX then Backoff := DX_RECONNECT_MAX;
|
||||
end;
|
||||
CloseSock;
|
||||
end;
|
||||
|
||||
end.
|
||||
Reference in New Issue
Block a user