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).

  ★Резолв имени вынесен в ОТДЕЛЬНЫЙ поток. Системный резолвер (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 ', в стор не идёт — только в лог.
}

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

interface

uses
  Classes, SysUtils, SyncObjs, StrUtils, DateUtils,
  WebUtils,        // SockClose/SockShutdown/SockRecv/SockSend/SOCK_INVALID
  DXSpotStore
  // ★ Windows.pas здесь НЕТ намеренно: он объявляет TCriticalSection как
  // ЗАПИСЬ (алиас TRTLCriticalSection) и, стоя в uses после SyncObjs,
  // перекрывал класс — под win64 сборка падала на TCriticalSection.Create
  // («identifier idents no member Create»). Всё, что нужно сокетам, даёт
  // WinSock2; так же сделано в WsClient и HPSDRNetwork.
  {$IFDEF MSWINDOWS}
    , WinSock2
  {$ELSE}
    , BaseUnix, Sockets, netdb, ctypes
  {$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_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;       // пауза после последнего шага логина
  DX_PASSWORD_WAIT_S = 8;     // ждём приглашение пароля, потом считаем, что его не будет
  DX_LOGIN_MAX_S   = 20;      // сервер молчит после позывного — идём дальше вслепую
  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;       // не владеет

    // Сокет живого соединения — зеркало под FLock. Нужен ровно для того, чтобы
    // Stop() мог сделать SockShutdown и вывести поток из блокирующего recv:
    // иначе выход из программы ждал бы до конца кванта recv (и до конца
    // таймаута send, если кластер перестал забирать данные). Поток снимает
    // зеркало ДО close, поэтому под локом хэндл гарантированно ещё открыт.
    FActiveSock: TSocket;

    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);
    procedure PublishSock(S: TSocket);   // зеркало хэндла для Stop (см. FActiveSock)
  public
    constructor Create(AStore: TDXSpotStore);
    destructor  Destroy; override;

    procedure Configure(const AHost: string; APort: Integer;
      const ALogin, APassword, APostLogin: string);
    procedure Start;
    // Неблокирующая половина Stop: разбудить поток и порвать сокет, не дожидаясь
    // его конца. Зовётся в начале выхода из программы, чтобы поток доживал
    // ПАРАЛЛЕЛЬНО с разборкой радио, а join в Stop уже никого не ждал.
    procedure RequestStop;
    procedure Stop;              // RequestStop + join
    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
  // Запрос на резолв, общий для сессии и одноразового резолвер-потока. Живёт в
  // куче по счётчику ссылок: одна у резолвера, по одной у каждой ждущей сессии.
  // Кто уронил 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;
    FSocket: TSocket;
    FRxBuf:  string;             // хвост неполной строки

    // конфиг сессии (снимок на время соединения)
    FHost:     string;
    FPort:     Integer;
    FLogin:    string;
    FPassword: string;
    FPostLogin: string;

    FLoginSent:  Boolean;
    FLoginByPrompt: Boolean;  // позывной ушёл в ответ на приглашение, не вслепую
    FPassSent:   Boolean;
    FPostSent:   Boolean;
    FLoginAt:    TDateTime;   // когда ушёл позывной
    FLoginStepAt: TDateTime;  // когда ушла последняя порция учётки (позывной/пароль)
    FSawAfterLogin: Boolean;  // после учётки сервер что-то прислал
    FConnectAt:  TDateTime;
    FFatal:      Boolean;     // отказ авторизации — реконнект бессмыслен
    // Приглашение, на которое мы только что ответили, разобрав НЕЗАВЕРШЁННЫЙ
    // хвост. Оно остаётся в буфере и со следующим куском доедет целой строкой —
    // окно ровно на одну строку, чтобы не счесть собственное эхо новым вопросом.
    FAnsweredPrompt: string;

    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;
    function  SendLine(const S: string): Boolean;
    procedure FlushOutQueue;
    procedure HandleChunk(const Data: string);
    procedure HandleLine(const Line: string);
    procedure CheckPrompts(const Tail: string; IsTail: Boolean);
    function  Session: Boolean;    // одно соединение; False — выйти совсем
  protected
    procedure Execute; override;
  public
    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
    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);
  // Комментарий молчит — берём моду с участка бэндплана: в CW и SSB её сплошь
  // и рядом просто не пишут, а участок эти две моды разделяет надёжно.
  // Помечаем такой спот: угаданное не должно выглядеть как сказанное спотером.
  Spot.ModeGuessed := False;
  if Spot.Mode = dxmUnknown then
  begin
    Spot.Mode := DXModeFromFreq(Spot.FreqHz);
    Spot.ModeGuessed := Spot.Mode <> dxmUnknown;
  end;
  Spot.Stamp := Now;
  Result := True;
end;

{ ── TDXClusterClient ─────────────────────────────────────────────────────── }

constructor TDXClusterClient.Create(AStore: TDXSpotStore);
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;
  FActiveSock := SOCK_INVALID;
  // WSAStartup/WSACleanup здесь БЫЛИ и убраны — см. initialization юнита.
end;

destructor TDXClusterClient.Destroy;
begin
  Stop;
  FOutQueue.Free;
  FStopEvent.Free;
  FLock.Free;
  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
  // Поток прошлой сессии мог завершиться сам (кластер отверг логин) — прибираем
  // его, иначе 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
    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.RequestStop;
