Написал: rand
Специально для: xss.pro
Всем привет! Недавно заинтересовался задачей реализации протокола VNC на Free Pascal, вот скидываю свои наработки. Строго не судить. =)
IDE: Lazarus 4.0
Версиия FPC: 3.2.2
Скриншот клиента:
Скриншот работы серверной части:
Код клиентской части (все подробности в комментариях к коду):
Код серверной части:
Файлы проекта для компиляции (пароль на архив "xss.pro"): https://send.exploit.in/download/feb1e7092cad9c0f/#Tr0I7zF4qdgDLuC6b7btuQ
P.S. Активно продолжаю работу над HVNC, как закончу, обязательно выложу. =)
Специально для: xss.pro
Всем привет! Недавно заинтересовался задачей реализации протокола VNC на Free Pascal, вот скидываю свои наработки. Строго не судить. =)
IDE: Lazarus 4.0
Версиия FPC: 3.2.2
Скриншот клиента:
Скриншот работы серверной части:
Код клиентской части (все подробности в комментариях к коду):
Код:
unit ClientUnit;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls, ExtCtrls,
Windows, WinSock2, LMessages;
// Объявление внешней функции ioctlsocket из ws2_32.dll
function ioctlsocket(s: TSocket; cmd: Longint; argp: Pointer): Integer; stdcall; external 'ws2_32.dll';
// Функция Min уже определена в SysUtils, ее можно удалить
// function Min(a, b: Integer): Integer;
const
VNC_PORT = 5900; // Стандартный порт для VNC-соединения
WM_SOCKET = WM_USER + 1; // Пользовательское сообщение для асинхронных событий сокета
FIONREAD = $4004667F; // Команда для ioctlsocket, используемая для определения количества доступных байт в сокете
type
// Запись для заголовка данных экрана, передаваемых по сети
TScreenHeader = packed record
Width: DWORD; // Ширина изображения
Height: DWORD; // Высота изображения
DataSize: DWORD; // Размер данных изображения в байтах
end;
// Запись для сообщения о событии мыши
TMouseMsg = packed record
MsgType: Byte; // Тип сообщения (2 для мыши)
Buttons: Byte; // Битовая маска нажатых кнопок мыши
X: WORD; // X-координата курсора
Y: WORD; // Y-координата курсора
end;
// Запись для сообщения о событии клавиатуры
TKeyMsg = packed record
MsgType: Byte; // Тип сообщения (3 для клавиатуры)
IsDown: Byte; // 1, если клавиша нажата; 0, если отпущена
KeyCode: DWORD; // Код клавиши (виртуальный код)
end;
{ TClientForm }
TClientForm = class(TForm)
Button1: TButton; // Кнопка "Connect"
Button2: TButton; // Кнопка "Disconnect"
Button3: TButton; // Кнопка "Fullscreen"
Edit1: TEdit; // Поле ввода IP-адреса сервера
Edit2: TEdit; // Поле ввода порта сервера
Label1: TLabel; // Метка для IP-адреса
Label2: TLabel; // Метка для порта
Label3: TLabel; // Метка статуса
Memo1: TMemo; // Поле для логирования сообщений
Panel1: TPanel; // Панель для группировки элементов управления
ScrollBox1: TScrollBox; // Область прокрутки для PaintBox
PaintBox1: TPaintBox; // Компонент для отображения удаленного экрана
Timer1: TTimer; // Таймер для запроса обновлений экрана
// Обработчики событий формы
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
procedure FormKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
// Обработчики событий кнопок
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
procedure Memo1Change(Sender: TObject); // Обработчик изменения текста в Memo1 (возможно, пустой)
// Обработчики событий PaintBox
procedure PaintBox1Paint(Sender: TObject);
procedure PaintBox1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure PaintBox1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure PaintBox1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
procedure Timer1Timer(Sender: TObject); // Обработчик события таймера
private
FSocket: TSocket; // Дескриптор сокета
FConnected: Boolean; // Флаг состояния подключения
FWSAData: TWSADATA; // Структура данных Winsock
FScreenBitmap: Graphics.TBitmap; // Битовая карта для хранения изображения удаленного экрана
FScreenWidth: Integer; // Ширина удаленного экрана
FScreenHeight: Integer; // Высота удаленного экрана
FLogFile: TextFile; // Файловая переменная для логирования
FLogOpened: Boolean; // Флаг состояния лог-файла
FFullScreenForm: TForm; // Дополнительная форма для полноэкранного режима
// Буферизация данных для приема сетевого потока
FReceiveBuffer: PByte; // Указатель на буфер приема данных
FReceiveBufferSize: Integer; // Общий размер буфера приема
FReceiveBufferUsed: Integer; // Количество байт, фактически занятых в буфере
FExpectingHeader: Boolean; // Флаг, указывающий, ожидаем ли мы заголовок изображения
FCurrentHeader: TScreenHeader; // Текущий заголовок изображения
FImageDataReceived: Integer; // Количество полученных байт данных изображения для текущего кадра
FFullScreenMode: Boolean; // Новая переменная для отслеживания состояния полноэкранного режима
FOriginalBorderStyle: TBorderStyle; // Новая переменная для сохранения исходного BorderStyle основной формы
FOriginalWindowState: TWindowState; // Новая переменная для сохранения исходного WindowState основной формы
// Приватные процедуры
procedure SafeLog(const Msg: string); // Процедура для безопасного логирования сообщений
procedure ConnectToServer; // Процедура для установки соединения с сервером
procedure DisconnectFromServer; // Процедура для разрыва соединения с сервером
procedure ProcessServerData; // Процедура для обработки данных, полученных от сервера
procedure RequestUpdate; // Процедура для отправки запроса на обновление экрана серверу
procedure SendMouseEvent(X, Y: Integer; Buttons: Byte); // Процедура для отправки событий мыши серверу
procedure SendKeyEvent(KeyCode: DWORD; IsDown: Boolean); // Процедура для отправки событий клавиатуры серверу
procedure UpdateDisplay; // Процедура для обновления отображения экрана
procedure SetStatus(const Msg: string); // Процедура для установки текстового статуса в Label3
procedure UpdateBitmapRegion(DataOffset: Integer; DataSize: Integer); // Процедура для обновления части битмапа данными
procedure DelayedRequestUpdate(Data: PtrInt); // Отложенный запрос обновления (используется с AsyncCall)
function ShiftStateToStr(Shift: TShiftState): string; // Вспомогательная функция для преобразования ShiftState в строку
protected
procedure WMSocket(var Message: TLMessage); message WM_SOCKET; // Обработчик пользовательского сообщения WM_SOCKET
public
end;
var
ClientForm: TClientForm; // Экземпляр главной формы
implementation
{$R *.lfm}
// Назначение: Вспомогательная функция, которая возвращает меньшее из двух чисел типа Double.
// Как работает:
// 1. Принимает два аргумента типа Double, `a` и `b`.
// 2. Сравнивает их. Если `a` меньше `b`, возвращает `a`. В противном случае возвращает `b`.
function MinDouble(a, b: Double): Double;
begin
if a < b then Result := a else Result := b;
end;
// Назначение: Процедура для безопасного логирования сообщений как в Memo1, так и в текстовый файл.
// Как работает:
// 1. Форматирует текущее время и добавляет его к сообщению.
// 2. Если Memo1 существует, добавляет сообщение в его строки, ограничивая их количество до 50 для предотвращения переполнения памяти.
// 3. Вызывает `Application.ProcessMessages` для немедленного обновления GUI.
// 4. Если лог-файл открыт (`FLogOpened` = True), записывает сообщение в файл и немедленно сбрасывает буфер (`Flush`) для обеспечения актуальности лога.
// 5. Вся логика заключена в блок `try..except` для игнорирования ошибок, которые могут возникнуть при логировании (например, если Memo1 не инициализирован).
procedure TClientForm.SafeLog(const Msg: string);
var
TimeStr: string;
FullMsg: string;
begin
try
TimeStr := FormatDateTime('hh:nn:ss', Now);
FullMsg := '[' + TimeStr + '] ' + Msg;
// Логирую в мемо
if Assigned(Memo1) then
begin
Memo1.Lines.Add(FullMsg);
// Ограничиваю количество строк в Memo1
while Memo1.Lines.Count > 50 do // Увеличил лимит для более полного лога
Memo1.Lines.Delete(0);
Application.ProcessMessages;
end;
// Логирую в файл
if FLogOpened then
begin
WriteLn(FLogFile, FullMsg);
Flush(FLogFile);
end;
except
// Игнорирую ошибки логирования
end;
end;
// Назначение: Инициализирует форму и все необходимые компоненты и системные ресурсы при создании формы.
// Как работает:
// 1. Инициализирует лог-файл, создавая его в директории исполняемого файла.
// 2. Устанавливает заголовок формы и текст кнопок/меток.
// 3. Инициализирует внутренние переменные состояния (подключение, размеры экрана, режим полноэкранного экрана).
// 4. Выделяет память для буфера приема сетевых данных.
// 5. Создает и инициализирует битмап (графический объект) для отображения удаленного экрана.
// 6. Устанавливает размеры PaintBox1 по умолчанию.
// 7. Включает `KeyPreview` для формы, чтобы обрабатывать события клавиатуры на уровне формы.
// 8. Инициализирует Winsock (библиотеку для работы с сетью).
// 9. Настраивает таймер для периодических запросов обновлений (изначально выключен).
// 10. Устанавливает начальный статус приложения.
// 11. Все шаги заключены в блок `try..except` для перехвата и логирования критических ошибок.
procedure TClientForm.FormCreate(Sender: TObject);
var
LogFileName: string;
begin
// Инициализирую лог файл
FLogOpened := False;
try
LogFileName := ExtractFilePath(Application.ExeName) + 'vnc_client.log';
AssignFile(FLogFile, LogFileName);
Rewrite(FLogFile);
FLogOpened := True;
SafeLog('=== VNC Client Started ===');
except
FLogOpened := False;
SafeLog('Ошибка открытия лог-файла.');
end;
try
SafeLog('Начинаем инициализацию FormCreate');
Caption := 'VNC Client (Safe Version)';
Button1.Caption := 'Connect';
Button2.Caption := 'Disconnect';
Button3.Caption := 'Fullscreen';
Button2.Enabled := False;
Button3.Enabled := False;
Label1.Caption := 'Server:';
Label2.Caption := 'Port:';
Edit1.Text := '127.0.0.1';
Edit2.Text := IntToStr(VNC_PORT); // Используем константу
FSocket := INVALID_SOCKET;
FConnected := False;
FScreenWidth := 640; // Начинаем с маленького размера
FScreenHeight := 480;
// Инициализация новых переменных для полноэкранного режима
FFullScreenMode := False;
FOriginalBorderStyle := Self.BorderStyle; // Сохраняем текущий стиль границы
FOriginalWindowState := Self.WindowState; // Сохраняем текущее состояние окна
// Инициализация буферизации
FReceiveBufferSize := 65536; // Начальный размер буфера, можно увеличить при необходимости
GetMem(FReceiveBuffer, FReceiveBufferSize);
FReceiveBufferUsed := 0;
FExpectingHeader := True;
FImageDataReceived := 0;
SafeLog('Создаем bitmap');
// Инициализация Bitmap
FScreenBitmap := nil;
try
FScreenBitmap := Graphics.TBitmap.Create;
FScreenBitmap.PixelFormat := pf24bit; // VNC обычно использует 24-битный или 32-битный цвет (BGR/RGB)
FScreenBitmap.Width := FScreenWidth;
FScreenBitmap.Height := FScreenHeight;
FScreenBitmap.Canvas.Brush.Color := clBlack;
FScreenBitmap.Canvas.FillRect(Classes.Rect(0, 0, FScreenWidth, FScreenHeight));
SafeLog('Bitmap создан успешно');
except
on E: Exception do
begin
SafeLog('Ошибка создания bitmap: ' + E.Message);
if Assigned(FScreenBitmap) then
begin
FScreenBitmap.Free;
FScreenBitmap := nil;
end;
end;
end;
PaintBox1.Width := FScreenWidth;
PaintBox1.Height := FScreenHeight;
KeyPreview := True;
SafeLog('Инициализируем Winsock');
// Инициализация Winsock
if WSAStartup(MAKEWORD(2, 2), FWSAData) <> 0 then
begin
SafeLog('Ошибка инициализации Winsock: ' + IntToStr(WSAGetLastError));
ShowMessage('Winsock init failed');
Exit;
end;
SafeLog('Winsock инициализирован успешно');
Timer1.Interval := 5000; // Обновления каждые 5 секунд
Timer1.Enabled := False;
SetStatus('Ready to connect');
SafeLog('FormCreate завершен успешно');
except
on E: Exception do
begin
SafeLog('КРИТИЧЕСКАЯ ОШИБКА в FormCreate: ' + E.Message);
ShowMessage('Critical error in FormCreate: ' + E.Message);
end;
end;
end;
// Назначение: Освобождает все системные ресурсы, выделенные формой, при ее уничтожении.
// Как работает:
// 1. Закрывает полноэкранную форму, если она была открыта.
// 2. Вызывает `DisconnectFromServer` для корректного закрытия сетевого соединения и освобождения сокета.
// 3. Освобождает память, занятую битмапом экрана (`FScreenBitmap`).
// 4. Освобождает память, выделенную для буфера приема сетевых данных (`FReceiveBuffer`).
// 5. Вызывает `WSACleanup` для деинициализации Winsock.
// 6. Закрывает лог-файл.
// 7. Все шаги заключены в блок `try..except` для перехвата и логирования возможных ошибок при освобождении ресурсов.
procedure TClientForm.FormDestroy(Sender: TObject);
begin
try
SafeLog('Начинаем FormDestroy');
// Закрываю полноэкранную форму если она открыта
if Assigned(FFullScreenForm) then
begin
FFullScreenForm.Close;
FFullScreenForm := nil;
end;
DisconnectFromServer; // Убедимся, что сокет закрыт и ресурсы освобождены
if Assigned(FScreenBitmap) then
begin
FScreenBitmap.Free;
FScreenBitmap := nil;
SafeLog('Bitmap освобожден');
end;
if FReceiveBuffer <> nil then
begin
FreeMem(FReceiveBuffer);
FReceiveBuffer := nil;
FReceiveBufferSize := 0;
FReceiveBufferUsed := 0;
SafeLog('Буфер приема освобожден');
end;
WSACleanup;
SafeLog('Winsock очищен');
if FLogOpened then
begin
SafeLog('=== VNC Client Stopped ===');
CloseFile(FLogFile);
FLogOpened := False;
end;
except
on E: Exception do
begin
SafeLog('Ошибка в FormDestroy: ' + E.Message);
end;
end;
end;
// Назначение: Обрабатывает событие нажатия клавиши на форме.
// Как работает:
// 1. Проверяет комбинации горячих клавиш:
// а. Ctrl+F: Если активен полноэкранный режим, вызывает `Button3Click` для выхода из него.
// б. Escape: Если активен полноэкранный режим, также вызывает `Button3Click` для выхода.
// 2. Если клавиша не была обработана как горячая и клиент подключен, вызывает `SendKeyEvent` для отправки события нажатия клавиши на сервер.
// 3. Логирует информацию о нажатой клавише.
// 4. Обрабатывает исключения.
procedure TClientForm.FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
try
// Обработка горячих клавиш
if (ssCtrl in Shift) and (Key = VK_F) then
begin
SafeLog('Нажата горячая клавиша Ctrl+F');
// Выход из полноэкранного режима
if FFullScreenMode then
begin
Button3Click(nil); // Вызываем обработчик кнопки полноэкранного режима
Key := 0; // Подавляем дальнейшую обработку клавиши
Exit;
end;
end;
// Обработка клавиши Escape для выхода из полноэкранного режима
if (Key = VK_ESCAPE) and FFullScreenMode then
begin
SafeLog('Нажата клавиша Escape в полноэкранном режиме');
Button3Click(nil); // Выход из полноэкранного режима
Key := 0; // Подавляем дальнейшую обработку клавиши
Exit;
end;
// Отправляю событие клавиши на сервер только если мы подключены
// и клавиша не была обработана как горячая
if FConnected and (Key <> 0) then
begin
SafeLog(Format('Отправляем KeyDown: Code=%d, Shift=%s', [Key, ShiftStateToStr(Shift)]));
SendKeyEvent(Key, True);
end;
except
on E: Exception do
SafeLog('Ошибка в FormKeyDown: ' + E.Message);
end;
end;
// Назначение: Обрабатывает событие отпускания клавиши на форме.
// Как работает:
// 1. Если клиент подключен и клавиша не была обработана в `FormKeyDown` (т.е. `Key` не равен 0 после `FormKeyDown`), вызывает `SendKeyEvent` для отправки события отпускания клавиши на сервер.
// 2. Логирует информацию об отпущенной клавише.
// 3. Обрабатывает исключения.
procedure TClientForm.FormKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
try
// Отправляем событие клавиши на сервер только если мы подключены
// и клавиша не была горячей (Key = 0 означает, что она была обработана в KeyDown)
if FConnected and (Key <> 0) then
begin
SafeLog(Format('Отправляем KeyUp: Code=%d, Shift=%s', [Key, ShiftStateToStr(Shift)]));
SendKeyEvent(Key, False);
end;
except
on E: Exception do
SafeLog('Ошибка в FormKeyUp: ' + E.Message);
end;
end;
// Назначение: Преобразует состояние клавиш-модификаторов (Shift, Ctrl, Alt и кнопки мыши) из `TShiftState` в удобочитаемую строку.
// Как работает:
// 1. Инициализирует пустую строку `ShiftStr`.
// 2. Проверяет наличие каждого модификатора (`ssShift`, `ssCtrl`, `ssAlt`, `ssLeft`, `ssRight`, `ssMiddle`, `ssDouble`) в наборе `Shift`.
// 3. Если модификатор присутствует, добавляет соответствующую строку (например, "Shift+") к `ShiftStr`.
// 4. Удаляет последний символ '+' из результирующей строки, если она не пуста.
// 5. Возвращает полученную строку.
function TClientForm.ShiftStateToStr(Shift: TShiftState): string;
var
ShiftStr: string;
begin
ShiftStr := '';
if ssShift in Shift then ShiftStr := ShiftStr + 'Shift+';
if ssCtrl in Shift then ShiftStr := ShiftStr + 'Ctrl+';
if ssAlt in Shift then ShiftStr := ShiftStr + 'Alt+';
if ssLeft in Shift then ShiftStr := ShiftStr + 'Left+';
if ssRight in Shift then ShiftStr := ShiftStr + 'Right+';
if ssMiddle in Shift then ShiftStr := ShiftStr + 'Middle+';
if ssDouble in Shift then ShiftStr := ShiftStr + 'Double+';
if Length(ShiftStr) > 0 then
SetLength(ShiftStr, Length(ShiftStr) - 1);
Result := ShiftStr;
end;
// Назначение: Обрабатывает событие нажатия кнопки "Connect".
// Как работает:
// 1. Логирует событие.
// 2. Вызывает процедуру `ConnectToServer` для попытки установить соединение с сервером.
// 3. Обрабатывает исключения.
procedure TClientForm.Button1Click(Sender: TObject);
begin
try
SafeLog('Нажата кнопка Connect');
ConnectToServer;
except
on E: Exception do
begin
SafeLog('Ошибка в Button1Click: ' + E.Message);
end;
end;
end;
// Назначение: Обрабатывает событие нажатия кнопки "Disconnect".
// Как работает:
// 1. Логирует событие.
// 2. Вызывает процедуру `DisconnectFromServer` для разрыва соединения с сервером.
// 3. Обрабатывает исключения.
procedure TClientForm.Button2Click(Sender: TObject);
begin
try
SafeLog('Нажата кнопка Disconnect');
DisconnectFromServer;
except
on E: Exception do
SafeLog('Ошибка в Button2Click: ' + E.Message);
end;
end;
// Назначение: Переключает клиентское приложение между оконным и полноэкранным режимами.
// Как работает:
// 1. Если приложение не в полноэкранном режиме:
// а. Создает новую форму (`FFullScreenForm`), устанавливает ее стиль границы в `bsNone` и состояние окна в `wsFullScreen`.
// б. Создает `TPaintBox` на новой форме, устанавливает его выравнивание в `alClient` и привязывает обработчики событий `OnPaint`, `OnMouseDown`, `OnMouseUp`, `OnMouseMove` к соответствующим методам `TClientForm`.
// в. Привязывает обработчики событий клавиатуры (`OnKeyDown`, `OnKeyUp`) новой формы к методам `TClientForm`.
// г. Показывает новую форму, устанавливает `FFullScreenMode` в `True` и меняет текст кнопки на "Exit Fullscreen".
// 2. Если приложение уже в полноэкранном режиме:
// а. Закрывает `FFullScreenForm` и освобождает ее.
// б. Устанавливает `FFullScreenMode` в `False` и меняет текст кнопки обратно на "Fullscreen".
// 3. Логирует изменения режима.
// 4. Обрабатывает исключения.
procedure TClientForm.Button3Click(Sender: TObject);
begin
try
SafeLog('Нажата кнопка Fullscreen');
if not FFullScreenMode then
begin
// Создаем полноэкранную форму
FFullScreenForm := TForm.Create(Self);
FFullScreenForm.BorderStyle := bsNone;
FFullScreenForm.WindowState := wsFullScreen;
FFullScreenForm.KeyPreview := True;
FFullScreenForm.Color := clBlack;
// Создаю PaintBox для полноэкранной формы
with TPaintBox.Create(FFullScreenForm) do
begin
Parent := FFullScreenForm;
Align := alClient;
OnPaint := @PaintBox1Paint;
OnMouseDown := @PaintBox1MouseDown;
OnMouseUp := @PaintBox1MouseUp;
OnMouseMove := @PaintBox1MouseMove;
end;
// Обработчики клавиатуры для полноэкранной формы
FFullScreenForm.OnKeyDown := @FormKeyDown;
FFullScreenForm.OnKeyUp := @FormKeyUp;
FFullScreenForm.Show;
FFullScreenMode := True;
Button3.Caption := 'Exit Fullscreen';
SafeLog('Полноэкранный режим включен. Используйте Ctrl+F или Escape для выхода.');
end
else
begin
// Закрываем полноэкранную форму
if Assigned(FFullScreenForm) then
begin
FFullScreenForm.Close;
FFullScreenForm := nil;
end;
FFullScreenMode := False;
Button3.Caption := 'Fullscreen';
SafeLog('Полноэкранный режим выключен');
end;
except
on E: Exception do
SafeLog('Ошибка в Button3Click: ' + E.Message);
end;
end;
// Назначение: Пустой обработчик события изменения текста в Memo1.
// Как работает: Не выполняет никаких действий.
procedure TClientForm.Memo1Change(Sender: TObject);
begin
end;
// Назначение: Обрабатывает событие нажатия кнопки мыши на `PaintBox1`.
// Как работает:
// 1. Определяет маску нажатой кнопки мыши (левая, правая).
// 2. Корректирует координаты X и Y с учетом масштабирования, если приложение находится в полноэкранном режиме.
// 3. Вызывает `SendMouseEvent` для отправки скорректированных координат и маски кнопок на сервер.
// 4. Обрабатывает исключения.
procedure TClientForm.PaintBox1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var
ButtonMask: Byte;
ActualX, ActualY: Integer;
begin
try
ButtonMask := 0;
if Button = mbLeft then ButtonMask := 1
else if Button = mbRight then ButtonMask := 2;
// Преобразую координаты с учетом масштабирования в полноэкранном режиме
if FFullScreenMode then
begin
ActualX := Round(X * FScreenWidth / PaintBox1.Width);
ActualY := Round(Y * FScreenHeight / PaintBox1.Height);
end
else
begin
ActualX := X;
ActualY := Y;
end;
SendMouseEvent(ActualX, ActualY, ButtonMask);
except
on E: Exception do
SafeLog('Ошибка в PaintBox1MouseDown: ' + E.Message);
end;
end;
// Назначение: Обрабатывает событие отпускания кнопки мыши на `PaintBox1`.
// Как работает:
// 1. Корректирует координаты X и Y с учетом масштабирования, если приложение находится в полноэкранном режиме.
// 2. Вызывает `SendMouseEvent` для отправки скорректированных координат и нулевой маски кнопок (что означает, что кнопки не нажаты) на сервер.
// 3. Обрабатывает исключения.
procedure TClientForm.PaintBox1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var
ActualX, ActualY: Integer;
begin
try
// Преобразую координаты с учетом маштабирования в полноэкранном режиме
if FFullScreenMode then
begin
ActualX := Round(X * FScreenWidth / PaintBox1.Width);
ActualY := Round(Y * FScreenHeight / PaintBox1.Height);
end
else
begin
ActualX := X;
ActualY := Y;
end;
SendMouseEvent(ActualX, ActualY, 0);
except
on E: Exception do
SafeLog('Ошибка в PaintBox1MouseUp: ' + E.Message);
end;
end;
// Назначение: Обрабатывает событие перемещения мыши по `PaintBox1`.
// Как работает:
// 1. Определяет маску нажатых кнопок мыши из `ShiftState`.
// 2. Корректирует координаты X и Y с учетом масштабирования, если приложение находится в полноэкранном режиме.
// 3. Если хотя бы одна кнопка мыши нажата, вызывает `SendMouseEvent` для отправки скорректированных координат и маски кнопок на сервер.
// 4. Обрабатывает исключения.
procedure TClientForm.PaintBox1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
var
ButtonMask: Byte;
ActualX, ActualY: Integer;
begin
try
ButtonMask := 0;
if ssLeft in Shift then ButtonMask := ButtonMask or 1;
if ssRight in Shift then ButtonMask := ButtonMask or 2;
if ssMiddle in Shift then ButtonMask := ButtonMask or 4;
// Преобразую координаты с учетом масштабирования в полноэкранном режиме
if FFullScreenMode then
begin
ActualX := Round(X * FScreenWidth / PaintBox1.Width);
ActualY := Round(Y * FScreenHeight / PaintBox1.Height);
end
else
begin
ActualX := X;
ActualY := Y;
end;
if ButtonMask <> 0 then
SendMouseEvent(ActualX, ActualY, ButtonMask);
except
on E: Exception do
SafeLog('Ошибка в PaintBox1MouseMove: ' + E.Message);
end;
end;
// Назначение: Обрабатывает событие таймера, которое используется для периодического запроса обновлений экрана от сервера.
// Как работает:
// 1. Если клиент подключен (`FConnected`), логирует событие и вызывает `RequestUpdate` для отправки запроса серверу.
// 2. Обрабатывает исключения и отключает таймер в случае ошибки.
procedure TClientForm.Timer1Timer(Sender: TObject);
begin
try
if FConnected then
begin
// Запрашиваю обновления реже при высокой частоте кадров
SafeLog('Timer: запрашиваем обновление');
RequestUpdate;
end;
except
on E: Exception do
begin
SafeLog('Ошибка в Timer1Timer: ' + E.Message);
Timer1.Enabled := False;
end;
end;
end;
// Назначение: Устанавливает TCP-соединение с указанным сервером VNC.
// Как работает:
// 1. Проверяет, не подключен ли клиент уже.
// 2. Получает IP-адрес и порт из полей ввода.
// 3. Создает сокет (`socket`).
// 4. Увеличивает размер буфера приема сокета (`SO_RCVBUF`) до 1 МБ для повышения производительности.
// 5. Инициализирует структуру адреса сервера и пытается подключиться (`connect`).
// 6. Если соединение установлено, настраивает асинхронные уведомления Winsock (`WSAAsyncSelect`) для получения событий чтения (`FD_READ`) и закрытия (`FD_CLOSE`) сокета, направляя их в `WM_SOCKET` сообщение формы.
// 7. Обновляет состояние кнопок и полей ввода, а также сбрасывает внутренние буферы для приема данных.
// 8. Логирует все шаги и ошибки.
// 9. В случае критических ошибок закрывает сокет.
procedure TClientForm.ConnectToServer;
var
ServerAddr: TSockAddrIn;
ServerIP: string;
ServerPort: Integer;
SocketBufferSize: Integer;
OptLen: Integer;
begin
if FConnected then Exit;
try
ServerIP := Edit1.Text;
ServerPort := StrToIntDef(Edit2.Text, VNC_PORT);
SafeLog('Подключаемся к ' + ServerIP + ':' + IntToStr(ServerPort));
if ServerIP = '' then
begin
ShowMessage('Enter server IP address');
Exit;
end;
SetStatus('Connecting to server...');
FSocket := socket(AF_INET, SOCK_STREAM, IPPROTO_TCP);
if FSocket = INVALID_SOCKET then
begin
SafeLog('Ошибка создания сокета: ' + IntToStr(WSAGetLastError));
raise Exception.Create('Failed to create socket');
end;
// Увеличиваю буфер приема сокета для высокоскоростных данных
SocketBufferSize := 1024 * 1024; // 1MB буфер
OptLen := SizeOf(SocketBufferSize);
if setsockopt(FSocket, SOL_SOCKET, SO_RCVBUF, @SocketBufferSize, OptLen) = SOCKET_ERROR then
begin
SafeLog('Предупреждение: не удалось установить размер буфера приема: ' + IntToStr(WSAGetLastError));
end
else
begin
SafeLog('Буфер приема сокета установлен в ' + IntToStr(SocketBufferSize) + ' байт');
end;
SafeLog('Сокет создан: ' + IntToStr(FSocket));
ZeroMemory(@ServerAddr, SizeOf(ServerAddr));
ServerAddr.sin_family := AF_INET;
ServerAddr.sin_addr.s_addr := inet_addr(PAnsiChar(AnsiString(ServerIP)));
ServerAddr.sin_port := htons(ServerPort);
SafeLog('Вызываем connect()');
if connect(FSocket, @ServerAddr, SizeOf(ServerAddr)) = SOCKET_ERROR then
begin
SafeLog('Ошибка connect: ' + IntToStr(WSAGetLastError));
closesocket(FSocket);
FSocket := INVALID_SOCKET;
raise Exception.Create('Failed to connect to server');
end;
SafeLog('TCP соединение установлено');
SetStatus('Connection established');
SafeLog('Настраиваем асинхронные уведомления');
if WSAAsyncSelect(FSocket, Handle, WM_SOCKET, FD_READ or FD_CLOSE) = SOCKET_ERROR then
begin
SafeLog('Ошибка WSAAsyncSelect: ' + IntToStr(WSAGetLastError));
closesocket(FSocket);
FSocket := INVALID_SOCKET;
raise Exception.Create('Failed to set up async notifications');
end
else
begin
SafeLog('Асинхронные уведомления настроены успешно');
end;
FConnected := True;
Button1.Enabled := False;
Button2.Enabled := True;
Button3.Enabled := True;
Edit1.Enabled := False;
Edit2.Enabled := False;
// Сбрасываю состояние буфера
FReceiveBufferUsed := 0;
FExpectingHeader := True;
FImageDataReceived := 0;
// Устанавливаю таймер на более длительный интервал для высокочастотных обновлений
Timer1.Interval := 1000; // 1 секунда вместо 5
Timer1.Enabled := False; // Будет включен после первого кадра
SetStatus('Connected to ' + ServerIP + ':' + IntToStr(ServerPort));
SafeLog('Подключение завершено, ждем данных от сервера');
except
on E: Exception do
begin
SafeLog('ОШИБКА подключения: ' + E.Message);
SetStatus('Connection error: ' + E.Message);
ShowMessage('Connection error: ' + E.Message);
if FSocket <> INVALID_SOCKET then
begin
closesocket(FSocket);
FSocket := INVALID_SOCKET;
SafeLog('Сокет закрыт после ошибки');
end;
end;
end;
end;
// Назначение: Разрывает активное TCP-соединение с сервером.
// Как работает:
// 1. Проверяет, подключен ли клиент.
// 2. Устанавливает флаг `FConnected` в `False` и отключает таймер.
// 3. Если сокет валиден, отключает асинхронные уведомления (`WSAAsyncSelect` с нулевыми флагами) и закрывает сокет (`closesocket`).
// 4. Обновляет состояние кнопок и полей ввода.
// 5. Сбрасывает внутренние буферы приема данных.
// 6. Очищает отображение на `FScreenBitmap`, заливая его черным, и вызывает `PaintBox1.Invalidate` для перерисовки.
// 7. Обновляет статус приложения.
// 8. Логирует все шаги и ошибки.
procedure TClientForm.DisconnectFromServer;
begin
try
if not FConnected then Exit;
SafeLog('Начинаем отключение');
FConnected := False;
Timer1.Enabled := False;
if FSocket <> INVALID_SOCKET then
begin
// Снимаю асинхронные уведомления перед закрытием сокета
WSAAsyncSelect(FSocket, Handle, 0, 0);
closesocket(FSocket);
FSocket := INVALID_SOCKET;
SafeLog('Сокет закрыт');
end;
Button1.Enabled := True;
Button2.Enabled := False;
Button3.Enabled := False;
Edit1.Enabled := True;
Edit2.Enabled := True;
// Сбрасываю состояние буфера
FReceiveBufferUsed := 0;
FExpectingHeader := True;
FImageDataReceived := 0;
if Assigned(FScreenBitmap) then
begin
FScreenBitmap.Canvas.Brush.Color := clBlack;
FScreenBitmap.Canvas.FillRect(Classes.Rect(0, 0, FScreenBitmap.Width, FScreenBitmap.Height));
PaintBox1.Invalidate;
end;
SetStatus('Disconnected from server');
SafeLog('Отключение завершено');
except
on E: Exception do
SafeLog('Ошибка в DisconnectFromServer: ' + E.Message);
end;
end;
// Назначение: Обрабатывает данные, полученные от VNC-сервера.
// Как работает:
// 1. Использует `ioctlsocket` с `FIONREAD` для определения количества доступных байт в сокете.
// 2. Если данных нет, выходит.
// 3. Проверяет, не приведет ли добавление новых данных к переполнению буфера приема (`FReceiveBuffer`). Если да, сбрасывает буфер.
// 4. При необходимости увеличивает размер буфера приема (`ReallocMem`).
// 5. Читает данные из сокета (`recv`) в буфер.
// 6. В цикле обрабатывает полученные данные:
// а. Если ожидается заголовок (`FExpectingHeader`), читает `TScreenHeader`.
// б. Проверяет заголовок на корректность (разумные размеры и размер данных). Если некорректен, пытается найти следующий заголовок в буфере.
// в. Если заголовок корректен и размеры экрана изменились, пересоздает `FScreenBitmap` с новыми размерами.
// г. Затем обрабатывает данные изображения, копируя их в `FScreenBitmap` с помощью `UpdateBitmapRegion`.
// д. Если получен полный кадр, устанавливает `FExpectingHeader` в `True` для ожидания следующего заголовка и увеличивает счетчик обработанных кадров.
// е. После обработки каждого полного кадра (или нескольких кадров, если они пришли быстро), вызывает `UpdateDisplay`.
// 7. Сдвигает необработанные данные в начало буфера.
// 8. Запускает таймер `Timer1`, если он еще не активен, для запроса регулярных обновлений.
// 9. Обрабатывает ошибки, логирует их и в случае критических ошибок отключается от сервера.
procedure TClientForm.ProcessServerData;
var
BytesReceived: Integer;
BytesProcessed: Integer;
RemainingDataInSocket: LongWord;
ExpectedTotalData: Cardinal;
MaxBufferSize: Cardinal;
FramesProcessed: Integer;
RemainingImageData: Integer;
AvailableData: Integer;
RemainingBytes: Integer;
begin
try
// Проверяю, что сокет валиден
if FSocket = INVALID_SOCKET then
begin
SafeLog('ProcessServerData: FSocket недействителен, выход.');
Exit;
end;
// Ограничиваю максимальный размер буфера для предотвращения переполнения памяти
MaxBufferSize := 10 * 1024 * 1024; // 10MB максимум
// Использую ioctlsocket для получения количества доступных байт
if ioctlsocket(FSocket, FIONREAD, @RemainingDataInSocket) = SOCKET_ERROR then
begin
SafeLog('Ошибка ioctlsocket (FIONREAD): ' + IntToStr(WSAGetLastError));
DisconnectFromServer;
Exit;
end;
if RemainingDataInSocket = 0 then
begin
SafeLog('ProcessServerData: Нет данных для чтения из сокета.');
Exit;
end;
// Проверяю, не превышаем ли мы максимальный размер буфера
if FReceiveBufferUsed + RemainingDataInSocket > MaxBufferSize then
begin
SafeLog(Format('ПРЕДУПРЕЖДЕНИЕ: Буфер переполнен (%d + %d > %d), сбрасываем старые данные',
[FReceiveBufferUsed, RemainingDataInSocket, MaxBufferSize]));
// Сбрасываю буфер и начинаем заново
FReceiveBufferUsed := 0;
FExpectingHeader := True;
FImageDataReceived := 0;
// Ограничиваю количество читаемых данных
RemainingDataInSocket := Min(RemainingDataInSocket, MaxBufferSize div 2);
end;
SafeLog(Format('ProcessServerData: в сокете доступно %d байт, в буфере %d байт',
[RemainingDataInSocket, FReceiveBufferUsed]));
// Увеличиваю буфер если нужно
ExpectedTotalData := FReceiveBufferUsed + RemainingDataInSocket;
if FReceiveBufferSize < ExpectedTotalData then
begin
FReceiveBufferSize := ExpectedTotalData + (64 * 1024);
ReallocMem(FReceiveBuffer, FReceiveBufferSize);
SafeLog(Format('Буфер приема увеличен до %d байт', [FReceiveBufferSize]));
end;
// Читаю доступные данные
BytesReceived := recv(FSocket, (FReceiveBuffer + FReceiveBufferUsed)^, RemainingDataInSocket, 0);
if BytesReceived = SOCKET_ERROR then
begin
SafeLog('Ошибка recv: ' + IntToStr(WSAGetLastError));
DisconnectFromServer;
Exit;
end;
if BytesReceived = 0 then
begin
SafeLog('Соединение закрыто сервером (recv вернул 0)');
DisconnectFromServer;
Exit;
end;
Inc(FReceiveBufferUsed, BytesReceived);
SafeLog(Format('Получено %d байт, в буфере теперь %d байт', [BytesReceived, FReceiveBufferUsed]));
BytesProcessed := 0;
FramesProcessed := 0;
// Обрабатываю данные в цикле
while (FReceiveBufferUsed - BytesProcessed >= SizeOf(TScreenHeader)) and (FramesProcessed < 3) do
begin
if FExpectingHeader then
begin
// Читаю заголовок
Move((FReceiveBuffer + BytesProcessed)^, FCurrentHeader, SizeOf(TScreenHeader));
Inc(BytesProcessed, SizeOf(TScreenHeader));
SafeLog(Format('Заголовок: %dx%d, данных: %d байт',
[FCurrentHeader.Width, FCurrentHeader.Height, FCurrentHeader.DataSize]));
// Проверяю корректность заголовка
if (FCurrentHeader.Width < 1) or (FCurrentHeader.Width > 4096) or
(FCurrentHeader.Height < 1) or (FCurrentHeader.Height > 4096) or
(FCurrentHeader.DataSize < 1) or (FCurrentHeader.DataSize > 50 * 1024 * 1024) then
begin
SafeLog(Format('Некорректный заголовок (%dx%d, DataSize=%d), поиск следующего',
[FCurrentHeader.Width, FCurrentHeader.Height, FCurrentHeader.DataSize]));
// Ищу следующий возможный заголовок
while (BytesProcessed < FReceiveBufferUsed - SizeOf(TScreenHeader)) do
begin
Inc(BytesProcessed);
Move((FReceiveBuffer + BytesProcessed)^, FCurrentHeader, SizeOf(TScreenHeader));
if (FCurrentHeader.Width >= 1) and (FCurrentHeader.Width <= 4096) and
(FCurrentHeader.Height >= 1) and (FCurrentHeader.Height <= 4096) and
(FCurrentHeader.DataSize >= 1) and (FCurrentHeader.DataSize <= 50 * 1024 * 1024) then
begin
SafeLog(Format('Найден корректный заголовок на позиции %d', [BytesProcessed]));
Inc(BytesProcessed, SizeOf(TScreenHeader));
Break;
end;
end;
if BytesProcessed >= FReceiveBufferUsed - SizeOf(TScreenHeader) then
begin
SafeLog('Корректный заголовок не найден, очищаем буфер');
FReceiveBufferUsed := 0;
FExpectingHeader := True;
Exit;
end;
end;
// Обновляю размер bitmap если нужно
if (FScreenWidth <> FCurrentHeader.Width) or (FScreenHeight <> FCurrentHeader.Height) then
begin
SafeLog(Format('Изменяем размер bitmap: %dx%d -> %dx%d',
[FScreenWidth, FScreenHeight, FCurrentHeader.Width, FCurrentHeader.Height]));
FScreenWidth := FCurrentHeader.Width;
FScreenHeight := FCurrentHeader.Height;
if not Assigned(FScreenBitmap) then
begin
FScreenBitmap := Graphics.TBitmap.Create;
FScreenBitmap.PixelFormat := pf24bit;
end;
FScreenBitmap.Width := FScreenWidth;
FScreenBitmap.Height := FScreenHeight;
FScreenBitmap.Canvas.Brush.Color := clBlack;
FScreenBitmap.Canvas.FillRect(Classes.Rect(0, 0, FScreenWidth, FScreenHeight));
PaintBox1.Width := FScreenWidth;
PaintBox1.Height := FScreenHeight;
end;
FExpectingHeader := False;
FImageDataReceived := 0;
end;
// Обрабатываю данные изображения
if not FExpectingHeader then
begin
RemainingImageData := Integer(FCurrentHeader.DataSize) - FImageDataReceived;
AvailableData := FReceiveBufferUsed - BytesProcessed;
if AvailableData >= RemainingImageData then
begin
// Получил все данные для текущего кадра
UpdateBitmapRegion(BytesProcessed, RemainingImageData);
Inc(BytesProcessed, RemainingImageData);
Inc(FImageDataReceived, RemainingImageData);
SafeLog(Format('Кадр %d завершен (%d байт)', [FramesProcessed + 1, FCurrentHeader.DataSize]));
FExpectingHeader := True;
FImageDataReceived := 0;
Inc(FramesProcessed);
// Обновляю отображение только для последнего кадра в пакете
if FramesProcessed = 1 then
UpdateDisplay;
end
else
begin
// Недостаточно данных для полного кадра
if AvailableData > 0 then
begin
UpdateBitmapRegion(BytesProcessed, AvailableData);
Inc(FImageDataReceived, AvailableData);
Inc(BytesProcessed, AvailableData);
SafeLog(Format('Частичные данные: %d/%d байт получено',
[FImageDataReceived, FCurrentHeader.DataSize]));
end;
Break; // Ждем больше данных
end;
end;
end;
// Если обработали несколько кадров, обновляем отображение
if FramesProcessed > 1 then
begin
SafeLog(Format('Обработано %d кадров за один вызов', [FramesProcessed]));
UpdateDisplay;
end;
// Сдвигаем необработанные данные в начало буфера
if BytesProcessed > 0 then
begin
RemainingBytes := FReceiveBufferUsed - BytesProcessed;
if RemainingBytes > 0 then
begin
Move((FReceiveBuffer + BytesProcessed)^, FReceiveBuffer^, RemainingBytes);
FReceiveBufferUsed := RemainingBytes;
SafeLog(Format('Буфер сдвинут, осталось %d байт', [FReceiveBufferUsed]));
end
else
begin
FReceiveBufferUsed := 0;
SafeLog('Буфер полностью обработан');
end;
end;
// Запускаем таймер для регулярных обновлений если еще не запущен
if not Timer1.Enabled and FConnected then
begin
Timer1.Enabled := True;
SafeLog('Таймер обновлений запущен');
end;
except
on E: Exception do
begin
SafeLog('ОШИБКА в ProcessServerData: ' + E.Message);
FReceiveBufferUsed := 0;
FExpectingHeader := True;
FImageDataReceived := 0;
DisconnectFromServer;
end;
end;
end;
// Назначение: Обновляет указанную область `FScreenBitmap` данными из буфера приема.
// Как работает:
// 1. Проверяет, что `FScreenBitmap` инициализирован.
// 2. Определяет количество байт на пиксель (по умолчанию 3 для 24-битного цвета).
// 3. Использует `BeginUpdate` и `EndUpdate` для оптимизации отрисовки битмапа.
// 4. Построчно копирует данные из `FReceiveBuffer` в `FScreenBitmap`, используя `ScanLine` для доступа к строкам битмапа.
// 5. Контролирует, чтобы не выйти за пределы полученных данных (`DataSize`).
// 6. Если получено меньше данных, чем нужно для целой строки, заполняет остаток строки нулями.
// 7. Комментарий в коде указывает на возможное место для обмена байтов (BGR <-> RGB), если цвета отображаются некорректно.
// 8. Обрабатывает исключения.
procedure TClientForm.UpdateBitmapRegion(DataOffset: Integer; DataSize: Integer);
var
i, j: Integer;
DestPtr: PByte;
SrcPtr: PByte;
CurrentLineBytes: PByte;
BytesPerPixel: Integer;
PixelsToCopy: Integer;
begin
if not Assigned(FScreenBitmap) then Exit;
// Определение количества байт на пиксель (для BGR24 это 3)
// Если VNC сервер передает 32-битный RGBX/ARGB, то будет 4 байта на пиксель.
// Сейчас код жестко ожидает 3 байта на пиксель.
BytesPerPixel := 3;
if FCurrentHeader.DataSize > 0 then
BytesPerPixel := FCurrentHeader.DataSize div (FCurrentHeader.Width * FCurrentHeader.Height);
FScreenBitmap.BeginUpdate;
try
SrcPtr := FReceiveBuffer + DataOffset; // Указатель на начало данных в буфере приема
// Копируем данные построчно
// FScreenBitmap.ScanLine[Y] возвращает указатель на начало строки Y
for i := 0 to FScreenHeight - 1 do
begin
CurrentLineBytes := FScreenBitmap.ScanLine[i];
// Вычисляем, сколько байт для текущей строки скопировать
// Это количество байт на всю ширину изображения, умноженное на байт/пиксель
PixelsToCopy := FScreenWidth * BytesPerPixel;
if DataSize >= PixelsToCopy then
begin
Move(SrcPtr^, CurrentLineBytes^, PixelsToCopy);
Inc(SrcPtr, PixelsToCopy);
Dec(DataSize, PixelsToCopy);
end
else if DataSize > 0 then // Если осталось меньше, чем целая строка
begin
Move(SrcPtr^, CurrentLineBytes^, DataSize);
FillChar((CurrentLineBytes + DataSize)^, PixelsToCopy - DataSize, 0); // Заполняем остаток строки нулями
SrcPtr := SrcPtr + DataSize;
DataSize := 0;
end
else
begin
Break; // Все данные скопированы
end;
end;
finally
FScreenBitmap.EndUpdate;
end;
end;
// Назначение: Отложенно запрашивает обновление экрана от сервера.
// Как работает:
// 1. Эта функция предназначена для асинхронного вызова (например, через `AsyncCall`), чтобы не блокировать GUI-поток.
// 2. Проверяет, что клиент подключен, и вызывает `RequestUpdate`.
// 3. Обрабатывает исключения.
procedure TClientForm.DelayedRequestUpdate(Data: PtrInt);
begin
try
if FConnected then
RequestUpdate;
except
on E: Exception do
SafeLog('Ошибка в DelayedRequestUpdate: ' + E.Message);
end;
end;
// Назначение: Отправляет запрос на обновление экрана серверу.
// Как работает:
// 1. Проверяет, что клиент подключен.
// 2. Отправляет байт `1` в сокет, который является командой для сервера "запросить обновление экрана".
// 3. Логирует успешную отправку или ошибку.
// 4. В случае ошибки отправки предполагает потерю соединения и вызывает `DisconnectFromServer`.
// 5. Обрабатывает исключения.
procedure TClientForm.RequestUpdate;
var
Msg: Byte;
begin
try
if not FConnected then Exit;
SafeLog('Отправляем запрос обновления');
Msg := 1; // Команда "запросить обновление экрана"
if send(FSocket, Msg, SizeOf(Msg), 0) = SOCKET_ERROR then
begin
SafeLog('Ошибка отправки запроса: ' + IntToStr(WSAGetLastError));
// Если не удалось отправить, возможно, соединение потеряно
DisconnectFromServer;
end
else
begin
SafeLog('Запрос обновления отправлен');
end;
except
on E: Exception do
SafeLog('Ошибка в RequestUpdate: ' + E.Message);
end;
end;
// Назначение: Отправляет событие мыши (перемещение, нажатие/отпускание кнопки) на сервер.
// Как работает:
// 1. Проверяет, что клиент подключен.
// 2. Проверяет, что переданные координаты мыши находятся в пределах текущих размеров экрана, чтобы избежать отправки некорректных данных.
// 3. Создает структуру `TMouseMsg`, заполняя ее типом сообщения (2), координатами X и Y, и маской нажатых кнопок.
// 4. Отправляет структуру `Msg` в сокет (`send`).
// 5. Логирует отправленные данные или ошибку.
// 6. Обрабатывает исключения.
procedure TClientForm.SendMouseEvent(X, Y: Integer; Buttons: Byte);
var
Msg: TMouseMsg;
begin
try
if not FConnected then Exit;
// Проверяем, что координаты в пределах экрана
if (X < 0) or (X >= FScreenWidth) or (Y < 0) or (Y >= FScreenHeight) then
begin
SafeLog(Format('Попытка отправить недействительные координаты мыши: X=%d, Y=%d', [X, Y]));
Exit;
end;
Msg.MsgType := 2; // Тип сообщения: Мышь
Msg.X := X;
Msg.Y := Y;
Msg.Buttons := Buttons;
if send(FSocket, Msg, SizeOf(Msg), 0) = SOCKET_ERROR then
begin
SafeLog('Ошибка отправки mouse event: ' + IntToStr(WSAGetLastError));
end
else
begin
SafeLog(Format('Mouse: X=%d, Y=%d, Buttons=%d', [X, Y, Buttons]));
end;
except
on E: Exception do
SafeLog('Ошибка в SendMouseEvent: ' + E.Message);
end;
end;
// Назначение: Отправляет событие клавиатуры (нажатие или отпускание клавиши) на сервер.
// Как работает:
// 1. Проверяет, что клиент подключен.
// 2. Создает структуру `TKeyMsg`, заполняя ее типом сообщения (3), состоянием клавиши (нажата/отпущена) и кодом клавиши.
// 3. Отправляет структуру `Msg` в сокет (`send`).
// 4. Логирует отправленные данные или ошибку.
// 5. Обрабатывает исключения.
procedure TClientForm.SendKeyEvent(KeyCode: DWORD; IsDown: Boolean);
var
Msg: TKeyMsg;
begin
try
if not FConnected then Exit;
Msg.MsgType := 3; // Тип сообщения: Клавиатура
if IsDown then
Msg.IsDown := 1
else
Msg.IsDown := 0;
Msg.KeyCode := KeyCode;
if send(FSocket, Msg, SizeOf(Msg), 0) = SOCKET_ERROR then
begin
SafeLog('Ошибка отправки key event: ' + IntToStr(WSAGetLastError));
end
else
begin
SafeLog(Format('Key: Code=%d, Down=%s', [KeyCode, BoolToStr(IsDown, True)]));
end;
except
on E: Exception do
SafeLog('Ошибка в SendKeyEvent: ' + E.Message);
end;
end;
// Назначение: Обновляет отображение удаленного экрана на `PaintBox1` и, при необходимости, на полноэкранной форме.
// Как работает:
// 1. Ограничивает частоту обновления интерфейса до примерно 30 кадров в секунду (`MIN_UPDATE_INTERVAL`).
// 2. Если прошло достаточно времени с последнего обновления, вызывает `PaintBox1.Invalidate` для запуска перерисовки `PaintBox1`.
// 3. Если приложение находится в полноэкранном режиме, также вызывает `Invalidate` для `FFullScreenForm`.
// 4. Запоминает время текущего обновления (`LastUpdateTime`).
// 5. Обрабатывает исключения.
procedure TClientForm.UpdateDisplay;
var
LastUpdateTime: Cardinal;
CurrentTime: Cardinal;
const
MIN_UPDATE_INTERVAL = 33; // ~30 FPS максимум для отображения
begin
try
CurrentTime := GetTickCount;
// Ограничиваем частоту обновления интерфейса
if CurrentTime - LastUpdateTime >= MIN_UPDATE_INTERVAL then
begin
PaintBox1.Invalidate;
LastUpdateTime := CurrentTime;
// Обновляем полноэкранную форму если она активна
if FFullScreenMode and Assigned(FFullScreenForm) then
begin
FFullScreenForm.Invalidate;
end;
end;
except
on E: Exception do
SafeLog('Ошибка в UpdateDisplay: ' + E.Message);
end;
end;
// Назначение: Устанавливает текст статусной метки (`Label3`) и немедленно обновляет GUI.
// Как работает:
// 1. Если `Label3` существует, устанавливает его `Caption` в переданное сообщение.
// 2. Вызывает `Application.ProcessMessages` для принудительного обновления интерфейса.
// 3. Обрабатывает исключения.
procedure TClientForm.SetStatus(const Msg: string);
begin
try
if Assigned(Label3) then
Label3.Caption := Msg;
Application.ProcessMessages; // Обновляет GUI немедленно
except
on E: Exception do
SafeLog('Ошибка в SetStatus: ' + E.Message);
end;
end;
// Назначение: Прорисовывает содержимое `FScreenBitmap` на `PaintBox1` (или на `PaintBox` полноэкранной формы).
// Как работает:
// 1. Получает ссылку на `TPaintBox`, который вызвал событие.
// 2. Если `FScreenBitmap` инициализирован и имеет ненулевые размеры:
// а. Если активен полноэкранный режим, рассчитывает коэффициенты масштабирования (`ScaleX`, `ScaleY`) и выбирает минимальный (`Scale`) для сохранения пропорций. Затем вычисляет целевую область (`DestRect`) для отрисовки по центру `PaintBox` и использует `StretchDraw` для масштабированной отрисовки.
// б. В обычном режиме просто рисует `FScreenBitmap` в `PaintBox` без масштабирования (`Draw`).
// 3. Если `FScreenBitmap` не инициализирован, заливает `PaintBox` черным цветом.
// 4. Обрабатывает исключения.
procedure TClientForm.PaintBox1Paint(Sender: TObject);
var
PaintBox: TPaintBox;
DestRect: TRect;
ScaleX, ScaleY, Scale: Double;
begin
try
PaintBox := Sender as TPaintBox;
if Assigned(FScreenBitmap) and (FScreenBitmap.Width > 0) and (FScreenBitmap.Height > 0) then
begin
if FFullScreenMode then
begin
// В полноэкранном режиме масштабируем с сохранением пропорций
ScaleX := PaintBox.Width / FScreenWidth;
ScaleY := PaintBox.Height / FScreenHeight;
Scale := MinDouble(ScaleX, ScaleY);
DestRect.Left := (PaintBox.Width - Round(FScreenWidth * Scale)) div 2;
DestRect.Top := (PaintBox.Height - Round(FScreenHeight * Scale)) div 2;
DestRect.Right := DestRect.Left + Round(FScreenWidth * Scale);
DestRect.Bottom := DestRect.Top + Round(FScreenHeight * Scale);
PaintBox.Canvas.StretchDraw(DestRect, FScreenBitmap);
end
else
begin
// Обычный режим - без масштабирования
PaintBox.Canvas.Draw(0, 0, FScreenBitmap);
end;
end
else
begin
PaintBox.Canvas.Brush.Color := clBlack;
PaintBox.Canvas.FillRect(PaintBox.ClientRect);
end;
except
on E: Exception do
SafeLog('Ошибка в PaintBox1Paint: ' + E.Message);
end;
end;
// Назначение: Обработчик пользовательского сообщения `WM_SOCKET`, которое операционная система отправляет форме при возникновении асинхронных сетевых событий на сокетах, настроенных через `WSAAsyncSelect`.
// Как работает:
// 1. Извлекает код сетевого события (`Event`) и код ошибки (`Error`) из `Message.LParam`.
// 2. Использует конструкцию `case` для обработки различных типов событий:
// а. `FD_READ`: Происходит, когда на сокете доступны данные для чтения. Если ошибки нет, вызывает `ProcessServerData` для обработки входящих данных. В случае ошибки логирует ее, устанавливает статус и отключается.
// б. `FD_CLOSE`: Происходит, когда сервер закрыл соединение. Логирует событие и ошибку (если есть), устанавливает статус и вызывает `DisconnectFromServer`.
// в. `else`: Логирует любое неизвестное событие.
// 3. Вся логика заключена в блок `try..except` для перехвата и логирования критических ошибок, при возникновении которых происходит отключение от сервера.
procedure TClientForm.WMSocket(var Message: TLMessage);
var
Event: Word;
Error: Integer;
begin
Event := LOWORD(Message.LParam);
Error := HIWORD(Message.LParam);
try
SafeLog(Format('WMSocket вызван. Событие: %d, Ошибка: %d', [Event, Error]));
case Event of
FD_READ:
begin
if Error = 0 then
begin
SafeLog('FD_READ событие');
ProcessServerData;
end
else
begin
SafeLog('FD_READ ошибка: ' + IntToStr(Error));
SetStatus('Socket read error: ' + IntToStr(Error));
DisconnectFromServer;
end;
end;
FD_CLOSE:
begin
SafeLog('FD_CLOSE событие - сервер закрыл соединение. Ошибка: ' + IntToStr(Error));
if Error <> 0 then
SetStatus('Connection broken by server (Error: ' + IntToStr(Error) + ')')
else
SetStatus('Connection broken by server');
DisconnectFromServer;
end;
else
SafeLog('Неизвестное событие сокета: ' + IntToStr(Event));
end;
except
on E: Exception do
begin
SafeLog('КРИТИЧЕСКАЯ ОШИБКА в WMSocket: ' + E.Message);
DisconnectFromServer;
end;
end;
end;
end.Код серверной части:
Код:
unit ServerUnit;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls, ExtCtrls,
Windows, WinSock2, LMessages;
const
VNC_PORT = 5900;
MAX_CLIENTS = 5;
WM_SOCKET = WM_USER + 1;
// Константы для захвата экрана (Screen capture constants)
// SRCCOPY: Определяет, что исходный прямоугольник должен быть скопирован в целевой прямоугольник. Используется в BitBlt.
SRCCOPY = $00CC0020;
// DIB_RGB_COLORS: Указывает, что цвета в BITMAPINFO состоят из явных значений RGB. Используется в CreateDIBSection.
DIB_RGB_COLORS = 0;
// BI_RGB: Указывает, что битмап не сжат. Используется в BITMAPINFOHEADER.biCompression.
BI_RGB = 0;
// SM_CXSCREEN: Индекс для GetSystemMetrics, возвращает ширину экрана в пикселях.
SM_CXSCREEN = 0;
// SM_CYSCREEN: Индекс для GetSystemMetrics, возвращает высоту экрана в пикселях.
SM_CYSCREEN = 1;
// Константы для обработки ввода (Input constants)
// INPUT_MOUSE: Указывает, что структура TInputRec содержит событие мыши (MOUSEINPUT).
INPUT_MOUSE = 0;
// INPUT_KEYBOARD: Указывает, что структура TInputRec содержит событие клавиатуры (KEYBDINPUT).
INPUT_KEYBOARD = 1;
// MOUSEEVENTF_LEFTDOWN: Флаг для SendInput, имитирует нажатие левой кнопки мыши.
MOUSEEVENTF_LEFTDOWN = $0002;
// MOUSEEVENTF_LEFTUP: Флаг для SendInput, имитирует отпускание левой кнопки мыши.
MOUSEEVENTF_LEFTUP = $0004;
// MOUSEEVENTF_RIGHTDOWN: Флаг для SendInput, имитирует нажатие правой кнопки мыши.
MOUSEEVENTF_RIGHTDOWN = $0008;
// MOUSEEVENTF_RIGHTUP: Флаг для SendInput, имитирует отпускание правой кнопки мыши.
MOUSEEVENTF_RIGHTUP = $0010;
// KEYEVENTF_KEYUP: Флаг для SendInput, имитирует отпускание клавиши клавиатуры.
KEYEVENTF_KEYUP = $0002;
// Блок Windows API:
// Этот блок содержит объявления внешних функций из системных библиотек Windows (user32.dll, gdi32.dll).
// Эти функции позволяют программе взаимодействовать с операционной системой на низком уровне,
// выполняя такие задачи, как получение информации о системе, работа с графическим интерфейсом
// (контексты устройств, битмапы) и имитация пользовательского ввода.
function GetSystemMetrics(nIndex: Integer): Integer; stdcall; external 'user32.dll';
// GetSystemMetrics: Возвращает различные системные параметры, такие как размеры экрана.
// nIndex: Индекс параметра, который нужно получить (например, SM_CXSCREEN для ширины экрана).
function GetDC(hWnd: HWND): HDC; stdcall; external 'user32.dll';
// GetDC: Получает контекст устройства (Device Context - HDC) для указанного окна или всего экрана.
// HDC - это дескриптор, который позволяет рисовать на поверхности или получать информацию о ней.
// hWnd: Дескриптор окна. Если 0, возвращается контекст устройства для всего экрана.
function ReleaseDC(hWnd: HWND; hDC: HDC): Integer; stdcall; external 'user32.dll';
// ReleaseDC: Освобождает контекст устройства, полученный ранее с помощью GetDC.
// Важно освобождать DC, чтобы избежать утечек ресурсов.
function CreateCompatibleDC(hdc: HDC): HDC; stdcall; external 'gdi32.dll';
// CreateCompatibleDC: Создает контекст устройства в памяти, совместимый с указанным DC.
// Это позволяет рисовать в памяти, а затем быстро копировать изображение на экран.
function DeleteDC(hdc: HDC): BOOL; stdcall; external 'gdi32.dll';
// DeleteDC: Удаляет указанный контекст устройства в памяти.
function CreateDIBSection(hdc: HDC; const pbmi: BITMAPINFO; iUsage: UINT;
var ppvBits: Pointer; hSection: THandle; dwOffset: DWORD): HBITMAP; stdcall; external 'gdi32.dll';
// CreateDIBSection: Создает секцию DIB (Device-Independent Bitmap), которая позволяет
// приложению напрямую обращаться к пиксельным данным битмапа в памяти. Это очень эффективно
// для быстрой обработки изображений, например, для захвата экрана.
// ppvBits: Указатель на адрес, по которому будут доступны пиксельные данные битмапа.
function SelectObject(hdc: HDC; hgdiobj: HGDIOBJ): HGDIOBJ; stdcall; external 'gdi32.dll';
// SelectObject: Выбирает объект GDI (например, битмап, перо, кисть) в указанный контекст устройства.
// Возвращает предыдущий объект того же типа, который был выбран в DC. Это важно для последующего восстановления.
function BitBlt(DestDC: HDC; X, Y, Width, Height: Integer; SrcDC: HDC;
XSrc, YSrc: Integer; Rop: DWORD): BOOL; stdcall; external 'gdi32.dll';
// BitBlt: Выполняет побитовое блочное копирование цвета из исходного контекста устройства
// в целевой. Используется для быстрого копирования изображения экрана в битмап в памяти.
// Rop: Растровая операция, определяющая, как цвета исходного и целевого DC объединяются.
function DeleteObject(hObject: HGDIOBJ): BOOL; stdcall; external 'gdi32.dll';
// DeleteObject: Удаляет объект GDI (например, битмап), освобождая связанные с ним ресурсы.
function SendInput(cInputs: UINT; pInputs: Pointer; cbSize: Integer): UINT; stdcall; external 'user32.dll';
// SendInput: Вставляет события клавиатуры или мыши в поток ввода системы.
// Позволяет программе имитировать действия пользователя, такие как нажатия клавиш или движения мыши.
// pInputs: Указатель на массив структур TInputRec, описывающих события.
function SetCursorPos(X, Y: Integer): BOOL; stdcall; external 'user32.dll';
// SetCursorPos: Устанавливает текущую позицию курсора мыши на экране в указанных координатах.
type
// Простые структуры (Simple structures)
// TScreenHeader: Структура для передачи информации о скриншоте (ширина, высота, размер данных)
// перед передачей самих пиксельных данных по сети.
TScreenHeader = packed record
Width: DWORD;
Height: DWORD;
DataSize: DWORD;
end;
// TMouseMsg: Структура для передачи событий мыши от клиента к серверу.
// Содержит тип сообщения, состояние кнопок и координаты X/Y.
TMouseMsg = packed record
MsgType: Byte;
Buttons: Byte;
X: WORD;
Y: WORD;
end;
// TKeyMsg: Структура для передачи событий клавиатуры от клиента к серверу.
// Содержит тип сообщения, флаг "нажата/отпущена" и код клавиши.
TKeyMsg = packed record
MsgType: Byte;
IsDown: Byte;
KeyCode: DWORD;
end;
// TInputRec: Объединенная запись, используемая функцией SendInput для описания
// либо события мыши (MOUSEINPUT), либо события клавиатуры (KEYBDINPUT).
TInputRec = record
InputType: DWORD;
case Integer of
0: (mi: MOUSEINPUT);
1: (ki: KEYBDINPUT);
end;
TServerForm = class(TForm)
Button1: TButton; // Кнопка "Start" для запуска сервера.
Button2: TButton; // Кнопка "Stop" для остановки сервера.
Edit1: TEdit; // Поле ввода для номера порта, на котором будет слушать сервер.
Label1: TLabel; // Метка для отображения текущего статуса сервера (запущен/остановлен, порт).
Label2: TLabel; // Метка для отображения количества подключенных клиентов.
Memo1: TMemo; // Многострочное текстовое поле (лог) для вывода сообщений о работе сервера.
Timer1: TTimer; // Таймер, используемый для периодической отправки скриншотов клиентам.
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
private
FServerSocket: TSocket; // Дескриптор серверного сокета.
FClients: array[0..MAX_CLIENTS-1] of TSocket; // Массив дескрипторов клиентских сокетов.
FClientCount: Integer; // Текущее количество подключенных клиентов.
FRunning: Boolean; // Флаг, указывающий, запущен ли сервер.
FWSAData: TWSADATA; // Структура для хранения информации Winsock при инициализации.
// Переменные для захвата экрана (Screen capture)
FScreenDC: HDC; // Контекст устройства всего экрана.
FMemoryDC: HDC; // Совместимый контекст устройства в памяти для рисования.
FBitmap: HBITMAP; // Дескриптор битмапа, в который копируется изображение экрана.
FBitmapInfo: BITMAPINFO; // Структура с информацией о битмапе (размеры, формат).
FPixelData: PByte; // Указатель на пиксельные данные битмапа в памяти.
FScreenWidth: Integer; // Ширина экрана.
FScreenHeight: Integer; // Высота экрана.
// Приватные процедуры
procedure StartServer; // Запускает VNC-сервер.
procedure StopServer; // Останавливает VNC-сервер.
procedure AcceptClient; // Принимает новое клиентское подключение.
procedure ProcessClient(Index: Integer); // Обрабатывает данные, полученные от клиента.
procedure DisconnectClient(Index: Integer); // Отключает клиента.
procedure InitScreen; // Инициализирует ресурсы для захвата экрана.
procedure CleanupScreen; // Освобождает ресурсы, связанные с захватом экрана.
procedure CaptureScreen; // Делает скриншот экрана и копирует его в битмап в памяти.
procedure SendScreenToAll; // Отправляет текущий скриншот всем подключенным клиентам.
procedure HandleMouse(const Msg: TMouseMsg); // Обрабатывает события мыши, полученные от клиента.
procedure HandleKey(const Msg: TKeyMsg); // Обрабатывает события клавиатуры, полученные от клиента.
procedure AddLog(const Msg: string); // Добавляет сообщение в лог.
protected
procedure WMSocket(var Message: TLMessage); message WM_SOCKET; // Обработчик асинхронных сетевых сообщений.
public
end;
var
ServerForm: TServerForm;
implementation
{$R *.lfm}
procedure TServerForm.FormCreate(Sender: TObject);
var
i: Integer;
begin
// Назначение: Инициализация компонентов формы и переменных сервера при создании окна.
// Как работает:
// 1. Устанавливает начальные надписи для кнопок, заголовка формы и текстовых полей.
// 2. Деактивирует кнопку "Stop", так как сервер еще не запущен.
// 3. Инициализирует дескрипторы сокетов клиентов как недействительные (INVALID_SOCKET) и сбрасывает счетчик клиентов.
// 4. Инициализирует библиотеку Winsock (Windows Sockets API) с помощью `WSAStartup`. Это необходимо для работы с сетевыми сокетами. Если инициализация не удалась, выводится сообщение об ошибке.
// 5. Устанавливает интервал для `Timer1` в 100 миллисекунд (что соответствует 10 кадрам в секунду) и по умолчанию отключает его.
// 6. Добавляет первое сообщение в лог-окно.
Caption := 'Simple VNC Server';
Button1.Caption := 'Start';
Button2.Caption := 'Stop';
Button2.Enabled := False;
Edit1.Text := '5900';
Label1.Caption := 'Stopped';
Label2.Caption := 'Clients: 0';
FServerSocket := INVALID_SOCKET;
for i := 0 to MAX_CLIENTS-1 do
FClients[i] := INVALID_SOCKET;
FClientCount := 0;
FRunning := False;
// Initialize Winsock
if WSAStartup(MAKEWORD(2, 2), FWSAData) <> 0 then
begin
ShowMessage('Winsock init failed');
Exit;
end;
Timer1.Interval := 100; // 10FPS
Timer1.Enabled := False;
AddLog('Server ready');
end;
procedure TServerForm.FormDestroy(Sender: TObject);
begin
// Назначение: Корректное освобождение всех системных ресурсов, занятых сервером, перед его завершением.
// Как работает:
// 1. Вызывает `StopServer`, чтобы остановить все сетевые операции и отключить клиентов.
// 2. Вызывает `CleanupScreen` для освобождения ресурсов, связанных с захватом экрана (битмапы, контексты устройств).
// 3. Вызывает `WSACleanup`, чтобы деинициализировать библиотеку Winsock. Это важно для освобождения системных ресурсов, используемых сетевым стеком.
StopServer;
CleanupScreen;
WSACleanup;
end;
procedure TServerForm.Button1Click(Sender: TObject);
begin
// Назначение: Обработчик события нажатия кнопки "Start".
// Как работает: Просто вызывает приватную процедуру `StartServer`, которая содержит всю логику запуска сервера.
StartServer;
end;
procedure TServerForm.Button2Click(Sender: TObject);
begin
// Назначение: Обработчик события нажатия кнопки "Stop".
// Как работает: Просто вызывает приватную процедуру `StopServer`, которая содержит всю логику остановки сервера.
StopServer;
end;
procedure TServerForm.Timer1Timer(Sender: TObject);
begin
// Назначение: Периодическая отправка текущего изображения экрана всем подключенным клиентам.
// Как работает:
// 1. Проверяет два условия: запущен ли сервер (`FRunning`) и есть ли хотя бы один подключенный клиент (`FClientCount > 0`).
// 2. Если оба условия истинны, вызывает `SendScreenToAll`, которая выполняет захват экрана и рассылку изображения.
// Этот таймер обеспечивает постоянную "трансляцию" рабочего стола.
if FRunning and (FClientCount > 0) then
SendScreenToAll;
end;
procedure TServerForm.StartServer;
var
ServerAddr: TSockAddrIn;
Port: Integer;
begin
// Назначение: Запуск VNC-сервера, включая инициализацию сетевых сокетов и подготовку к захвату экрана.
// Как работает:
// 1. Проверяет, не запущен ли сервер уже. Если да, выходит.
// 2. Получает номер порта из текстового поля `Edit1` или использует значение по умолчанию (`VNC_PORT`).
// 3. Вызывает `InitScreen` для инициализации графических ресурсов для захвата экрана.
// 4. Создает серверный сокет с помощью функции `socket` (`AF_INET` для IPv4, `SOCK_STREAM` для TCP, `IPPROTO_TCP`).
// 5. Заполняет структуру `ServerAddr` для привязки сокета к любому доступному IP-адресу на указанном порту (`INADDR_ANY`).
// 6. Привязывает сокет к адресу и порту с помощью `bind`.
// 7. Переводит сокет в режим прослушивания входящих соединений с помощью `listen`, указывая максимальную очередь ожидающих подключений (`SOMAXCONN`).
// 8. Настраивает асинхронный режим работы сокета с помощью `WSAAsyncSelect`. Это позволяет системе Windows отправлять сообщения `WM_SOCKET` форме, когда происходят сетевые события (в данном случае `FD_ACCEPT` для новых подключений).
// 9. Устанавливает флаг `FRunning` в True, активирует кнопку "Stop", деактивирует кнопку "Start" и включает таймер.
// 10. Обновляет статус на форме и добавляет сообщение о запуске сервера в лог.
// 11. В случае любой ошибки во время запуска (например, порт занят), перехватывает исключение, выводит сообщение об ошибке и очищает ресурсы захвата экрана.
if FRunning then Exit;
Port := StrToIntDef(Edit1.Text, VNC_PORT);
try
InitScreen;
FServerSocket := socket(AF_INET, SOCK_STREAM, IPPROTO_TCP);
if FServerSocket = INVALID_SOCKET then
raise Exception.Create('Socket creation failed');
ZeroMemory(@ServerAddr, SizeOf(ServerAddr));
ServerAddr.sin_family := AF_INET;
ServerAddr.sin_addr.s_addr := INADDR_ANY;
ServerAddr.sin_port := htons(Port);
if bind(FServerSocket, @ServerAddr, SizeOf(ServerAddr)) = SOCKET_ERROR then
raise Exception.Create('Bind failed');
if listen(FServerSocket, SOMAXCONN) = SOCKET_ERROR then
raise Exception.Create('Listen failed');
WSAAsyncSelect(FServerSocket, Handle, WM_SOCKET, FD_ACCEPT);
FRunning := True;
Button1.Enabled := False;
Button2.Enabled := True;
Timer1.Enabled := True;
Label1.Caption := 'Running on port ' + IntToStr(Port);
AddLog('Server started on port ' + IntToStr(Port));
except
on E: Exception do
begin
AddLog('Start error: ' + E.Message);
ShowMessage('Start error: ' + E.Message);
CleanupScreen;
end;
end;
end;
procedure TServerForm.StopServer;
var
i: Integer;
begin
// Назначение: Остановка VNC-сервера, закрытие всех соединений и освобождение ресурсов.
// Как работает:
// 1. Проверяет, запущен ли сервер. Если нет, выходит.
// 2. Устанавливает флаг `FRunning` в False и отключает таймер, чтобы прекратить отправку скриншотов.
// 3. В цикле проходит по всем возможным клиентским сокетам (`FClients`). Если сокет активен (не `INVALID_SOCKET`), вызывает `DisconnectClient` для каждого клиента, чтобы корректно закрыть их соединения.
// 4. Если серверный сокет активен, закрывает его с помощью `closesocket` и сбрасывает `FServerSocket` в `INVALID_SOCKET`.
// 5. Вызывает `CleanupScreen` для освобождения графических ресурсов.
// 6. Обновляет состояние кнопок и меток на форме, а также добавляет сообщение об остановке сервера в лог.
if not FRunning then Exit;
FRunning := False;
Timer1.Enabled := False;
for i := 0 to MAX_CLIENTS-1 do
if FClients[i] <> INVALID_SOCKET then
DisconnectClient(i);
if FServerSocket <> INVALID_SOCKET then
begin
closesocket(FServerSocket);
FServerSocket := INVALID_SOCKET;
end;
CleanupScreen;
Button1.Enabled := True;
Button2.Enabled := False;
Label1.Caption := 'Stopped';
Label2.Caption := 'Clients: 0';
AddLog('Server stopped');
end;
procedure TServerForm.AcceptClient;
var
ClientSocket: TSocket;
i: Integer;
Greeting: AnsiString;
begin
// Назначение: Обработка нового входящего клиентского подключения.
// Как работает:
// 1. Использует функцию `accept` для принятия нового соединения. Если `accept` возвращает `INVALID_SOCKET`, это означает ошибку или отсутствие соединения, и процедура завершается.
// 2. Ищет свободный слот в массиве `FClients` (сокет со значением `INVALID_SOCKET`). `MAX_CLIENTS` ограничивает количество одновременных подключений.
// 3. Если свободный слот найден:
// а. Сохраняет дескриптор нового клиентского сокета в этом слоте.
// б. Настраивает `WSAAsyncSelect` для этого клиентского сокета, чтобы получать сообщения `WM_SOCKET` при наличии данных для чтения (`FD_READ`) или при отключении клиента (`FD_CLOSE`).
// в. Отправляет клиенту простое приветственное сообщение "VNC Ready".
// г. Увеличивает счетчик клиентов (`FClientCount`), обновляет метку на форме и добавляет сообщение в лог.
// 4. Если свободных слотов нет (достигнуто `MAX_CLIENTS`), новое соединение отклоняется: сокет закрывается, и в лог добавляется сообщение.
ClientSocket := accept(FServerSocket, nil, nil);
if ClientSocket = INVALID_SOCKET then Exit;
// Find free slot
for i := 0 to MAX_CLIENTS-1 do
begin
if FClients[i] = INVALID_SOCKET then
begin
FClients[i] := ClientSocket;
WSAAsyncSelect(ClientSocket, Handle, WM_SOCKET, FD_READ or FD_CLOSE);
Greeting := 'VNC Ready'#13#10;
send(ClientSocket, Greeting[1], Length(Greeting), 0);
Inc(FClientCount);
Label2.Caption := 'Clients: ' + IntToStr(FClientCount);
AddLog('Client connected');
Exit;
end;
end;
// No free slots
closesocket(ClientSocket);
AddLog('Client rejected - no slots');
end;
procedure TServerForm.ProcessClient(Index: Integer);
var
Buffer: array[0..255] of Byte;
BytesReceived: Integer;
MouseMsg: TMouseMsg;
KeyMsg: TKeyMsg;
begin
// Назначение: Обработка данных, полученных от конкретного клиента.
// Как работает:
// 1. Проверяет валидность клиентского сокета по индексу.
// 2. Пытается получить данные из сокета клиента с помощью `recv`. Максимальный размер буфера - 256 байт.
// 3. Если `BytesReceived` меньше или равно 0, это обычно означает, что клиент отключился или произошла ошибка чтения. В этом случае вызывается `DisconnectClient` для данного клиента.
// 4. Если данные получены, анализирует первый байт `Buffer[0]`, который служит "типом сообщения":
// а. `1`: Клиент запросил обновление экрана. Вызывается `SendScreenToAll` для отправки текущего кадра.
// б. `2`: Получено событие мыши. Данные из буфера копируются в структуру `TMouseMsg`, и затем вызывается `HandleMouse` для обработки.
// в. `3`: Получено событие клавиатуры. Данные копируются в структуру `TKeyMsg`, и вызывается `HandleKey` для обработки.
if FClients[Index] = INVALID_SOCKET then Exit;
BytesReceived := recv(FClients[Index], Buffer, SizeOf(Buffer), 0);
if BytesReceived <= 0 then
begin
DisconnectClient(Index);
Exit;
end;
case Buffer[0] of
1: // Update request
begin
AddLog(Format('Client #%d requests update', [Index]));
SendScreenToAll;
end;
2: // Mouse event
begin
if BytesReceived >= SizeOf(TMouseMsg) then
begin
Move(Buffer, MouseMsg, SizeOf(TMouseMsg));
HandleMouse(MouseMsg);
end;
end;
3: // Key event
begin
if BytesReceived >= SizeOf(TKeyMsg) then
begin
Move(Buffer, KeyMsg, SizeOf(TKeyMsg));
HandleKey(KeyMsg);
end;
end;
end;
end;
procedure TServerForm.DisconnectClient(Index: Integer);
begin
// Назначение: Отключение конкретного клиента и освобождение его слота.
// Как работает:
// 1. Проверяет валидность клиентского сокета по индексу.
// 2. Закрывает сокет клиента с помощью `closesocket`.
// 3. Устанавливает дескриптор сокета в массиве `FClients` обратно в `INVALID_SOCKET`, делая слот свободным.
// 4. Уменьшает счетчик подключенных клиентов (`FClientCount`) и обновляет соответствующую метку на форме.
// 5. Добавляет сообщение об отключении клиента в лог.
if FClients[Index] = INVALID_SOCKET then Exit;
closesocket(FClients[Index]);
FClients[Index] := INVALID_SOCKET;
Dec(FClientCount);
Label2.Caption := 'Clients: ' + IntToStr(FClientCount);
AddLog('Client disconnected');
end;
procedure TServerForm.InitScreen;
begin
// Назначение: Инициализация всех необходимых графических объектов и контекстов устройств для захвата экрана.
// Как работает:
// 1. Получает текущие ширину и высоту основного экрана с помощью `GetSystemMetrics` (используя константы `SM_CXSCREEN` и `SM_CYSCREEN`). Если эти значения невалидны (например, 0), устанавливает стандартные 1024x768.
// 2. Получает контекст устройства для всего экрана (`FScreenDC`) с помощью `GetDC(0)`.
// 3. Создает совместимый контекст устройства в памяти (`FMemoryDC`) с помощью `CreateCompatibleDC`. Этот DC будет использоваться для рисования захваченного изображения.
// 4. Заполняет структуру `FBitmapInfo` (тип `BITMAPINFO`) для описания желаемого формата битмапа:
// - `biSize`: Размер заголовка структуры.
// - `biWidth`: Ширина экрана.
// - `biHeight`: Высота экрана, но отрицательное значение (`-FScreenHeight`) указывает, что битмап является "сверху вниз" (первая строка пикселей - верхняя строка изображения), что часто удобно для обработки.
// - `biPlanes`: Количество цветовых плоскостей (всегда 1).
// - `biBitCount`: Количество бит на пиксель (24 для 24-битного RGB).
// - `biCompression`: Метод сжатия (BI_RGB означает отсутствие сжатия).
// 5. Создает секцию DIB (`FBitmap`) с помощью `CreateDIBSection`. Эта функция не только создает битмап, но и возвращает указатель (`FPixelData`) на его пиксельные данные в памяти. Это позволяет быстро получить прямой доступ к пикселям для их передачи.
// 6. Выбирает созданный битмап (`FBitmap`) в контекст устройства памяти (`FMemoryDC`) с помощью `SelectObject`. Теперь все операции рисования на `FMemoryDC` будут влиять на `FBitmap`.
// 7. Добавляет информацию о размере инициализированного экрана в лог.
FScreenWidth := GetSystemMetrics(SM_CXSCREEN);
FScreenHeight := GetSystemMetrics(SM_CYSCREEN);
if (FScreenWidth <= 0) or (FScreenHeight <= 0) then
begin
FScreenWidth := 1024;
FScreenHeight := 768;
end;
FScreenDC := GetDC(0);
FMemoryDC := CreateCompatibleDC(FScreenDC);
ZeroMemory(@FBitmapInfo, SizeOf(FBitmapInfo));
FBitmapInfo.bmiHeader.biSize := SizeOf(BITMAPINFOHEADER);
FBitmapInfo.bmiHeader.biWidth := FScreenWidth;
FBitmapInfo.bmiHeader.biHeight := -FScreenHeight; // Negative height for top-down DIB
FBitmapInfo.bmiHeader.biPlanes := 1;
FBitmapInfo.bmiHeader.biBitCount := 24;
FBitmapInfo.bmiHeader.biCompression := BI_RGB;
// CreateDIBSection returns a handle to the DIB, and ppvBits points to the pixel data
FBitmap := CreateDIBSection(FMemoryDC, FBitmapInfo, DIB_RGB_COLORS, Pointer(FPixelData), 0, 0);
SelectObject(FMemoryDC, FBitmap);
AddLog(Format('Screen init: %dx%d', [FScreenWidth, FScreenHeight]));
end;
procedure TServerForm.CleanupScreen;
begin
// **Назначение:** Освобождение всех графических ресурсов, занятых при захвате экрана.
// **Как работает:**
// 1. Проверяет, был ли битмап `FBitmap` создан. Если да, удаляет его с помощью `DeleteObject`.
// 2. Проверяет, был ли контекст устройства памяти `FMemoryDC` создан. Если да, удаляет его с помощью `DeleteDC`.
// 3. Проверяет, был ли контекст устройства экрана `FScreenDC` получен. Если да, освобождает его с помощью `ReleaseDC`.
// 4. Сбрасывает указатель на пиксельные данные `FPixelData` в `nil`.
if FBitmap <> 0 then DeleteObject(FBitmap);
if FMemoryDC <> 0 then DeleteDC(FMemoryDC);
if FScreenDC <> 0 then ReleaseDC(0, FScreenDC);
FPixelData := nil;
end;
procedure TServerForm.CaptureScreen;
begin
// Назначение: Копирование текущего содержимого экрана в битмап, расположенный в памяти.
// Как работает:
// 1. Проверяет, что все необходимые дескрипторы (для экрана, памяти и битмапа) инициализированы.
// 2. Использует функцию `BitBlt` для выполнения "битового блочного переноса" (Bit Block Transfer).
// - `FMemoryDC`: Целевой контекст устройства (куда копируем).
// - `0, 0`: Координаты назначения (левый верхний угол `FMemoryDC`).
// - `FScreenWidth, FScreenHeight`: Ширина и высота области для копирования.
// - `FScreenDC`: Исходный контекст устройства (откуда копируем, т.е. экран).
// - `0, 0`: Координаты исходной области (левый верхний угол экрана).
// - `SRCCOPY`: Растровая операция, указывающая на прямое копирование пикселей из источника в цель.
// После выполнения этой процедуры, пиксельные данные экрана будут доступны через указатель `FPixelData`.
if (FScreenDC = 0) or (FMemoryDC = 0) or (FBitmap = 0) then Exit;
BitBlt(FMemoryDC, 0, 0, FScreenWidth, FScreenHeight, FScreenDC, 0, 0, SRCCOPY);
end;
procedure TServerForm.SendScreenToAll;
var
Header: TScreenHeader;
ImageSize: DWORD;
i: Integer;
begin
// Назначение: Отправка захваченного изображения экрана всем активным клиентам.
// Как работает:
// 1. Проверяет, есть ли подключенные клиенты и доступны ли пиксельные данные. Если нет, выходит.
// 2. Вызывает `CaptureScreen` для создания свежего скриншота.
// 3. Вычисляет `ImageSize`: поскольку используется 24-битный цвет, каждый пиксель занимает 3 байта (`Width * Height * 3`).
// 4. Заполняет структуру `Header` (тип `TScreenHeader`) с шириной, высотой и размером данных изображения. Эта структура будет отправлена первой, чтобы клиент знал, сколько данных и какого размера ожидать.
// 5. Добавляет отладочное сообщение в лог о подготовке к отправке кадра.
// 6. В цикле проходит по всем возможным клиентским сокетам (`FClients`):
// а. Если слот клиента активен:
// i. Отправляет структуру `Header` с помощью `send`.
// ii. Если заголовок отправлен успешно, отправляет сами пиксельные данные (`FPixelData^`) с помощью `send`.
// iii. Добавляет сообщения об успехе или ошибке отправки в лог для каждого клиента.
// 7. Вся операция заключена в блок `try..except` для перехвата возможных сетевых ошибок и их логирования.
if (FClientCount = 0) or (FPixelData = nil) then Exit;
try
CaptureScreen;
ImageSize := FScreenWidth * FScreenHeight * 3; // 3 bytes per pixel (24-bit RGB)
Header.Width := FScreenWidth;
Header.Height := FScreenHeight;
Header.DataSize := ImageSize;
AddLog(Format('Отправляем кадр %dx%d (%d байт) %d клиентам',
[FScreenWidth, FScreenHeight, ImageSize, FClientCount]));
for i := 0 to MAX_CLIENTS-1 do
begin
if FClients[i] <> INVALID_SOCKET then
begin
AddLog(Format('Отправляем заголовок клиенту #%d', [i]));
if send(FClients[i], Header, SizeOf(Header), 0) = SizeOf(Header) then
begin
AddLog(Format('Отправляем данные клиенту #%d', [i]));
// FPixelData^ - это разыменование указателя, получаем сами данные битмапа
if send(FClients[i], FPixelData^, ImageSize, 0) = Integer(ImageSize) then
AddLog(Format('Данные отправлены клиенту #%d успешно', [i]))
else
AddLog(Format('Ошибка отправки данных клиенту #%d', [i]));
end
else
AddLog(Format('Ошибка отправки заголовка клиенту #%d', [i]));
end;
end;
except
on E: Exception do
AddLog('Ошибка в SendScreenToAll: ' + E.Message);
end;
end;
procedure TServerForm.HandleMouse(const Msg: TMouseMsg);
var
Input: TInputRec;
begin
// Назначение: Обработка полученных от клиента событий мыши и их имитация в системе.
// Как работает:
// 1. Устанавливает текущую позицию курсора мыши на экране в координаты, переданные в `Msg.X` и `Msg.Y`, с помощью `SetCursorPos`.
// 2. Инициализирует структуру `Input` (тип `TInputRec`) нулями.
// 3. Устанавливает `Input.InputType` в `INPUT_MOUSE`, указывая, что это событие мыши.
// 4. Проверяет бит 0 в `Msg.Buttons`. Если он установлен (что соответствует нажатой левой кнопке мыши), устанавливает флаг `MOUSEEVENTF_LEFTDOWN` для имитации нажатия. В противном случае (бит 0 не установлен), устанавливает `MOUSEEVENTF_LEFTUP` для имитации отпускания.
// *Примечание:* В текущей реализации обрабатывается только левая кнопка мыши (бит 0). Для обработки других кнопок (правой, средней) потребуется добавить соответствующие проверки битов и флаги (`MOUSEEVENTF_RIGHTDOWN`, `MOUSEEVENTF_RIGHTUP` и т.д.).
// 5. Отправляет имитированное событие мыши в систему с помощью `SendInput`. `cInputs` равен 1 (одно событие), `pInputs` указывает на структуру `Input`, `cbSize` - размер структуры.
SetCursorPos(Msg.X, Msg.Y);
ZeroMemory(@Input, SizeOf(Input));
Input.InputType := INPUT_MOUSE;
// Bit 0 of Buttons is for Left Button
if Msg.Buttons and 1 <> 0 then
Input.mi.dwFlags := MOUSEEVENTF_LEFTDOWN
else
Input.mi.dwFlags := MOUSEEVENTF_LEFTUP;
SendInput(1, @Input, SizeOf(Input));
end;
procedure TServerForm.HandleKey(const Msg: TKeyMsg);
var
Input: TInputRec;
begin
// Назначение: Обработка полученных от клиента событий клавиатуры и их имитация в системе.
// Как работает:
// 1. Инициализирует структуру `Input` (тип `TInputRec`) нулями.
// 2. Устанавливает `Input.InputType` в `INPUT_KEYBOARD`, указывая, что это событие клавиатуры.
// 3. Устанавливает `Input.ki.wVk` (виртуальный код клавиши) в значение `Msg.KeyCode`, которое представляет собой код нажатой/отпущенной клавиши.
// 4. Проверяет значение `Msg.IsDown`. Если оно равно 0, это означает, что клавиша была отпущена, и устанавливается флаг `KEYEVENTF_KEYUP`. Если `Msg.IsDown` другое (например, 1), это подразумевает нажатие клавиши (по умолчанию, без флага `KEYEVENTF_KEYUP`).
// 5. Отправляет имитированное событие клавиатуры в систему с помощью `SendInput`.
ZeroMemory(@Input, SizeOf(Input));
Input.InputType := INPUT_KEYBOARD;
Input.ki.wVk := Msg.KeyCode;
if Msg.IsDown = 0 then // 0 means key up
Input.ki.dwFlags := KEYEVENTF_KEYUP;
SendInput(1, @Input, SizeOf(Input));
end;
procedure TServerForm.AddLog(const Msg: string);
begin
// Назначение: Добавление отладочных и информационных сообщений в лог-окно на форме.
// Как работает:
// 1. Формирует строку сообщения, добавляя текущее время в квадратных скобках перед самим сообщением.
// 2. Добавляет эту строку в `Memo1.Lines` (список строк текстового поля).
// 3. Проверяет количество строк в `Memo1.Lines`. Если их стало более 100, удаляет самую старую строку (строку с индексом 0), чтобы лог не разрастался бесконечно и не потреблял слишком много памяти.
Memo1.Lines.Add('[' + TimeToStr(Now) + '] ' + Msg);
while Memo1.Lines.Count > 100 do
Memo1.Lines.Delete(0);
end;
procedure TServerForm.WMSocket(var Message: TLMessage);
var
i: Integer;
begin
// Назначение: Обработчик пользовательского сообщения `WM_SOCKET`, которое операционная система отправляет форме при возникновении асинхронных сетевых событий на сокетах, настроенных через `WSAAsyncSelect`.
// Как работает:
// 1. Использует `LOWORD(Message.LParam)` для получения кода сетевого события Winsock:
// а. `FD_ACCEPT`: Происходит, когда на серверном сокете есть новое входящее подключение. В этом случае вызывается `AcceptClient`.
// б. `FD_READ`: Происходит, когда на клиентском сокете доступны данные для чтения.
// - `Message.WParam` содержит дескриптор сокета, на котором произошло событие.
// - В цикле `for` ищется соответствующий сокет в массиве `FClients`.
// - Когда сокет найден, вызывается `ProcessClient` для обработки входящих данных.
// в. `FD_CLOSE`: Происходит, когда клиентский сокет был закрыт (клиент отключился).
// - Аналогично `FD_READ`, ищется соответствующий сокет.
// - Вызывается `DisconnectClient` для корректного закрытия соединения и освобождения слота.
case LOWORD(Message.LParam) of
FD_ACCEPT: AcceptClient;
FD_READ:
begin
for i := 0 to MAX_CLIENTS-1 do
if FClients[i] = Message.WParam then // Message.WParam holds the socket handle
begin
ProcessClient(i);
Break; // Найден и обработан, можно выйти из цикла
end;
end;
FD_CLOSE:
begin
for i := 0 to MAX_CLIENTS-1 do
if FClients[i] = Message.WParam then
begin
DisconnectClient(i);
Break; // Найден и обработан, можно выйти из цикла
end;
end;
end;
end;
end.Файлы проекта для компиляции (пароль на архив "xss.pro"): https://send.exploit.in/download/feb1e7092cad9c0f/#Tr0I7zF4qdgDLuC6b7btuQ
P.S. Активно продолжаю работу над HVNC, как закончу, обязательно выложу. =)
Последнее редактирование:
