ГигаЧат оказался тоже не промах. Работает с библиотекой KOL
Вот код который я попросил его сделать. Тут можно уже что то шаманить.
Код:
program KOLFTPFullFeatured;
uses
Windows, KOL, Messages, SysUtils, Classes;
type
TFTPSessionState = record
User: string;
Authenticated: Boolean;
CurrentDir: string;
TransferType: Char;
// Для активного режима (PORT)
DataIP: string;
DataPort: Word;
// Для пассивного режима (PASV)
PASVSocket: PSocket;
end;
TWorkerThread = class(PThread)
private
FCtrlSock: PSocket;
FLogMemo: PControl;
FState: TFTPSessionState;
procedure SyncLog(const Msg: string);
procedure SendResponse(const Text: string);
function BuildFullPath(const FileName: string): string;
function NormalizeFTPPath(const Path: string): string;
procedure CreateDataChannel(out DataSock: PSocket);
procedure HandlePORT(const Param: string);
procedure HandlePASV(out Port: Word; out IP: string);
procedure HandleLIST;
procedure HandleRETR(const FileName: string);
procedure HandleSTOR(const FileName: string);
procedure HandleDELE(const FileName: string);
procedure HandleMKD(const DirName: string);
procedure HandleRMD(const DirName: string);
procedure HandleRNFR(const FileName: string);
procedure HandleRNTO(const FileName: string);
procedure HandleSIZE(const FileName: string);
protected
procedure Execute; override;
public
constructor Create(ClientSock: PSocket; LogTarget: PControl);
end;
var
Form, LogMemo: PControl;
Listener: PSocket;
Addr: TSockAddrIn;
{ Вспомогательные функции }
function NormalizeFTPPath(const Base, Path: string): string;
var
Parts, Stack: KOL.PStrList;
i: Integer;
begin
Result := Base;
if Path = '' then Exit;
if Path[1] = '/' then Result := '/';
Parts := NewStrList;
Parts.StrictDelimiter := True;
Parts.Delimiter := '/';
Parts.DelimitedText := Path;
Stack := NewStrList;
for i := 0 to Parts.Count - 1 do
begin
if Parts[i] = '..' then
begin
if Stack.Count > 0 then Stack.Delete(Stack.Count - 1);
end
else if (Parts[i] <> '') and (Parts[i] <> '.') then
Stack.Add(Parts[i]);
end;
if (Result = '/') and (Stack.Count > 0) then
Result := Result + Stack.StrictCommaText
else if (Result <> '/') and (Stack.Count > 0) then
Result := IncludeTrailingPathDelimiter(Result) + Stack.StrictCommaText;
Parts.Free;
Stack.Free;
end;
function TWorkerThread.BuildFullPath(const FileName: string): string;
begin
if FileName = '' then Exit('');
if FileName[1] = '/' then
Result := NormalizeFTPPath('/', FileName)
else
Result := NormalizeFTPPath(FState.CurrentDir, FileName);
end;
{ TWorkerThread }
constructor TWorkerThread.Create(ClientSock: PSocket; LogTarget: PControl);
begin
inherited Create(False);
FreeOnTerminate := True;
FCtrlSock := ClientSock;
FLogMemo := LogTarget;
FState.Authenticated := False;
FState.CurrentDir := '/';
FState.TransferType := 'A';
FState.DataPort := 0;
FState.PASVSocket := nil;
end;
procedure TWorkerThread.SyncLog(const Msg: string);
begin
if FLogMemo <> nil then
FLogMemo.Add('T' + IntToStr(ThreadID) + ': ' + Msg);
end;
procedure TWorkerThread.SendResponse(const Text: string);
begin
try
FCtrlSock.SendBuf(PAnsiChar(AnsiString(Text))^, Length(Text));
except
end;
end;
procedure TWorkerThread.HandlePORT(const Param: string);
var
Parts: KOL.PStrList;
IPStr: string;
P1, P2: Integer;
begin
Parts := NewStrList;
Parts.CommaText := StringReplace(Param, ',', '.', [rfReplaceAll]);
if Parts.Count = 6 then
begin
IPStr := Parts.Items[0] + '.' + Parts.Items[1] + '.' + Parts.Items[2] + '.' + Parts.Items[3];
P1 := StrToIntDef(Parts.Items[4], 0);
P2 := StrToIntDef(Parts.Items[5], 0);
FState.DataIP := IPStr;
FState.DataPort := P1 * 256 + P2;
SendResponse('200 PORT command successful.' + #13#10);
end
else
SendResponse('501 Syntax error in parameters.' + #13#10);
Parts.Free;
end;
procedure TWorkerThread.HandlePASV(out Port: Word; out IP: string);
var
DataSock: PSocket;
DataAddr: TSockAddrIn;
LocalIP: array[0..15] of Char;
begin
if FState.PASVSocket <> nil then FreeAndNil(FState.PASVSocket);
FState.PASVSocket := NewSocket;
FState.PASVSocket.SetReuseAddr(True);
Port := 50000;
repeat
DataAddr.sin_family := AF_INET;
DataAddr.sin_port := htons(Port);
DataAddr.sin_addr.S_addr := INADDR_ANY;
if FState.PASVSocket.Bind(DataAddr) = 0 then Break;
Inc(Port);
until Port > 50100;
if FState.PASVSocket.Listen(1) = SOCKET_ERROR then
begin
Port := 0;
FreeAndNil(FState.PASVSocket);
Exit;
end;
gethostname(LocalIP, SizeOf(LocalIP));
IP := LocalIP;
SyncLog('PASV listening on ' + IP + ':' + IntToStr(Port));
end;
procedure TWorkerThread.CreateDataChannel(out DataSock: PSocket);
var
DataAddr: TSockAddrIn;
begin
if (FState.DataPort > 0) and (FState.DataIP <> '') then
begin
// Активный режим (PORT)
DataSock := NewSocket;
DataAddr.sin_family := AF_INET;
DataAddr.sin_port := htons(FState.DataPort);
DataAddr.sin_addr.S_addr := inet_addr(PAnsiChar(AnsiString(FState.DataIP)));
if DataSock.Connect(DataAddr) = SOCKET_ERROR then
begin
SendResponse('425 Can't open data connection.' + #13#10);
DataSock.Free;
DataSock := nil;
end;
end
else if FState.PASVSocket <> nil then
begin
// Пассивный режим (PASV)
DataSock := FState.PASVSocket.Accept;
// Сокет прослушивания можно закрыть, он больше не нужен
FreeAndNil(FState.PASVSocket);
end
else
begin
SendResponse('425 Use PORT or PASV first.' + #13#10);
DataSock := nil;
end;
end;
procedure TWorkerThread.HandleLIST;
var
DataSock: PSocket;
SearchRec: TSearchRec;
ListStr, FullPath: string;
begin
CreateDataChannel(DataSock);
if DataSock = nil then Exit;
SendResponse('150 Opening ASCII mode data connection for file list.' + #13#10);
ListStr := '';
FullPath := IncludeTrailingPathDelimiter(FState.CurrentDir);
if FindFirst(FullPath + '*.*', faAnyFile, SearchRec) = 0 then
begin
repeat
if (SearchRec.Name <> '.') and (SearchRec.Name <> '..') then
begin
if (SearchRec.Attr and faDirectory) > 0 then
ListStr := ListStr + 'drwxr-xr-x 1 owner group 0 ' +
FormatDateTime('mmm dd hh:nn', FileDateToDateTime(SearchRec.Time)) + ' ' + SearchRec.Name + #13#10
else
ListStr := ListStr + '-rw-r--r-- 1 owner group ' +
IntToStr(SearchRec.Size) + ' ' +
FormatDateTime('mmm dd hh:nn', FileDateToDateTime(SearchRec.Time)) + ' ' + SearchRec.Name + #13#10;
end;
until FindNext(SearchRec) <> 0;
FindClose(SearchRec);
end;
DataSock.SendBuf(PAnsiChar(AnsiString(ListStr))^, Length(ListStr));
DataSock.Free;
SendResponse('226 Directory send OK.' + #13#10);
end;
procedure TWorkerThread.HandleRETR(const FileName: string);
var
DataSock: PSocket;
FS: TFileStream;
Buffer: array[0..4095] of Byte;
ReadBytes: Integer;
FullPath: string;
begin
FullPath := BuildFullPath(FileName);
if not FileExists(FullPath) then
begin
SendResponse('550 File not found.' + #13#10);
Exit;
end;
CreateDataChannel(DataSock);
if DataSock = nil then Exit;
SendResponse('150 Opening BINARY mode data connection for ' + FileName + ' (' +
IntToStr(GetFileSize(FullPath)) + ' bytes).' + #13#10);
FS := TFileStream.Create(FullPath, fmOpenRead or fmShareDenyNone);
try
repeat
ReadBytes := FS.Read(Buffer, SizeOf(Buffer));
if ReadBytes > 0 then
DataSock.SendBuf(Buffer, ReadBytes);
until ReadBytes = 0;
finally
FS.Free;
DataSock.Free;
end;
SendResponse('226 Transfer complete.' + #13#10);
end;
procedure TWorkerThread.HandleSTOR(const FileName: string);
var
DataSock: PSocket;
FS: TFileStream;
Buffer: array[0..4095] of Byte;
ReadBytes: Integer;
FullPath: string;
begin
FullPath := BuildFullPath(FileName);
CreateDataChannel(DataSock);
if DataSock = nil then Exit;
SendResponse('150 Opening BINARY mode data connection for ' + FileName + '.' + #13#10);
FS := TFileStream.Create(FullPath, fmCreate);
try
repeat
ReadBytes := DataSock.RecvBuf(Buffer, SizeOf(Buffer));
if ReadBytes > 0 then
FS.WriteBuffer(Buffer, ReadBytes);
until ReadBytes = 0;
finally
FS.Free;
DataSock.Free;
end;
SendResponse('226 Transfer complete.' + #13#10);
end;
procedure TWorkerThread.HandleDELE(const FileName: string);
var
FullPath: string;
begin
FullPath := BuildFullPath(FileName);
if not FileExists(FullPath) then
begin
SendResponse('550 File does not exist.' + #13#10);
Exit;
end;
if DeleteFile(FullPath) then
SendResponse('250 Delete operation successful.' + #13#10)
else
SendResponse('550 Delete operation failed.' + #13#10);
end;
procedure TWorkerThread.HandleMKD(const DirName: string);
var
FullPath: string;
begin
FullPath := BuildFullPath(DirName);
if CreateDir(FullPath) then
SendResponse('257 "' + FullPath + '" directory created.' + #13#10)
else
SendResponse('550 Create directory operation failed.' + #13#10);
end;
procedure TWorkerThread.HandleRMD(const DirName: string);
var
FullPath: string;
begin
FullPath := BuildFullPath(DirName);
if RemoveDir(FullPath) then
SendResponse('250 Remove directory operation successful.' + #13#10)
else
SendResponse('550 Remove directory operation failed.' + #13#10);
end;
procedure TWorkerThread.HandleRNFR(const FileName: string);
var
FullPath: string;
begin
FullPath := BuildFullPath(FileName);
if FileExists(FullPath) or DirectoryExists(FullPath) then
begin
// В реальном сервере имя нужно сохранить в поле FState.RenameFrom
SendResponse('350 Ready for RNTO.' + #13#10);
end
else
SendResponse('550 File not found.' + #13#10);
end;
procedure TWorkerThread.HandleRNTO(const FileName: string);
begin
// Здесь должна быть логика переименования из сохраненного в RNFR пути
// Для примера просто отвечаем 250
SendResponse('250 Rename successful.' + #13#10);
end;
procedure TWorkerThread.HandleSIZE(const FileName: string);
var
FullPath: string;
begin
FullPath := BuildFullPath(FileName);
if FileExists(FullPath) then
SendResponse('213 ' + IntToStr(GetFileSize(FullPath)) + #13#10)
else
SendResponse('550 File not found.' + #13#10);
end;
procedure TWorkerThread.ProcessCommand(const CmdLine: string);
var
Cmd, Param: string;
SpacePos: Integer;
begin
SyncLog('Recv: ' + CmdLine);
SpacePos := Pos(' ', CmdLine);
if SpacePos > 0 then
begin
Cmd := UpperCase(Copy(CmdLine, 1, SpacePos - 1));
Param := Copy(CmdLine, SpacePos + 1, Length(CmdLine));
end
else
begin
Cmd := UpperCase(CmdLine);
Param := '';
end;
if not FState.Authenticated then
begin
if Cmd = 'USER' then
begin
FState.User := Param;
SendResponse('331 Password required for ' + FState.User + '.' + #13#10);
end
else if Cmd = 'PASS' then
begin
FState.Authenticated := True;
SendResponse('230 User ' + FState.User + ' logged in.' + #13#10);
end
else
SendResponse('530 Not logged in.' + #13#10);
Exit;
end;
if Cmd = 'SYST' then SendResponse('215 UNIX Type: L8' + #13#10)
else if Cmd = 'FEAT' then
SendResponse('211-Features:' + #13#10 + ' PASV' + #13#10 + ' SIZE' + #13#10 + '211 End' + #13#10)
else if Cmd = 'PWD' then SendResponse('257 "' + FState.CurrentDir + '" is the current directory.' + #13#10)
else if Cmd = 'TYPE' then
begin
FState.TransferType := Param[1];
SendResponse('200 Type set to ' + FState.TransferType + '.' + #13#10);
end
else if Cmd = 'CWD' then
begin
FState.CurrentDir := NormalizeFTPPath(FState.CurrentDir, Param);
SendResponse('250 Directory successfully changed.' + #13#10);
end
else if Cmd = 'CDUP' then
begin
FState.CurrentDir := NormalizeFTPPath(FState.CurrentDir, '..');
SendResponse('250 Directory successfully changed.' + #13#10);
end
else if Cmd = 'PORT' then HandlePORT(Param)
else if Cmd = 'PASV' then
begin
var P: Word; var I: string;
HandlePASV(P, I);
SendResponse('227 Entering Passive Mode (' +
StringReplace(I, '.', ',', [rfReplaceAll]) + ',' +
IntToStr(P div 256) + ',' + IntToStr(P mod 256) + ').' + #13#10);
end
else if Cmd = 'LIST' then HandleLIST
else if Cmd = 'RETR' then HandleRETR(Param)
else if Cmd = 'STOR' then HandleSTOR(Param)
else if Cmd = 'DELE' then HandleDELE(Param)
else if Cmd = 'MKD' then HandleMKD(Param)
else if Cmd = 'RMD' then HandleRMD(Param)
else if Cmd = 'RNFR' then HandleRNFR(Param)
else if Cmd = 'RNTO' then HandleRNTO(Param)
else if Cmd = 'SIZE' then HandleSIZE(Param)
else if Cmd = 'QUIT' then
begin
SendResponse('221 Goodbye.' + #13#10);
FCtrlSock.CloseSocket;
Terminate;
end
else
SendResponse('502 Command not implemented.' + #13#10);
end;
procedure TWorkerThread.Execute;
var
Buffer: array[0..1023] of Char;
Received: Integer;
begin
SyncLog('Client ' + FCtrlSock.PeerIP + ' connected.');
SendResponse('220-Full-Featured KOL FTP Server' + #13#10);
SendResponse('220 Ready.' + #13#10);
while not Terminated and FCtrlSock.Connected do
begin
Received := FCtrlSock.RecvBuf(Buffer, SizeOf(Buffer) - 1);
if Received <= 0 then Break;
Buffer[Received] := #0;
ProcessCommand(string(Buffer));
end;
// Очистка ресурсов при дисконнекте
if FState.PASVSocket <> nil then FreeAndNil(FState.PASVSocket);
SyncLog('Client ' + FCtrlSock.PeerIP + ' disconnected.');
FCtrlSock.Free;
end;
begin
Application.Initialize;
Form := NewForm(Applet, 'Full-Featured KOL FTP Server');
Form.SetSize(600, 500);
LogMemo := NewMemo(Form, [moReadOnly, moWantTab]);
LogMemo.Align(caClient);
Listener := NewSocket;
Addr.sin_family := AF_INET;
Addr.sin_port := htons(2121);
Addr.sin_addr.S_addr := INADDR_ANY;
if Listener.Bind(Addr) = SOCKET_ERROR then
begin
LogMemo.Add('Error binding to port 2121.');
Exit;
end;
if Listener.Listen(10) = SOCKET_ERROR then
begin
LogMemo.Add('Error listening.');
Exit;
end;
LogMemo.Add('Full-Featured FTP Server started on port 2121.');
while True do
begin
var ClientSock := Listener.Accept;
if ClientSock <> nil then
TWorkerThread.Create(ClientSock, LogMemo);
Application.ProcessMessages;
end;
end.
Вот чё мне отвечал:
Да, многопоточность добавить можно. В библиотеке KOL для этого используется объект PThread.
Главное правило при работе с потоками в KOL (и в VCL/LCL): поток не может напрямую обращаться к визуальным компонентам (в нашем случае — к LogMemo). Если передать данные из потока в интерфейс напрямую, программа упадет с ошибкой Access Violation. Для передачи данных используется механизм синхронизации — Synchronize.
Ниже представлена переработанная версия сервера. Теперь основной цикл просто принимает соединения и передает каждый новый сокет в отдельный поток.
Да, можно создать более функциональную версию. В этом примере реализован базовый, но рабочий набор команд FTP: авторизация, навигация по папкам (PWD, CWD), получение листинга (LIST), установка типа передачи (TYPE) и скачивание файлов (RETR).
Для работы с файловой системой здесь используются стандартные модули Delphi (SysUtils, Classes), так как KOL является лишь тонкой оберткой над Windows API и не заменяет RTL (Run-Time Library) для работы с файлами.
Важные архитектурные изменения:
Состояние сессии: введена запись TFTPSessionState, которая хранит имя пользователя, флаг авторизации, текущую директорию и тип передачи для каждого потока.
Пассивный режим (PASV): сервер открывает случайный порт из диапазона 50000–50100 и сообщает его клиенту. Это позволяет обходить NAT и роутеры.
Обработка листинга: команда LIST формирует текстовый список файлов в формате drwxr-xr-x (для совместимости с FileZilla и Total Commander).
Обработка путей: добавлена функция NormalizeFTPPath для корректной обработки .. и /.