begin
  // Всё, что не успели отправить, к следующему соединению уже неактуально.
  FLock.Enter;
  try
    FOutQueue.Clear;
  finally
    FLock.Leave;
  end;
  if FThread = nil then Exit;
  FThread.Terminate;
  FStopEvent.SetEvent;
  // Терминации мало: поток стоит в блокирующем recv и проснулся бы только по
  // SO_RCVTIMEO (до DX_RECV_MS), а на застрявшем send — до SO_SNDTIMEO. Всё это
  // время join держал бы главный поток, т.е. окно висело бы на выходе и на
  // переподключении после правки настроек. SockShutdown рвёт обе стороны
  // немедленно (на Linux одного close мало — см. WebUtils.SockShutdown).
  // Закрывает сокет по-прежнему сам поток: закрыть чужой хэндл значило бы
  // гонку с его же recv.
  FLock.Enter;
  try
    if FActiveSock <> SOCK_INVALID then SockShutdown(FActiveSock);
  finally
    FLock.Leave;
  end;
end;

procedure TDXClusterClient.Stop;
var T: TThread;
begin
  RequestStop;
  T := FThread;
  if T = nil then
  begin
    SetState(dxsOff, '');
    Exit;
  end;
  FThread := nil;
  T.WaitFor;
  T.Free;
  SetState(dxsOff, '');
end;

function TDXClusterClient.Running: Boolean;
// Завершившийся сам поток (отказ авторизации) — уже не «работаем»: иначе окно
// кластера показывало бы DISCONNECT у мёртвого соединения.
begin
  Result := (FThread <> nil) and (not FThread.Finished);
end;

procedure TDXClusterClient.PublishSock(S: TSocket);
// Зеркало хэндла для Stop. Поток зовёт с валидным хэндлом сразу после connect
// и с SOCK_INVALID ПЕРЕД close — так Stop под локом видит либо живой сокет,
// либо ничего, но не закрытый.
begin
  FLock.Enter;
  try
    FActiveSock := S;
  finally
    FLock.Leave;
  end;
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);
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);
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;

{ ── Резолв имени ─────────────────────────────────────────────────────────── }

{$IFNDEF MSWINDOWS}
// 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 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}
  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}
  // Системный путь: 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() отрабатывает быстро.
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;
  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);
  {$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}
  FOwner.PublishSock(FSocket);   // с этого момента Stop может рвать нас shutdown'ом
  Result := True;
end;

procedure TDXClusterThread.CloseSock;
begin
  if FSocket <> SOCK_INVALID then
  begin
    FOwner.PublishSock(SOCK_INVALID);   // до close: Stop не должен увидеть мёртвый хэндл
    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, j: 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
    i := 0;
    while i < Pending.Count do
    begin
      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;

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 = '') or FFatal 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);
      if IsTail then FAnsweredPrompt := TrimRight(U);
      FLoginSent  := True;
      FLoginByPrompt := True;    // ответили на вопрос, а не выстрелили вслепую
      FLoginAt    := Now;
      FLoginStepAt := FLoginAt;
      FSawAfterLogin := False;   // ждём ответ именно на позывной
      FOwner.SetState(dxsLogin, '');
    end;
    Exit;
  end;

  // Кластер снова просит позывной. Если наш ушёл ПО ПРИГЛАШЕНИЮ — его не
  // приняли, второй раз слать тот же нечего. Если же мы стреляли вслепую
  // (приглашения не дождались за 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('> ********');
    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);
    FOwner.FLock.Enter;
    try
      Inc(FOwner.FSpotCount);
    finally
      FOwner.FLock.Leave;
    end;
    if FOwner.State <> dxsOnline then FOwner.SetState(dxsOnline, '');
    Exit;
  end;

  CheckPrompts(Line, False);
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
  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;

function TDXClusterThread.Session: Boolean;
var
  Buf: array[0..4095] of Byte;
  N: Integer;
  Chunk: string;
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));
  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);
      // ★FSawAfterLogin здесь НЕ ставится. Приход байтов — факт транспортный, а
      // не протокольный: отдельным пакетом может доехать один лишь '\r\n',
      // закрывающий приглашение, на которое мы уже ответили, и «подтверждение
      // логина» зависело бы от того, как TCP порезал поток. Флаг ставит
      // HandleChunk/HandleLine — после разбора, по существу пришедшего.
      HandleChunk(Chunk);
      if FFatal then Break;      // логин отвергнут — реконнект не поможет
    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;
      FLoginByPrompt := False;   // вслепую: опоздавшее приглашение = не отказ
      FLoginAt     := Now;
      FLoginStepAt := FLoginAt;
      FSawAfterLogin := False;   // ждём ответ именно на позывной
    end;

    // Post-login команды — один раз, когда логин действительно пройден.
    if (not FPostSent) and LoginSettled then
    begin
      FPostSent := True;
      if not SendPostLogin then Break;   // сокет умер — вся сессия на реконнект
      if FOwner.State <> dxsOnline then FOwner.SetState(dxsOnline, '');
    end;

    // Команды пользователя — только после логина: до него кластер ждёт позывной
    // и пароль, и любая наша строка ушла бы вместо них. Очередь никуда не
    // девается, отправим следом.
    if FPostSent then FlushOutQueue;
  end;

  CloseSock;
  Result := (not Terminated) and (not FFatal);
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;

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.