diff --git a/DXClusterClient.pas b/DXClusterClient.pas index ce5be8b..f3d0047 100644 --- a/DXClusterClient.pas +++ b/DXClusterClient.pas @@ -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. diff --git a/DXClusterForm.pas b/DXClusterForm.pas index 9aa680c..3268278 100644 --- a/DXClusterForm.pas +++ b/DXClusterForm.pas @@ -283,12 +283,22 @@ procedure TDXClusterForm.RefreshSpots; var i, j, Keep: Integer; T: TDXSpot; - Sel: string; + SelCall: string; + SelFreq: Double; begin if FStore = nil then Exit; + // Что выделено — запоминаем позывным И частотой: стор намеренно держит один + // позывной на разных диапазонах, и по одному позывному выделение после + // обновления перескочило бы на первый совпавший, а Enter/двойной клик увёл бы + // радио не на тот диапазон. Keep := FList.ItemIndex; - Sel := ''; - if (Keep >= 0) and (Keep < Length(FSpots)) then Sel := FSpots[Keep].Call; + SelCall := ''; + SelFreq := 0; + if (Keep >= 0) and (Keep < Length(FSpots)) then + begin + SelCall := FSpots[Keep].Call; + SelFreq := FSpots[Keep].FreqHz; + end; FStore.Snapshot(FSpots); // приходит отсортированным по частоте if not FSortFreq then @@ -314,10 +324,12 @@ begin FList.Items.EndUpdate; end; - // Держим выделение на том же позывном, если он ещё в списке. - if Sel <> '' then + // Держим выделение на том же споте, если он ещё в списке. Допуск по частоте — + // тот же, что у дедупа стора: спот того же позывного мог чуть подвинуться. + if SelCall <> '' then for i := 0 to High(FSpots) do - if SameText(FSpots[i].Call, Sel) then + if SameText(FSpots[i].Call, SelCall) and + (Abs(FSpots[i].FreqHz - SelFreq) <= DX_DEDUP_HZ) then begin FList.ItemIndex := i; Break; diff --git a/DXSpotStore.pas b/DXSpotStore.pas index 33d5079..18577ca 100644 --- a/DXSpotStore.pas +++ b/DXSpotStore.pas @@ -74,6 +74,10 @@ type // Добавить/обновить спот (вызывается из потока кластера). procedure Add(const S: TDXSpot); procedure Clear; + // Выбросить просроченное прямо сейчас. Нужен тому, кто следит за временем + // снаружи: сам стор чистится только на Add и снимках, а когда споты никто + // не берёт и не приходит новых, устаревать им иначе негде. + procedure Purge; // Снимок всех спотов, отсортированный по частоте. function Snapshot(out Arr: TDXSpotArray): Integer; @@ -338,6 +342,16 @@ begin end; end; +procedure TDXSpotStore.Purge; +begin + FLock.Enter; + try + PurgeLocked; // сам поднимет Version, если что-то выбросил + finally + FLock.Leave; + end; +end; + procedure TDXSpotStore.Clear; begin FLock.Enter; diff --git a/MainForm.pas b/MainForm.pas index 812739d..9857dc4 100644 --- a/MainForm.pas +++ b/MainForm.pas @@ -5168,9 +5168,16 @@ begin if FDXPending and (MilliSecondsBetween(Now, FDXPendingAt) >= DX_SETTINGS_QUIET_MS) then CommitDXClusterSettings; - if FDXSpotOverlay = nil then Exit; if SecondsBetween(Now, FDXAgeTickAt) < DX_AGE_TICK_SEC then Exit; FDXAgeTickAt := Now; + + // TTL — свойство базы, а не картинки. Стор чистится только внутри Add и + // снимков, поэтому с выключенными подписями и молчащим (или отключённым) + // кластером просроченные споты не выбрасывал бы никто: новых Add нет, версия + // стора не меняется, окно списка снимок не берёт, тик оверлея выключен. + if FDXStore <> nil then FDXStore.Purge; + + if FDXSpotOverlay = nil then Exit; if not FDXSpotOverlay.Active then Exit; // Тик получают оверлеи всех панов: возраст спота от пана не зависит. for i := 0 to MAX_PANS - 1 do @@ -5198,6 +5205,10 @@ begin FDXCfg.ShowSpots := not FDXCfg.ShowSpots; ApplyDXClusterSettings(FDXCfg); FController.FSettings.SaveDXClusterSettings(FDXCfg); + // Правки SETUP ждут тишины в СВОЕЙ копии конфига. Не поправив её, отложенный + // коммит записал бы старый FDXPendingCfg целиком и молча вернул прежнее + // состояние тумблера — на экране новое, в файле старое. + if FDXPending then FDXPendingCfg.ShowSpots := FDXCfg.ShowSpots; // Открытый SETUP держит СВОЮ копию конфига: без синхронизации галка «Show // spots» осталась бы старой, и первая же правка любого поля на этой странице // вернула бы подписи обратно. @@ -5240,10 +5251,15 @@ end; procedure TMainForm.OnDXTuneSpot(FreqHz: Double; Mode: TDXMode); // QSY по споту: клик по подписи на главном пане или двойной клик в окне списка. +// Крутим ТОТ VFO, который сейчас активен, — ровно как обычный клик по спектру +// (DoSpectrumClick): иначе при активном B спот уводил бы неактивный A. var NewMode: Integer; begin if FreqHz <= 0 then Exit; - ApplyVfoA(Round(FreqHz)); + if FController.FActiveVfo = 0 then + ApplyVfoA(Round(FreqHz)) + else + FController.SetVfoB(Round(FreqHz)); // рендер через OnControllerState(rfVfoB) NewMode := DXSpotRadioMode(FreqHz, Mode); if (NewMode >= 0) and (NewMode <> FController.FMode) then FController.SetMode(NewMode);