btutils.pas

由delphi实现的bt下载器示例程序

unit btutils;

//{$DEFINE DEBUGMSG}
interface

uses
  windows, sysutils, classes, winsock, DCPsha1, SortLists, SimpleSocks,
  InetUtils, ThreadTimer, DelayLists{$IFDEF DEBUGMSG}, debugunit{$ENDIF};

const
  PEER_ID            =   '-BC0095-';
  PEER_ID2           =   '2-4297-8-38F';
  CLIENTS_WANTED     =   100;           // peers count from tracker

  REQUEST_BLOCK_SIZE =   16 * 1024;
  REQUERY_INTERVAL   =   10000;
  KEEPALIVE_INTERVAL =   30000;
  TRACKER_INTERVAL   =   5000;
  TRACKER_TIMEOUT    =   10000;
  BTMANAGER_INTERVAL =   2000;
  MAX_SERVICE        =   4;            // max upload count
  MAX_REQUEST        =   50;           // max download count
  MIN_SEED_WANT      =   6;
  WRITETIMEOUT       =   5000;
  READTIMEOUT        =   10000;
  CHOKETIMEOUT       =   60000;
  SERV_TIMEOUT       =   30000;
  SOCKTIMEOUT        =   180000;
  RANDOMBLOCK        =   false;
  MAX_SEND_LIMIT     =   256 * 1024;
  MAX_RECV_LIMIT     =   16;

type
  TSHA1 = array [0..4] of DWORD;

  TSHA1Arr = array [0..1] of TSHA1;
  PSHA1Arr = ^TSHA1Arr;

  TBTMngr = class;
  TBTTracker = class;
  TBencodeItem = class;
  TBencodeList = class;
  TBencodeDict = class;

  TBencodeData = class(TList)
  private
    function GetValue: TBencodeData;
    procedure SetValue(const Value: TBencodeData);
  public
    function Bencode: string; virtual; abstract;
    procedure Bdecode(var p: PChar; var Len: Integer); virtual; abstract;
    property Values: TBencodeData read GetValue write SetValue;
  end;

  TBencodeInt = class(TBencodeData)
  private
    function GetInt: Int64;
    procedure SetInt(const Value: Int64);
  public
    procedure Clear; override;
    function Bencode: string; override;
    procedure Bdecode(var p: PChar; var Len: Integer); override;
    property Values: Int64 read GetInt write SetInt;
  end;

  TBencodeStr = class(TBencodeData)
  private
    function GetStr: string;
    procedure SetStr(const Value: string);
  public
    procedure Clear; override;
    function Bencode: string; override;
    procedure Bdecode(var p: PChar; var Len: Integer); override;
    property Values: string read GetStr write SetStr;
  end;

  TBencodeDict = class(TBencodeData)
  private
    function GetDict(AName: string): TBencodeItem;
    procedure SetDict(AName: string; const Value: TBencodeItem);
    function FindItem(AName: string): Integer;
    function GetDictValue(AName: string): TBencodeDict;
    function GetIntValue(AName: string): Int64;
    function GetListValue(Aname: string): TBencodeList;
    function GetStrValue(AName: string): string;
  public
    procedure Clear; override;
    function Bencode: string; override;
    procedure Bdecode(var p: PChar; var Len: Integer); override;
    function AddInt(AName: string; Value: Int64): TBencodeItem;
    function AddStr(AName, Value: string): TBencodeItem;
    function AddListDirect(AName: string; Value: TBencodeList): TBencodeItem;
    function AddDictDirect(AName: string; Value: TBencodeDict): TBencodeItem;
    function AddList(AName: string): TBencodeList;
    function AddDict(AName: string): TBencodeDict;
    property Values[AName: string]: TBencodeItem read GetDict write SetDict;
    property IntValue[AName: string]: Int64 read GetIntValue;
    property StrValue[AName: string]: string read GetStrValue;
    property ListValue[Aname: string]: TBencodeList read GetListValue;
    property DictValue[AName: string]: TBencodeDict read GetDictValue;
  end;

  TBencodeList = class(TBencodeData)
  private
    function GetList(Index: Integer): TBencodeData;
    procedure SetList(Index: Integer; const Value: TBencodeData);
    function GetDictValue(Index: Integer): TBencodeDict;
    function GetIntValue(Index: Integer): Int64;
    function GetListValue(Index: Integer): TBencodeList;
    function GetStrValue(Index: Integer): string;
  public
    procedure Clear; override;
    function Bencode: string; override;
    procedure Bdecode(var p: PChar; var Len: Integer); override;
    function AddInt(Value: Int64): Integer;
    function AddStr(Value: string): Integer;
    function AddListDirect(Value: TBencodeList): Integer;
    function AddDictDirect(Value: TBencodeDict): Integer;
    function AddList: Integer;
    function AddDict: Integer;
    property Values[Index: Integer]: TBencodeData read GetList write SetList;
    property IntValue[Index: Integer]: Int64 read GetIntValue;
    property StrValue[Index: Integer]: string read GetStrValue;
    property ListValue[Index: Integer]: TBencodeList read GetListValue;
    property DictValue[Index: Integer]: TBencodeDict read GetDictValue;
  end;

  TBencodeItem = class(TBencodeStr)
  private
    function GetItem: TBencodeData;
    function GetName: string;
    procedure SetItem(const Value: TBencodeData);
    procedure SetName(const Value: string);
    function GetDictValue: TBencodeDict;
    function GetIntValue: Int64;
    function GetListValue: TBencodeList;
    function GetStrValue: string;
  public
    procedure Clear; override;
    function Bencode: string; override;
    procedure Bdecode(var p: PChar; var Len: Integer); override;
    property Values: TBencodeData read GetItem write SetItem;
    property Name: string read GetName write SetName;
    property IntValue: Int64 read GetIntValue;
    property StrValue: string read GetStrValue;
    property ListValue: TBencodeList read GetListValue;
    property DictValue: TBencodeDict read GetDictValue;
  end;

  TBTBits = class
  private
    FBits: PByteArray;
    FSetCnt: Integer;
    FSize: Integer;
    function GetBits(Index: Integer): Boolean;
    procedure SetBits(Index: Integer; const Value: Boolean);
    function GetCount: Integer;
    procedure SetCount(const Value: Integer);
    procedure SetSize(const Value: Integer);
  public
    destructor Destroy; override;
    procedure Clear;
    procedure ANDBits(Bits: TBTBits); overload;
    procedure ANDBits(const Buf; Cnt: Integer); overload;
    procedure ORBits(Bits: TBTBits); overload;
    procedure ORBits(const Buf; Cnt: Integer); overload;
    procedure XORBits(Bits: TBTBits); overload;
    procedure XORBits(const Buf; Cnt: Integer); overload;
    procedure Invert(Cnt: Integer);
    function ToString(Cnt: Integer=0): string;
    procedure FromString(Bits: string);
    function GetBitIndex(Flag: Boolean; Position: Integer = 1): Integer;

    property Bits[Index: Integer]: Boolean read GetBits write SetBits; default;
    property Size: Integer read FSize write SetSize;
    property Count: Integer read GetCount write SetCount;
    property BitsCount: Integer read FSetCnt;
  end;

  TBTInfo = class(TList)
  private
    FLock: TRTLCriticalSection;
    FOwner: TBTMngr;
    procedure SetOwner(const Value: TBTMngr);
  public
    InfoHash: TSHA1;
    Announce: string;
    Comment: string;
    CreateDate: Integer;
    BlockSize: Integer;
    Blocks: string;
    TotalSize: Int64;
    FilePath: string;

    BitFlags: TBTBits;
    RestSize: Int64;

    Interval: Cardinal;
    UpSize: Int64;
    DownSize: Int64;
    AnalyzedSize: Int64;
    Registered: Boolean;
    BTExt: Boolean;
    WorkPath: string;
    RequestCnt: Integer;

    Clients: TStringList;
    Tracker: TInetJob;
    TrackerTick: Cardinal;
    DownCnt: Integer;
    SeedCnt: Integer;
    Tag: Integer;

    constructor Create(AOwner: TBTMngr);
    destructor Destroy; override;
    procedure Clear; override;
    procedure Init(ADict: TBencodeDict);
    function Bencode: string;
    procedure AddFileInfo(AInfo: TBencodeDict);
    procedure InitBitFlags;
    function BlockToFile(Blk: Integer; var Index: Integer; var FileOff: Int64): Boolean;
    procedure LoadFromStream(AStream: TStream);
    procedure SaveToStream(AStream: TStream);
    function LoadTorrent(ATorrent: string): Boolean;
    procedure Lock;
    function TryLock(TimeOut: Cardinal = 0): Boolean;
    procedure Unlock;
    function MakeAnnounce(evt: string = ''; num: Integer = CLIENTS_WANTED): string;
    procedure StopTracker;
    procedure DoTracker(Sender: TBTTracker);
    function GetBlockBuffer(Index: Integer): string;
    procedure SetBlockBuffer(Index: Integer; const Buf; Len: Integer);
    function GetBitField: string;
    function Completed: Boolean;
    function PeekClient(var a: TSockAddrIn): Boolean;

    property Owner: TBTMngr read FOwner write SetOwner;
  end;

  TBTFile = class
  public
    Parent: TBTInfo;
    Index: Integer;

    FileName: string;
    FileSize: Int64;
    StartOff: Int64;
    OriginFile: string;
    CRC: Cardinal;
    ZipCRC: Cardinal;
    Zipped: Boolean;

    destructor Destroy; override;
    function BencodeName: TBencodeList;
    procedure BdecodeName(Names: TBencodeList);
    function MakeComment: string;
    procedure InitInfo(Info: string);
    function ReadToBuffer(var Buffer; BufLen: Integer; var FileOff: Int64; var SkipLen: Integer; var BufChg: Boolean): Boolean;
    function WriteFromBuffer(const Buffer; BufLen: Integer; var FileOff: Int64; var WriteLen: Integer): Boolean;
    procedure LoadFromStream(AStream: TStream);
    procedure SaveToStream(AStream: TStream);
  end;

  TBTTracker = class(TLockList)
  private
    Timer: Cardinal;
    function CompareBT(Key, Item: Pointer): Integer;
    procedure ReleaseBT(Data: Pointer);
    procedure Callback(Sender: TInetJob; Code: Integer);
    procedure DoTimer(WParam, LParam: Integer);
    function GetActive: Boolean;
    procedure SetActive(const Value: Boolean);
    procedure DoTracker(List: TObject; Item: Pointer; WParam, LParam: Integer);
  public
    Owner: TBTMngr;
    constructor Create(AOwner: TBTMngr);
    destructor Destroy; override;
    property Active: Boolean read GetActive write SetActive;
  end;

  TBTBlockKey = record
    Info: TBTInfo;
    Index: Integer;
  end;
  PBTBlockKey = ^TBTBlockKey;

  TBTBlock = class
  private
    FLock: TRTLCriticalSection;
  public
    Owner: TBTMngr;
    Key: TBTBlockKey;
    Cache: string;
    Blocks: TRuler;
    Wants: TRuler;
    BlockLen: Cardinal;
    LastRequest: Cardinal;
    constructor Create(AOwner: TBTMngr; AInfo: TBTInfo; AIndex: Integer);
    destructor Destroy; override;
    function WriteCache(Offset: Integer; const buf; len: Integer; IsInit: Boolean = false): Boolean;
    function ReadCache: string;
    function ReadPart(Offset, Len: Integer): string;
    procedure Lock;
    procedure Unlock;
  end;

  TBTClient = class
  private
    FLock: TRTLCriticalSection;
  public
    Owner: TBTMngr;
    Info: TBTInfo;
    Sock: TSimpleSock;
    Flags: TBTBits;
    IsAccepted: Boolean;
    Connected: Boolean;
    Unchoked: Boolean;
    RemoteUnchoked: Boolean;
    RemoteInterested: Boolean;

    UnchokedTick: Cardinal;
    RemoteUnchokedTick: Cardinal;
    InterestedTick: Cardinal;
    LastReadTick: Cardinal;
    LastWriteTick: Cardinal;
    KeepAliveTick: Cardinal;
    Downloading: Integer;

    constructor Create(AOwner: TBTMngr);
    destructor Destroy; override;
    procedure Lock;
    procedure Unlock;
    procedure DoRemoteChoke;
    procedure DoRemoteUnchoke;
    procedure DoRemoteInterested;
    procedure DoRemoteNotInterested;
    procedure DoHaveBlock(Index: Integer);
    procedure DoGetBitField(const Buf; Len: Integer);
    procedure DoRequestBlock(Index, Off, Len: Integer);
    procedure DoReadBlock(Index, Off: Integer; const Buf; Len: Integer);

    procedure UnChokeRemote;
    procedure ChokeRemote;
    function RequestBlock(Index: Integer): Boolean;
    procedure HaveBlock(Blk: TBTBlock);
    procedure RequestRandomBlock(WParam, LParam: Integer);
  end;

  TBTNotifyEvent = procedure (Sender: TBTMngr; Info: TBTInfo) of object;
  TBTMngr = class
  private
    FOnBTDownloaded: TBTNotifyEvent;

    function CompareBTInfo(Key, Item: Pointer): Integer;
    function CompareClient(Key, Item: Pointer): Integer;
    function CompareClient2(Key, Item: Pointer): Integer;


    function CompareBTBlock(Key, Item: Pointer): Integer;
    function CompareConnection(Key, Item: Pointer): Integer;
    function CompareConnection2(Key, Item: Pointer): Integer;

    procedure ReleaseInfo(Data: Pointer);
    procedure ReleaseBlock(Data: Pointer);
    procedure ReleaseClient(Data: Pointer);

    function CreateBlock(Key: Pointer): Pointer;

    procedure DoTimer(WParam, LParam: Integer);
    procedure DoTimer2(WParam, LParam: Integer);
    procedure DoBTFinish(WParam, LParam: Integer);
    procedure DoSockEvent(Sender: TSimpleSock; Code: Integer; const Buf; var Len: Integer);
    procedure DoSockRead(Sock: TSimpleSock; const Buf; var Len: Integer);
    procedure DoSockConnect(Sock: TSimpleSock);
    procedure DoSockClose(Sock: TSimpleSock);
    function GetDownSize: Int64;
    function GetRestSize: Int64;
    function GetTotalSize: Int64;
    function GetUpSize: Int64;
    procedure DoGetDownSize(List: TObject; Item: Pointer; WParam, LParam: Integer);
    procedure DoGetUpSize(List: TObject; Item: Pointer; WParam, LParam: Integer);
    procedure DoGetRestSize(List: TObject; Item: Pointer; WParam, LParam: Integer);
    procedure DoGetTotalSize(List: TObject; Item: Pointer; WParam, LParam: Integer);
    procedure InnerAddInfo(AInfo: TBTInfo);
  public
    WorkPath: string;
    CachePath: string;
    Tracker: TBTTracker;

    Links: TLockList;
    Connections: TLockList;
    BTInfos: TLockList;
    Blocks: TLockList;

    Timer: Cardinal;
    Timer2: Cardinal;
    ListenPort: Word;
    ListenSock: TSimpleSock;

    UpCnt: Integer;
    SendLimit: Cardinal;
    Requesting: Cardinal;
    BandLimit: Cardinal;

    constructor Create;
    destructor Destroy; override;
    function Open: Boolean;
    procedure Close;
    function DeleteInfo(AInfo: TBTInfo): Boolean;

    function MakeCmd(Cmd: Byte; Para: string): string;
    function GetBlock(Info: TBTInfo; Index: Integer): TBTBlock;
    procedure RequestMoreLinks(Info: TBTInfo);
    property UpSize: Int64 read GetUpSize;
    property DownSize: Int64 read GetDownSize;
    property RestSize: Int64 read GetRestSize;
    property TotalSize: Int64 read GetTotalSize;
    property OnBTDownloaded: TBTNotifyEvent read FOnBTDownloaded write FOnBTDownloaded;
  end;

