idfsp.pas

photo.163.com 相册下载器 多线程下载

{ $HDR$}
{**********************************************************************}
{ Unit archived using Team Coherence                                   }
{ Team Coherence is Copyright 2002 by Quality Software Components      }
{                                                                      }
{ For further information / comments, visit our WEB site at            }
{ http://www.TeamCoherence.com                                         }
{**********************************************************************}
{}
{ $Log:  111212: IdFSP.pas 
{
{   Rev 1.11    11/11/2004 11:22:54 PM  JPMugaas
{ Removed an $IFDEF that's no longer needed.
}
{
{   Rev 1.10    11/8/2004 8:36:04 PM  JPMugaas
{ Added value for command that may appear later.
}
{
{   Rev 1.9    11/7/2004 11:34:16 PM  JPMugaas
{ Now uses inherited methods again.  The inherited methods now use the Binding
{ methods we used here.
}
{
{   Rev 1.8    11/6/2004 1:46:34 AM  JPMugaas
{ Minor bug fix for when there is no data in a reply to CC_GET_PRO.
}
{
{   Rev 1.7    11/5/2004 7:55:02 PM  JPMugaas
{ Changed to use, Connect, Recv, Send, and Disconnect instead of ReceiveFrom
{ and SendTo.  This should improve performance as we do make repeated contacts
{ to the host and UDP connect will cause the stack to filter out packets that
{ aren't from the peer.  There should only be one DNS resolution per session
{ making this more efficient (cutting down to about 87 seconds to get a dir).
}
{
{   Rev 1.4    10/31/2004 1:49:58 AM  JPMugaas
{ Now uses item type from TIdFTPList for dirs and files.  We don't use Skip
{ items or end of dir marker items.
}
{
{   Rev 1.2    10/30/2004 10:23:58 PM  JPMugaas
{ Should be much faster.
}
{
{   Rev 1.1    10/30/2004 7:04:26 PM  JPMugaas
{ FSP Upload.
}
{
{   Rev 1.0    10/29/2004 12:34:20 PM  JPMugaas
{ File Services Protocol implementation started
}
unit IdFSP;

interface
uses Classes, IdException, IdFTPList,  IdGlobal, IdStreamVCL, IdTStrings, IdUDPClient;

{This is based on:

http://cvs.sourceforge.net/viewcvs.py/fsp/fsp/doc/PROTOCOL?rev=1.4&view=markup

and the Java Lib at fsp.sourceforge.net was also referenced.

I have verified this on a CygWin build of the FSP Server at fsp.sourceforge.net.
}
{


FSP Packet format:
  HEADER - size = Fixed size 12 bytes. Always present.
  DATA         - size = defined in header (DATA_LENGTH)
  XTRA DATA- size = packet_size - header_size (12) - DATA_LENGTH

Maximal data size DATA_LENGTH + XTRA_DATA length is 1024. Clients and servers
are not required to support XTRA DATA (but in current FSP implementation does).
If XTRA DATA are provided, there must be also contained in MESSAGE_CHECKSUM.

HEADER FORMAT (12 bytes)
 byte FSP_COMMAND
 byte MESSAGE_CHECKSUM
 word KEY
 word SEQUENCE
 word DATA_LENGTH
 long FILE_POSITION

MESSAGE_CHECKSUM
Entire packet (HEADER + DATA + XTRA DATA) is checksumed.  When computing a
checksum use zero in place of MESSAGE_CHECKSUM header field. 

Due to some unknown reason, method of computing checksums is different in each
direction. For packets travelling from server to client initial checksum
value is zero, otherwise it is HEADER + DATA + XTRA DATA size.

Checksums in server->client direction are computed as follows:

 /* assume that we have already zeroed checksum in packet */
 unsigned int sum,checksum;
 for(t = packet_start, sum = 0; t < packet_end; sum += *t++);
 checksum= sum + (sum >> 8);

KEY
Client's message to server contain a KEY value that is the same as the KEY
value of the previous message received from the server. KEY is choosen random
by server.
}

{



 CC_VERSION     0x10- Get server version string and setup

                request
                file position: ignored
                data:          not used
xtra data:     not used

reply
file position:  size of optional extra version data
data:           ASCIIZ Server version string
xtra data:      optional extra version data
byte - FLAGS
        bit 0 set - server does logging
bit 1 set - server is read only
bit 2 set - reverse lookup required
bit 3 set - server is in private mode
bit 4 set - thruput control
        if bit 4 is set thruput info follows
long - max_thruput allowed (in bytes/sec)
word - max. packet size supported by server
}

const
  IdPORT_FSP = 21;

  HSIZE=12;
  MAXSPACE=1024;
  MAXSIZE=MAXSPACE+HSIZE;

{
  HEADER - size = Fixed size 12 bytes. Always present.
  DATA         - size = defined in header (DATA_LENGTH)
  XTRA DATA- size = packet_size - header_size (12) - DATA_LENGTH
}

//commands
  CC_VERSION     = $10;  //Get server version string and setup
  CC_INFO        = $11;  //return server's extended info block
  CC_ERR         = $40;  //error response from server
  CC_GET_DIR     = $41; // get a directory listing
  CC_GET_FILE    = $42; // get a file
  CC_UP_LOAD     = $43; // open a file for writing
  CC_INSTALL     = $44; // close and install file opened for writing
  CC_DEL_FILE    = $45; // delete a file
  CC_DEL_DIR     = $46; // delete a directory
  CC_GET_PRO     = $47; // get directory protection
  CC_SET_PRO     = $48; // set directory protection
  CC_MAKE_DIR    = $49; // create a directory
  CC_BYE         = $4A; // finish a session
  CC_GRAB_FILE   = $4B; // atomic get+delete a file
  CC_GRAB_DONE   = $4C; // atomic get+delete a file done
  CC_STAT        = $4D; // get information about file/directory
  CC_RENAME      = $4E; // rename file or directory
  CC_CH_PASSW    = $4F; // change password
//Reserved commands:
 CC_LIMIT        = $80;
 { commands > 0x7F will have extended
     header. No such extensions or commands
    which uses that are known today. This
    header will be used in protocol version 3.   }

  CC_TEST         = $81; //reserved for testing of new header

  RDTYPE_END      = $00;
  RDTYPE_FILE     = $01;
  RDTYPE_DIR      = $02;
  RDTYPE_SKIP     = $2A;   //42

  MINTIMEOUT =   1340;   //1.34 seconds
  MAXTIMEOUT = 300000; //300 seconds
type
  EIdFSPException = class(EIdException);
  EIdFSPFileAlreadyExists = class(EIdFSPException);
  EIdFSPFileNotFound = class(EIdFSPException);
  EIdFSPProtException = class(EIdFSPException);
{
RDIRENT.HEADER types:
  RDTYPE_END      0x00
  RDTYPE_FILE     0x01
  RDTYPE_DIR      0x02
  RDTYPE_SKIP     0x2A
}
  TIdFSPStatInfo = class(TCollectionItem)
  protected
      FModifiedDateGMT : TDateTime;
    FModifiedDate: TDateTime;
    //Size is Int64 in case FSP 3 has an expansion, otherise, it can only handle
    //file sizes up 4 GB's.  It's not a bug, it's a feature.
    FSize: Int64;
    FItemType :TIdDirItemType;
  published
    property ItemType :TIdDirItemType read FItemType write FItemType;
    property Size: Int64 read FSize write FSize;
    property ModifiedDate: TDateTime read FModifiedDate write FModifiedDate;
    property ModifiedDateGMT : TDateTime read FModifiedDateGMT write FModifiedDateGMT;
  end;
  TIdFSPListItem = class(TIdFSPStatInfo)
  protected
    FFileName: string;
  published
    property FileName: string read FFileName write FFileName;
  end;
  TIdFSPListItems = class(TCollection)
  protected
    function GetItems(AIndex: Integer): TIdFSPListItem;
    procedure SetItems(AIndex: Integer; const Value: TIdFSPListItem);
  public
    function Add: TIdFSPListItem;
    constructor Create; reintroduce;
    function ParseEntries(const AData : TIdBytes; const ADataLen : Cardinal) : Boolean;
    function IndexOf(AItem: TIdFSPListItem): Integer;
    property Items[AIndex: Integer]: TIdFSPListItem read GetItems write SetItems; default;

  end;
  TIdFSPDirInfo = class(TObject)
  protected
    FOwnsDir,
    FCanDeleteFiles,
    FCanAddFiles,
    FCanMakeDir,
    FOnlyOwnerCanReadFiles,
    FHasReadMe,
    FCanBeListed,
    FCanRenameFiles : Boolean;
    FReadMe : String;
  public
    property OwnsDir : Boolean read FOwnsDir write FOwnsDir;
    property CanDeleteFiles : Boolean read FCanDeleteFiles write FCanDeleteFiles;
    property CanAddFiles : Boolean read FCanAddFiles write FCanAddFiles;
    property CanMakeDir : Boolean read FCanMakeDir write FCanMakeDir;
    property OnlyOwnerCanReadFiles : Boolean read FOnlyOwnerCanReadFiles write FOnlyOwnerCanReadFiles;
    property HasReadMe : Boolean read FHasReadMe write FHasReadMe;
{


        Compatibility

Versions older than 2.8.1b6 do not uses bits 6 and 7. This
causes that directory can be listable even it do not have
6th bit set.
}
    property CanBeListed : Boolean read FCanBeListed write FCanBeListed;
    property CanRenameFiles : Boolean read FCanRenameFiles write FCanRenameFiles;
    property ReadMe : String read FReadMe write FReadMe;
  end;
  TIdFSPPacket = class(TObject)
  protected
    FCmd: Byte;
    FFilePosition: Cardinal;
    FData: TIdBytes;
    FDataLen : Cardinal;
    FExtraData: TIdBytes;
//    FExtraDataLen : Cardinal;
    FSequence: Word;
    FKey: Word;
    FValid : Boolean;
  public
    constructor Create;
    function WritePacket : TIdBytes;
    procedure ReadPacket(const AData : TIdBytes; const ALen : Cardinal);
    property Valid : Boolean read FValid;
    property Cmd : Byte read FCmd write FCmd;
    property Key : Word read FKey write FKey;
    property Sequence : Word read FSequence write FSequence;
    property FilePosition : Cardinal read FFilePosition write FFilePosition;
    property Data : TIdBytes read FData write FData;
    property DataLen : Cardinal read FDataLen write FDataLen;
    property ExtraData : TIdBytes read FExtraData write FExtraData;
  //  property WritePacket : TIdBytes read GetWritePacket write SetWritePacket;
  end;
  TIdFSPLogEvent = procedure (Sender : TObject; APacket : TIdFSPPacket) of object;
  TIdFSP = class(TIdUDPClient)
  protected
    FConEstablished : Boolean;
    FSequence : Word;
    FKey : Word;
    FSystemDesc: string;
    FSystemServerLogs : Boolean;
    FSystemReadOnly : Boolean;
    FSystemReverseLookupRequired : Boolean;
    FSystemPrivateMode : Boolean;
    FSystemAcceptsExtraData : Boolean;
    FThruputControl : Boolean;

    FMaxThruPut : Cardinal;  //bytes per sec
    FMaxPacketSize : Word; //maximum packet size
    FDirectoryListing: TIdFSPListItems;
    FDirInfo : TIdFSPDirInfo;
    FStatInfo : TIdFSPStatInfo;
    FOnRecv, FOnSend : TIdFSPLogEvent;
    //note:  This is optimized for performance - DO NOT MESS with it even if you don't like it
    //or think its wrong.  There is a performance penalty that is noticable with downloading,
    //uploading, and dirs because those use a series of packets - not one and we limited in
    //packet size.  We also do not want to eat CPU cycles excessively which I've noticed
    //with previous code.
    procedure SendCmd(ACmdPacket, ARecvPacket : TIdFSPPacket; var VTempBuf : TIdBytes; const ARaiseException : Boolean=True); overload;
    procedure SendCmd(const ACmd : Byte; const AData, AExtraData : TIdBYtes;
      const AFilePosition : Int64; //in case FSP 3.0 does support more than 4GB
      var VData, VExtraData : TIdBytes; const ARaiseException : Boolean=True);  overload;
    procedure SendCmd(const ACmd : Byte; const AData : TIdBYtes;
      const AFilePosition : Int64; //in case FSP 3.0 does support more than 4GB
      var VData, VExtraData : TIdBytes; const ARaiseException : Boolean=True); overload;
    procedure ParseDirInfo(const ABuf, AExtraBuf: TIdBytes; ADir : TIdFSPDirInfo);
    procedure InitComponent; override;
  public
    destructor Destroy; override;
    procedure Connect; override; //this is so we can use it similarly to FTP
    procedure Disconnect; override;
    procedure Version;
    procedure Delete(const AFilename: string);
    procedure RemoveDir(const ADirName: string);
    procedure Rename(const ASourceFile, ADestFile: string);
    procedure MakeDir(const ADirName: string);
    //this is so we can use it similarly to FTP
    //and also sends a BYE command which is the courteous thing to do.
    procedure List;  overload;
    procedure List(  
      const ASpecifier: string); overload;
    procedure GetDirInfo(const ADIR : String); overload;
    procedure GetDirInfo(const ADIR : String; ADirInfo : TIdFSPDirInfo); overload;
    procedure GetStatInfo(const APath : String);
    procedure Get(const ASourceFile, ADestFile: string; const ACanOverwrite: boolean = false;
      AResume: Boolean = false); overload;
    procedure Get(const ASourceFile: string; ADest: TStream; AResume: Boolean = false); overload;
    procedure Get(const ASourceFile: string; ADest: TIdStreamVCL; AResume: Boolean = false); overload;
    procedure Put(const ASource: TIdStreamVCL; const ADestFile: string;
       const AGMTTime : TDateTime=0); overload;
    procedure Put(const ASource: TStream; const ADestFile: string;
       const AGMTTime : TDateTime=0); overload;
    procedure Put(const ASourceFile: string; const ADestFile: string=''); overload;
    property SystemDesc: string read FSystemDesc;
    property SystemServerLogs : Boolean read  FSystemServerLogs;
    property SystemReadOnly : Boolean read FSystemReadOnly;
    property SystemReverseLookupRequired : Boolean read FSystemReverseLookupRequired;
    property SystemPrivateMode : Boolean read FSystemPrivateMode;
    property SystemAcceptsExtraData : Boolean read  FSystemAcceptsExtraData;
    property ThruputControl : Boolean read FThruputControl;
    property MaxThruPut : Cardinal read FMaxThruPut;
    property MaxPacketSize : Word read FMaxPacketSize;
    property DirectoryListing: TIdFSPListItems read FDirectoryListing;
    property DirInfo : TIdFSPDirInfo read FDirInfo;
    property StatInfo : TIdFSPStatInfo read FStatInfo;
  published
    property Port default IdPORT_FSP;
    property OnWork;
    property OnWorkBegin;
    property OnWorkEnd;
    property OnRecv : TIdFSPLogEvent read FOnRecv write FOnRecv;
    property OnSend : TIdFSPLogEvent read  FOnSend write FOnSend;
  end;

implementation
uses IdComponent, IdGlobalProtocols, IdResourceStringsProtocols, SysUtils
  IdStack;

//This is from: http://www.swissdelphicenter.ch/en/showcode.php?id=844
const
  // Sets UnixStartDate to TDateTime of 01/01/1970
  UnixStartDate: TDateTime = 25569.0;

function ParseASCIIZ(const ABytes : TIdBytes; const ALen : Cardinal) : String;
var i : Cardinal;
begin
  Result := '';
  if ALen=0 then
  begin
    Exit;
  end;
  for i := 0 to ALen do
  begin
    if ABytes[i]=0 then
    begin
      Break;
    end
    else
    begin
      Result := Result + Char(ABytes[i]);
    end;
  end;
end;

function UnixDateTimeToDelphiDateTime(UnixDateTime: Cardinal): TDateTime;
begin
   Result := (UnixDateTime / 86400) + UnixStartDate;
{
From: http://homepages.borland.com/efg2lab/Library/UseNet/1999/0309b.txt
 }
   //  Result := EncodeDate(1970, 1, 1) + (UnixDateTime / 86400); {86400=No. of secs. per day}