Prosty serwerek FTP (INDY)

Cześć tu Agent_Ziemba. Jest to mój pierwszy artykuł, proszę o wyrozumiałość. Starałem się poprawić wszystkie błędy jakie
znalazłem. W tym gotowcu napiszemy sobie jak postawić prosty serwerek FTP. Możemy to zrobić na 2 sposoby:

1. Zainstalować sobie jakiś gotowy serwerek :P (ale to nie dla nas)
2. Napisać sobie serwerek (chyba trochę większa frajda)
   Zaczynamy

Robiłem to w Delphi7 z zainstalowanym INDY 10. Uruchamiamy sobie Delphi i wrzucamy IdFTPServer. Teraz zabieramy się za edycję
kodu.

Deklarujemy globalną zmienną Folder

var 
  Folder  :  String;

Jest to zmienna typu String. Do tej zmiennej będzie przypisana ścieżka której użyjemy jako główny folder FTP (root dir).
Następnie piszemy sobie funkcję która zamienia znaki ze stylu UNIX na styl WINDOWS. Czyli '/' na '' i '\' na '' .

function TForm1.ZamienZnaki(APath:String) :String;
var  s:String;
begin
  s:=StringReplace(APath, '/', '\', [rfReplaceAll]);
  s:=StringReplace(s, '\\', '\', [rfReplaceAll]);
  Result:=s;
end;

Teraz piszemy sobie funkcję podającą rozmiar plików:

function TForm1.Rozmiarpliku(AFile : String) : Integer;
var FStream : TFileStream;
begin
try
  FStream:=TFileStream.Create(AFile, fmOpenRead);
  try 
   Result:=Fstream.Size;
  finally
  FreeAndNil(FStream);
  end;
 except
  Result:=0;
 end;
 end;

Powyzsza funkcja otwiera strumien pliku, sprawdza jego rozmiar i przypisuje do zmiennej Result.

Każdy serwer FTP musi wyświetlić listę plików do pobrania napiszmy więc obsługę eventu <B> OnListDirectory </B>

var
 LFTPItem :TIdFTPListItem;
 SR : TSearchRec;
 SRI : Integer;
begin
  ADirectoryListing.DirFormat := doUnix;
  SRI := FindFirst(Folder + APath + '\*.*', faAnyFile - faHidden - faSysFile, SR);
  While SRI = 0 do
  begin
    LFTPItem := ADirectoryListing.Add;
    LFTPItem.FileName := SR.Name;
    LFTPItem.Size := SR.Size;
    LFTPItem.ModifiedDate := FileDateToDateTime(SR.Time);
    if SR.Attr = faDirectory then
     LFTPItem.ItemType   := ditDirectory
    else
     LFTPItem.ItemType   := ditFile;
    SRI := FindNext(SR);
  end;
  FindClose(SR);
  SetCurrentDir(Folder + APath + '\..');
end;

Teraz przydałoby się zareagować jeżeli jakiś user będzie chciał uploadować plik, napiszmy więc obsługę eventu <B> OnStoreFile</B> :

begin
 if not Aappend then
   VStream := TFileStream.Create(ZamienZnaki(Folder+AFilename),fmCreate)
 else
   VStream := TFileStream.Create(ZamienZnaki(Folder+AFilename),fmOpenWrite)
end;

Teraz uzupełnimy event <B> OnRetrieveFile </B>, który będzie odpowiedzialny za downloadowanie plików:

begin
  VStream := TFileStream.Create(ZamienZnaki(Folder+AFilename),fmOpenRead);
end;

Z kolei w evencie <B> OnMakeDirectory </B> umieścimy następujący kod:

begin
  if not ForceDirectories(ZamienZnaki(Folder + VDirectory)) then
  begin
    Raise Exception.Create('Nie mozna utworzyc katalogu');
  end;
end;

Jeżeli user będzie chciał zmienić katalog roboczy to zadziała event <B> OnChangeDirectory </B>, który to uzupełniamy o poniższy kod:

begin
  ASender.CurrentDir := VDirectory;
end;

Poniższy kod będzie pobierał rozmiar pliku w systemie plików serwera. Wrzucamy go do eventu <B> OnGetFileSize </B>

Var
 LFile : String;
begin 
 LFile := ZamienZnaki( Folder + AFilename );
 try
 If FileExists(LFile) then
   VFileSize :=  RozmiarPliku(LFile)
 else
   VFileSize := 0;
 except
   VFileSize := 0;
 end;
end;

Teraz uzupełnimy event <B> OnDeleteFile </B> odpowiedzialny za kasowanie plików z serwera.

begin
  DeleteFile(ZamienZnaki(Folder+ASender.CurrentDir+'\'+APathname));
end;

Na koniec tego gotowca zostawiłem logowanie. Kod Logowania należy wrzucić do eventu <B> OnUserLogin</B> .

begin
  if (AUsername='maniek') and (APassword='pankoski') then begin
   AAuthenticated := True;
 end
 else begin
  AAuthenticated := False;
 end;
end;

Trochę wyjaśnienia. Jeżeli użytkownik poda nazwę użytkownika maniek i hasło pankoski to uzyska dostęp do serwera,
jeżeli poda coś innego to jego logowanie zostanie odrzucone. To był tylko przykład, jeżeli chcecie mieć bardzo niewielu
userów to możecie wrzucić nazwy userów do kodu, ale nie polecam tego z kilku powodów:

1. Trudność ze zmianą hasła usera (powtórna kompilacja)
2. Trudność z dodaniem usera (powtórna kompilacja)
3. Trudność z usunięciem usera (powtórna kompilacja)
   Radze zrobić jakiś plik z hasłami i podczas logowania sprawdzać login i hasło.
   Jeszcze tylko musimy uruchamiać i zamykać nasz serwerek. Wrzucamy na formę edita i dwa buttony. W edicie będzie podawana
   ścieżka do katalogu wirtualnego. Button1 będzie uruchamiał serwer:

begin
  Folder:=Edit1.Text;
  IdFTPServer1.Active:=True;
end;

Button2 będzie zamykał serwer

begin
  IdFTPServer1.Active:=False;
end;

A oto cały listing unita:

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  IdBaseComponent, IdComponent, IdTCPServer, IdCmdTCPServer, IdFTPList,
  IdExplicitTLSClientServerBase, IdFTPServer, StdCtrls, IdFTPListOutput,
  IdCustomTCPServer;

type
  TForm1 = class(TForm)
    IdFTPServer1: TIdFTPServer;
    Edit1: TEdit;
    Button1: TButton;
    Button2: TButton;
    Label1: TLabel;
    procedure IdFTPServer1UserLogin(ASender: TIdFTPServerContext;
      const AUsername, APassword: string; var AAuthenticated: Boolean);
    procedure IdFTPServer1MakeDirectory(ASender: TIdFTPServerContext;
      var VDirectory: string);
    procedure IdFTPServer1RetrieveFile(ASender: TIdFTPServerContext;
      const AFileName: string; var VStream: TStream);
    procedure IdFTPServer1GetFileSize(ASender: TIdFTPServerContext;
      const AFilename: string; var VFileSize: Int64);
    procedure IdFTPServer1StoreFile(ASender: TIdFTPServerContext;
      const AFileName: string; AAppend: Boolean; var VStream: TStream);
    procedure IdFTPServer1ListDirectory(ASender: TIdFTPServerContext;
      const APath: string; ADirectoryListing: TIdFTPListOutput; const ACmd,
      ASwitches: string);
    procedure IdFTPServer1DeleteFile(ASender: TIdFTPServerContext;
      const APathName: string);
    procedure IdFTPServer1ChangeDirectory(ASender: TIdFTPServerContext;
      var VDirectory: string);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    function ZamienZnaki(APath: String): String;
    function RozmiarPliku(AFile : String) : Integer;
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;
  Folder      : String;

implementation
{$R *.DFM}

function TForm1.ZamienZnaki(APath:String):String;
var
 s:string;
begin
  s := StringReplace(APath, '/', '\', [rfReplaceAll]);
  s := StringReplace(s, '\\', '\', [rfReplaceAll]);
  Result := s;
end;

function TForm1.RozmiarPliku(AFile : String) : Integer;
var
 FStream : TFileStream;
begin
Try
 FStream := TFileStream.Create(AFile, fmOpenRead);
 Try
  Result := FStream.Size;
 Finally
  FreeAndNil(FStream);
 End;
Except
 Result := 0;
End;
end;

procedure TForm1.IdFTPServer1ChangeDirectory(
  ASender: TIdFTPServerContext; var VDirectory: string);
begin
  ASender.CurrentDir := VDirectory;
end;

procedure TForm1.IdFTPServer1DeleteFile(ASender: TIdFTPServerContext;
  const APathName: string);
begin
  DeleteFile(ZamienZnaki(Folder+ASender.CurrentDir+'\'+APathname));
end;

procedure TForm1.IdFTPServer1ListDirectory(ASender: TIdFTPServerContext;
  const APath: string; ADirectoryListing: TIdFTPListOutput; const ACmd,
  ASwitches: string);
var
 LFTPItem :TIdFTPListItem;
 SR : TSearchRec;
 SRI : Integer;
begin
  ADirectoryListing.DirFormat := doUnix;
  SRI := FindFirst(Folder + APath + '\*.*', faAnyFile - faHidden - faSysFile, SR);
  While SRI = 0 do
  begin
    LFTPItem := ADirectoryListing.Add;
    LFTPItem.FileName := SR.Name;
    LFTPItem.Size := SR.Size;
    LFTPItem.ModifiedDate := FileDateToDateTime(SR.Time);
    if SR.Attr = faDirectory then
     LFTPItem.ItemType   := ditDirectory
    else
     LFTPItem.ItemType   := ditFile;
    SRI := FindNext(SR);
  end;
  FindClose(SR);
  SetCurrentDir(Folder + APath + '\..');
end;

procedure TForm1.IdFTPServer1StoreFile(ASender: TIdFTPServerContext;
  const AFileName: string; AAppend: Boolean; var VStream: TStream);
begin
 if not Aappend then
   VStream := TFileStream.Create(ZamienZnaki(Folder+AFilename),fmCreate)
 else
   VStream := TFileStream.Create(ZamienZnaki(Folder+AFilename),fmOpenWrite)
end;

procedure TForm1.IdFTPServer1GetFileSize(ASender: TIdFTPServerContext;
  const AFilename: string; var VFileSize: Int64);
Var
 LFile : String;
begin
 LFile := ZamienZnaki( Folder + AFilename );
 try
 If FileExists(LFile) then
   VFileSize :=  RozmiarPliku(LFile)
 else
   VFileSize := 0;
 except
   VFileSize := 0;
 end;
end;

procedure TForm1.IdFTPServer1RetrieveFile(ASender: TIdFTPServerContext;
  const AFileName: string; var VStream: TStream);
begin
  VStream := TFileStream.Create(ZamienZnaki(Folder+AFilename),fmOpenRead);
end;

procedure TForm1.IdFTPServer1MakeDirectory(ASender: TIdFTPServerContext;
  var VDirectory: string);
begin
  if not ForceDirectories(ZamienZnaki(Folder + VDirectory)) then
  begin
    Raise Exception.Create('Nie mozna utworzyc katalogu');
  end;
end;

procedure TForm1.IdFTPServer1UserLogin(ASender: TIdFTPServerContext;
  const AUsername, APassword: string; var AAuthenticated: Boolean);
begin
  if (AUsername='maniek') and (APassword='pankoski') then begin
   AAuthenticated := True;
 end
 else begin
  AAuthenticated := False;
 end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
Folder:=Edit1.Text;
idFTPServer1.Active:=True;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
IdFtpServer1.Active:=False;
end;

end.

No to koniec gotowca. Mam nadzieje że to się komuś przyda. Pozdro