function CompareSha1(const Sha1, Sha2): Integer;
procedure CopyFileFromOrigin(Source, Dest: string);

implementation

function CompareSha1(const Sha1, Sha2): Integer;
var
  i: Integer;
  p1, p2: PIntegerArray;
begin
  p1 := @Sha1;
  p2 := @Sha2;
  for i := 0 to 4 do
  begin
    result := p1[i] - p2[i];
    if result <> 0 then
      break;
  end;
end;

procedure CopyFileFromOrigin(Source, Dest: string);
begin
end;

const
  HexDigit: array [0..15] of char = ('0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F');
  
function BufToHex(const Buf; Len: Integer): string;
var
  p: PByte;
  i: Integer;
begin
  setlength(result, len*2);
  p := pbyte(@buf);
  for i := 0 to len-1 do
  begin
    result[i*2+1] := HexDigit[p^ shr 4];
    result[i*2+2] := HexDigit[p^ and $f];
    inc(p);
  end;
end;

function HTTPEncode(const buf; Len: Integer): string; overload;
var
  i, n: Integer;
  p: PChar;
begin
  p := Pchar(@buf);
  n := 1;
  setlength(result, len*3);
  for i := 1 to len do
  begin
    //if p^ in ['0'..'9', 'A'..'Z', 'a'..'z', '_', '$', '-', '.', '+', '!', '*', '''','(', ')'] then
    if p^ in ['0'..'9', 'A'..'Z', 'a'..'z', '_'] then
    begin
      result[n] := p^;
      inc(n);
    end
    else begin
      result[n] := '%';
      result[n+1] := HexDigit[pbyte(p)^ shr 4];
      result[n+2] := HexDigit[pbyte(p)^ and $f];
      inc(n, 3);
    end;
    inc(p);
  end;
  setlength(result, n-1);
end;

function HTTPEncode(const s: string): string; overload;
begin
  result := HTTPEncode(s[1], length(s));
end;

function RandomPeerId: string;
const
  PeerIdChar: string = '0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ$-_.+!*';
var
  i: Integer;
begin
  setlength(result, 12);
  for i := 1 to 8 do
    result[i] := PeerIdChar[random(length(PeerIdChar))+1];
end;

{ TBencodeData }

function TBencodeData.GetValue: TBencodeData;
begin
  result := self;
end;

procedure TBencodeData.SetValue(const Value: TBencodeData);
begin

end;

{ TBencodeInt }

procedure TBencodeInt.Clear;
begin
  with TListRef(self) do
  begin
    FList := nil;
    FCount := 0;
    FCapacity := 0;
  end;
  inherited;
end;

procedure TBencodeInt.Bdecode(var p: PChar; var Len: Integer);
var
  pi: PInt64;