Ver Mensaje Individual
  #10  
Antiguo 07-10-2005
Avatar de Spynosa
Spynosa Spynosa is offline
Miembro
 
Registrado: nov 2004
Ubicación: Ecija - Sevilla
Posts: 99
Reputación: 20
Spynosa Va por buen camino
Aqui tienes un servidor usando IdFTPServer de la indy a mi me funciona perfectamente
Código Delphi [-]
 unit Fftp;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
   IdBaseComponent, IdComponent, IdTCPServer, IdFTPServer,
   IdFTPList,
   IdSocketHandle,
   idglobal,
   IdHashCRC;
 
 type
   TFTP = class(TForm)
     IdFTPServer1: TIdFTPServer;
     procedure IdFTPServer1ChangeDirectory(ASender: TIdFTPServerThread;
       var VDirectory: String);
     procedure IdFTPServer1GetFileSize(ASender: TIdFTPServerThread;
       const AFilename: String; var VFileSize: Int64);
     procedure IdFTPServer1ListDirectory(ASender: TIdFTPServerThread;
       const APath: String; ADirectoryListing: TIdFTPListItems);
     procedure IdFTPServer1UserLogin(ASender: TIdFTPServerThread;
       const AUsername, APassword: String; var AAuthenticated: Boolean);
     procedure IdFTPServer1RenameFile(ASender: TIdFTPServerThread;
       const ARenameFromFile, ARenameToFile: String);
     procedure FormActivate(Sender: TObject);
     procedure IdFTPServer1CommandXCRCCommand(ASender: TIdCommand);
     procedure IdFTPServer1DeleteFile(ASender: TIdFTPServerThread;
       const APathName: String);
     procedure IdFTPServer1RetrieveFile(ASender: TIdFTPServerThread;
       const AFileName: String; var VStream: TStream);
     procedure IdFTPServer1StoreFile(ASender: TIdFTPServerThread;
       const AFileName: String; AAppend: Boolean; var VStream: TStream);
     procedure IdFTPServer1MakeDirectory(ASender: TIdFTPServerThread;
       var VDirectory: String);
     procedure IdFTPServer1RemoveDirectory(ASender: TIdFTPServerThread;
       var VDirectory: String);
   private
     { Private declarations }
     function TransLatePath( const APathname, homeDir: string ) : string;
   public
     { Public declarations }
   end;
 
 var
   FTP: TFTP;
 
 implementation
 
 {$R *.DFM}
 
 function CalculateCRC( const path: string ) : string;
 var
   f: tfilestream;
   value: dword;
   IdHashCRC32: TIdHashCRC32;
 begin
   IdHashCRC32 := nil;
   f := nil;
   try
     IdHashCRC32 := TIdHashCRC32.create;
     f := TFileStream.create( path, fmOpenRead or fmShareDenyWrite ) ;
     value := IdHashCRC32.HashValue( f ) ;
     result := inttohex( value, 8 ) ;
   finally
     f.free;
     IdHashCRC32.free;
   end;
 end;
 
 function GetSizeOfFile( const APathname: string ) : int64;
 begin
   result := FileSizeByName( APathname ) ;
 end;
 
 
 
 function GetNewDirectory( old, action: string ) : string;
 var
   a: integer;
 begin
   if action = '../' then
   begin
     if old = '/' then
     begin
       result := old;
       exit;
     end;
     a := length( old ) - 1;
     while ( old[a] <> '\' ) and ( old[a] <> '/' ) do
       dec( a ) ;
     result := copy( old, 1, a ) ;
     exit;
   end;
   if ( action[1] = '/' ) or ( action[1] = '\' ) then
     result := action
   else
     result := old + action;
 end;
 function SlashToBackSlash( const str: string ) : string;
 var
   a: dword;
 begin
   result := str;
   for a := 1 to length( result ) do
     if result[a] = '/' then
       result[a] := '\';
 end;
 
 
 function TFTP.TransLatePath( const APathname, homeDir: string ) : string;
 var
   tmppath: string;
 begin
   result := SlashToBackSlash( homeDir ) ;
   tmppath := SlashToBackSlash( APathname ) ;
   if homedir = '/' then
   begin
     result := tmppath;
     exit;
   end;
 
   if length( APathname ) = 0 then
     exit;
   if result[length( result ) ] = '\' then
     result := copy( result, 1, length( result ) - 1 ) ;
   if tmppath[1] <> '\' then
     result := result + '\';
   result := result + tmppath;
 end;
 
 
 
 procedure TFTP.IdFTPServer1ChangeDirectory(ASender: TIdFTPServerThread;
   var VDirectory: String);
 begin
 VDirectory := GetNewDirectory( ASender.CurrentDir, VDirectory ) ;
 end;
 
 procedure TFTP.IdFTPServer1GetFileSize(ASender: TIdFTPServerThread;
   const AFilename: String; var VFileSize: Int64);
 begin
 VFileSize := GetSizeOfFile( TransLatePath( AFilename, ASender.HomeDir ) ) ;
 end;
 
 procedure TFTP.IdFTPServer1ListDirectory(ASender: TIdFTPServerThread;
   const APath: String; ADirectoryListing: TIdFTPListItems);
 procedure AddlistItem( aDirectoryListing: TIdFTPListItems; Filename: string; ItemType: TIdDirItemType; size: int64; date: tdatetime ) ;
   var
     listitem: TIdFTPListItem;
   begin
     listitem := aDirectoryListing.Add;
     listitem.ItemType := ItemType;
     listitem.FileName := Filename;
     listitem.OwnerName := 'anonymous';
     listitem.GroupName := 'all';
     listitem.OwnerPermissions := '---';
     listitem.GroupPermissions := '---';
     listitem.UserPermissions := '---';
     listitem.Size := size;
     listitem.ModifiedDate := date;
   end;
 
 var
   f: tsearchrec;
   a: integer;
 begin
   ADirectoryListing.DirectoryName := apath;
 
   a := FindFirst( TransLatePath( apath, ASender.HomeDir ) + '*.*', faAnyFile, f ) ;
   while ( a = 0 ) do
   begin
     if ( f.Attr and faDirectory > 0 ) then
       AddlistItem( ADirectoryListing, f.Name, ditDirectory, f.size, FileDateToDateTime( f.Time ) )
     else
       AddlistItem( ADirectoryListing, f.Name, ditFile, f.size, FileDateToDateTime( f.Time ) ) ;
     a := FindNext( f ) ;
   end;
 
   FindClose( f ) ;
 end;
 
 
 procedure TFTP.IdFTPServer1UserLogin(ASender: TIdFTPServerThread;
   const AUsername, APassword: String; var AAuthenticated: Boolean);
 begin
 AAuthenticated := ( AUsername = 'imagina' ) and ( APassword = 'sport' ) ;
   if not AAuthenticated then
     exit;
   ASender.HomeDir := '/';
   asender.currentdir := '/';
 end;
 
 procedure TFTP.IdFTPServer1RenameFile(ASender: TIdFTPServerThread;
   const ARenameFromFile, ARenameToFile: String);
 begin
 if not MoveFile( pchar( TransLatePath( ARenameFromFile, ASender.HomeDir ) ) , pchar( TransLatePath( ARenameToFile, ASender.HomeDir ) ) ) then
     RaiseLastWin32Error;
 end;
 
 procedure TFTP.FormActivate(Sender: TObject);
 begin
  with IdFTPServer1.CommandHandlers.add do
   begin
     Command := 'XCRC';
     OnCommand := IdFTPServer1CommandXCRCCommand;
   end;
   IdFTPServer1.Active := true;
 end;
 
 
 
 
 procedure TFTP.IdFTPServer1CommandXCRCCommand(ASender: TIdCommand);
 // note, this is made up, and not defined in any rfc.
 var
   s: string;
 begin
   with TIdFTPServerThread( ASender.Thread ) do
   begin
     if Authenticated then
     begin
       try
         s := ProcessPath( CurrentDir, ASender.UnparsedParams ) ;
         s := TransLatePath( s, TIdFTPServerThread( ASender.Thread ) .HomeDir ) ;
         ASender.Reply.SetReply( 213, CalculateCRC( s ) ) ;
       except
         ASender.Reply.SetReply( 500, 'file error' ) ;
       end;
     end;
   end;
 end;
 
 procedure TFTP.IdFTPServer1DeleteFile(ASender: TIdFTPServerThread;
   const APathName: String);
 begin
 DeleteFile( pchar( TransLatePath( ASender.CurrentDir + '/' + APathname, ASender.HomeDir ) ) ) ;
 end;
 
 procedure TFTP.IdFTPServer1RetrieveFile(ASender: TIdFTPServerThread;
   const AFileName: String; var VStream: TStream);
 begin
 VStream := TFileStream.create( translatepath( AFilename, ASender.HomeDir ) , fmopenread or fmShareDenyWrite ) ;
 end;
 
 procedure TFTP.IdFTPServer1StoreFile(ASender: TIdFTPServerThread;
   const AFileName: String; AAppend: Boolean; var VStream: TStream);
 begin
 if FileExists( translatepath( AFilename, ASender.HomeDir ) ) and AAppend then
   begin
     VStream := TFileStream.create( translatepath( AFilename, ASender.HomeDir ) , fmOpenWrite or fmShareExclusive ) ;
     VStream.Seek( 0, soFromEnd ) ;
   end
   else
     VStream := TFileStream.create( translatepath( AFilename, ASender.HomeDir ) , fmCreate or fmShareExclusive ) ;
 end;
 
 procedure TFTP.IdFTPServer1MakeDirectory(ASender: TIdFTPServerThread;
   var VDirectory: String);
 begin
 MkDir( TransLatePath( VDirectory, ASender.HomeDir ) ) ;
 end;
 
 procedure TFTP.IdFTPServer1RemoveDirectory(ASender: TIdFTPServerThread;
   var VDirectory: String);
 begin
 RmDir( TransLatePath( VDirectory, ASender.HomeDir ) ) ;
 end;
 
 end.

un saludo
Responder Con Cita