mysocket.pas

DarkMoon v4.11 (远程控制) 国外收集的代码,控件下载: http://www.winio.cn/Blogs/jishuwenzhang/200712/20071208230135.

unit MySocket;
{(C) Alex Demchenko([e-mail])}
{$R-}                   //Remove range checking
{$DEFINE USE_FORMS}     //If you don't use forms unit remove this line



{$DEFINE REMOVEHTTP}

interface
uses
  Windows, Messages, WinSock, {$IFDEF USE_FORMS}Forms, {$ENDIF} Classes, ICQWorks;

function InitMySocket(var WSA: TWSAData): LongWord;
procedure FinalMySocket;

const
  CNetPktLen = 8192;

type
  {$IFNDEF USE_FORMS}
  TWndMethod = procedure(var Message: TMessage) of object;
  {$ENDIF}

  TOnRecv = procedure(Sender: TObject; Socket: TSocket; Buffer: Pointer; BufLen: LongWord) of object;
  TOnPktParse = procedure(Sender: TObject; Buffer: Pointer; BufLen: LongWord) of object;
  TOnPktParseAdv = procedure(Sender: TObject; Buffer: Pointer; BufLen: LongWord; Incoming: Boolean) of object;
  TOnAdvPktParse = procedure(Sender: TObject; Buffer: Pointer; BufLen: LongWord; Incoming: Boolean) of object;
  TOnResolve = procedure(Sender: TObject; Addr: String) of object;
  TOnError = procedure(Sender: TObject; ErrorType: TErrorType; ErrorMsg: String) of object;

  PNetPacket = ^TNetPacket;
  TNetPacket = record
    Buf: array[0..CNetPktLen - 1] of Byte;
    BufLen: Word;
    Offset: Word;
    Next: PNetPacket;
  end;

  TNetBuffer = class(TObject)
  private
    FPkt: PNetPacket;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Clear;
    procedure AddPacket(Buffer: Pointer; BufLen: LongWord);
    procedure DelPacket;
    function GetPacket(Buffer: Pointer): LongWord;
    function SkipData(Len: Word): Boolean;
    procedure AddStr(Value: String);
    function GetStr: String;
  end;

  TClSock = class(TObject)
  private
    FWndHandle: THandle;
    FIp: String;
    FDestPort: LongWord;
    FClSock: TSocket;
    FOnRecv: TOnRecv;
    FOnDisconnect: TNotifyEvent;
    FOnConnect: TNotifyEvent;
    FOnConnectError: TNotifyEvent;
    FOnPktParse: TOnPktParse;
    FHostIp: array[0..MAXGETHOSTSTRUCT - 1] of Char;
    FResolve: Boolean;
    FOnResolve: TOnResolve;
    FOnFailed: TNotifyEvent;
    FOnError: TOnError;
    FCanWrite: Boolean;
    FBuffer: TNetBuffer;
    FOnDataSent: TNotifyEvent;
    function ResolveAddr(Value: Pointer): LongInt;
    function TestResolve(IP: String): Boolean;
    procedure InitConnect(dwIP: LongWord);
    procedure OnSockMsg(var Msg: TMessage);
    function IsConnected: Boolean;
    procedure ProcessBuffer;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Connect(ClearBuffer: Boolean = True); //Connect to remote host
    procedure Resolve; //Just resolve remote host w/o connecting
    procedure DoClose; //Close socket
    procedure Disconnect;
    procedure SendData(var Buf; BufLen: LongWord);
    procedure SendStr(const Value: String);
    property IP: String read FIp write FIp;
    property DestPort: LongWord read FDestPort write FDestPort;
    property Connected: Boolean read IsConnected;
    property WndHandle: THandle read FWndHandle;
  published
    property OnDataSent: TNotifyEvent read FOnDataSent write FOnDataSent;
    property OnRecieve: TOnRecv read FOnRecv write FOnRecv;
    property OnDisconnect: TNotifyEvent read FOnDisconnect write FOnDisconnect;
    property OnConnect: TNotifyEvent read FOnConnect write FOnConnect;
    property OnConnectError: TNotifyEvent read FOnConnectError write FOnConnectError;
    property OnPktParse: TOnPktParse read FOnPktParse write FOnPktParse;
    property OnResolve: TOnResolve read FOnResolve write FOnResolve;
    property OnResolveFailed: TNotifyEvent read FOnFailed write FOnFailed;
    property OnError: TOnError read FOnError write FOnError;
  end;

  TProxySock = class(TObject)
  private
    {$IFNDEF REMOVEHTTP}
    FICQRecv: TClSock;
    FICQSID: String;
    FICQSEQ: Word;
    FICQPIP: String;
    FICQPPORT: Word;

    FBuf: array[0..$FFFF - 1] of Byte;  //
    FCurLen: Word;                      //  HTTP Protocol
    FLen: Word;                         //
    {$ENDIF}

    FSrcBuf: array[0..MAX_DATA_LEN - 1] of Byte;
    FSrcLen: Word;
    FSock: TClSock;
    FProxyType: TProxyType;
    FProxyHost: String;
    FProxyPort: Word;
    FProxyAuth: Boolean;
    FProxyPass: String;
    FUserID: String;
    FHost: String;
    FPort: Word;
    FResolve: Boolean;
    FSocks: Word;
    FOnConnectError: TNotifyEvent;
    FOnDisconnect: TNotifyEvent;
    FOnPktParse: TOnAdvPktParse;
    FOnError: TOnError;
    FOnRecv: TOnRecv;
    FOnConnectProc: TNotifyEvent;
  private
    {$IFNDEF REMOVEHTTP}
    procedure HandleHTTPDataPak(Buffer: Pointer; BufLen: LongWord);
    procedure SendHTTPData(Buffer: Pointer; BufLen: LongWord);
    procedure HandleHTTPData(Buffer: Pointer; BufLen: LongWord);
    {$ENDIF}
    function GetWndHandle: THandle;

    {$IFNDEF REMOVEHTTP}
    procedure InitRecvConnection;
    procedure OnHTTPRecvSockConnect(Sender: TObject);
    procedure OnHTTPDataSent(Sender: TObject);
    {$ENDIF}

    procedure OnSockResolve(Sender: TObject; Addr: String);
    procedure OnSockResolveFailed(Sender: TObject);
    procedure OnSockConnect(Sender: TObject);
    procedure OnSockRecv(Sender: TObject; Socket: TSocket; Buffer: Pointer; BufLen: LongWord);
    procedure OnSockConnectError(Sender: TObject);
    procedure OnSockDisconnect(Sender: TObject);
    procedure OnSockError(Sender: TObject; ErrorType: TErrorType; ErrorMsg: String);
    procedure OnPktParse(Sender: TObject; Buffer: Pointer; BufLen: LongWord);
  protected
    procedure OnReceive(Buffer: Pointer; BufLen: LongWord); dynamic;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Connect; dynamic;
    procedure Disconnect;
    procedure SendData(var Buf; BufLen: LongWord);
    property Host: String read FHost write FHost;
    property Port: Word read FPort write FPort;
    property ProxyType: TProxyType read FProxyType write FProxyType;
    property ProxyHost: String read FProxyHost write FProxyHost;
    property ProxyPort: Word read FProxyPort write FProxyPort;
    property ProxyUserID: String read FUserID write FUserID;
    property ProxyAuth: Boolean read FProxyAuth write FProxyAuth;
    property ProxyPass: String read FProxyPass write FProxyPass;
    property UseProxyResolve: Boolean read FResolve write FResolve default False;
    property WndHandle: THandle read GetWndHandle;
  published
    property OnConnectError: TNotifyEvent read FOnConnectError write FOnConnectError;
    property OnDisconnect: TNotifyEvent read FOnDisconnect write FOnDisconnect;
    property OnPktParseA: TOnAdvPktParse read FOnPktParse write FOnPktParse;
    property OnError: TOnError read FOnError write FOnError;
    property OnReceiveProc: TOnRecv read FOnRecv write FOnRecv;
    property OnConnectProc: TNotifyEvent read FOnConnectProc write FOnConnectProc;
  end;

  TMySock = class(TProxySock)
  private
    function GetClientSocket: TSocket;
    procedure SetClientSocket(Socket: TSocket);
    function IsConnected: Boolean;
  public
    property ClientSocket: TSocket read GetClientSocket write SetClientSocket;
    property Connected: Boolean read IsConnected;
  end;

  TOnClientConnected = procedure(Sender: TObject; Socket: TMySock) of object;

  TSrvSock = class(TObject)
  private
    FPort: Word;
    FWndHandle: THandle;
    FSrvSock: TSocket;
    FOnClientConnected: TOnClientConnected;
    procedure OnSockMsg(var Msg: TMessage);
  public
    constructor Create;
    destructor Destroy; override;
    function StartServer(Port: Word): Boolean;
    function StopServer: Boolean;
    property Port: Word read FPort;
  published
    property OnClientConnected: TOnClientConnected read FOnClientConnected write FOnClientConnected;
  end;



var
  WSA: TWSAData;

function GetLocalIP: LongInt;
function FindBindPort: Word;

{$IFNDEF USE_FORMS}
function AllocateHWnd(Method: TWndMethod): THandle;
procedure DeallocateHWnd(Wnd: THandle);
{$ENDIF}



implementation
const
  WSA_ACCEPT   = WM_USER + $10;
  WSA_NETEVENT = WM_USER + $20;
  WSA_RESOLVE_COMPLETE = WM_USER + $30;


  b64alphabet: PChar = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';

function EncodeBase64(Value: String): String;
const
  pad: PChar = '====';

  function EncodeChunk(const Chunk: String): String;
  var
    W: LongWord;
    i, n: Byte;
  begin
    n := Length(Chunk); W := 0;
    for i := 0 to n - 1 do
      W := W + Ord(Chunk[i + 1]) shl ((2 - i) * 8);
    Result := b64alphabet[(W shr 18) and $3f] +
              b64alphabet[(W shr 12) and $3f] +
              b64alphabet[(W shr 06) and $3f] +
              b64alphabet[(W shr 00) and $3f];
    if n <> 3 then
      Result := Copy(Result, 0, n + 1) + Copy(pad, 0, 3 - n);   //add padding when out len isn't 24 bits
  end;

begin
  Result := '';
  while Length(Value) > 0 do
  begin
    Result := Result + EncodeChunk(Copy(Value, 0, 3));
    Delete(Value, 1, 3);
  end;
end;

function DecodeBase64(Value: String): String;
  function DecodeChunk(const Chunk: String): String;
  var
    W: LongWord;
    i: Byte;
  begin
    W := 0; Result := '';
    for i := 1 to 4 do
      if Pos(Chunk[i], b64alphabet) <> 0 then
        W := W + Word((Pos(Chunk[i], b64alphabet) - 1)) shl ((4 - i) * 6);
    for i := 1 to 3 do
      Result := Result + Chr(W shr ((3 - i) * 8) and $ff);
  end;
begin
  Result := '';
  if Length(Value) mod 4 <> 0 then Exit;
  while Length(Value) > 0 do
  begin
    Result := Result + DecodeChunk(Copy(Value, 0, 4));
    Delete(Value, 1, 4);
  end;
end;

constructor TNetBuffer.Create;
begin
  inherited;
  FPkt := nil;
end;

destructor TNetBuffer.Destroy;
begin
  Clear;
  inherited;
end;

procedure TNetBuffer.Clear;
var
  p: Pointer;
begin
  while FPkt <> nil do
  begin
    p := FPkt^.Next;
    FreeMem(FPkt);
    FPkt := p;
  end;
end;

procedure TNetBuffer.AddPacket(Buffer: Pointer; BufLen: LongWord);
var
  p: PNetPacket;
begin
  if BufLen > CNetPktLen then BufLen := CNetPktLen;
  if FPkt = nil then
  begin
    GetMem(FPkt, SizeOf(TNetPacket));
    p := FPkt;
  end else
  begin
    p := FPkt;
    while p <> nil do
    begin
      if p^.Next = nil then Break;
      p := p^.Next;
    end;
    GetMem(p^.Next, SizeOf(TNetPacket));
    p := p^.Next;
  end;
  p^.BufLen := BufLen;
  p^.Offset := 0;
  p^.Next := nil;
  Move(Buffer^, p^.Buf, BufLen);
end;

procedure TNetBuffer.DelPacket;
var
  p: PNetPacket;
begin
  if FPkt = nil then Exit;
  if FPkt^.Next <> nil then
  begin
    p := FPkt^.Next;
    FreeMem(FPkt);
    FPkt := p;
  end else
  begin
    FreeMem(FPkt);
    FPkt := nil;
  end;
end;

function TNetBuffer.GetPacket(Buffer: Pointer): LongWord;
begin
  if (FPkt = nil) or (FPkt^.Offset >= FPkt^.BufLen) then
  begin
    Result := 0;
    Exit;
  end;
  Move(Ptr(LongWord(@FPkt^.Buf) + FPkt^.Offset)^, Buffer^, FPkt^.BufLen - FPkt^.Offset);
  Result := FPkt^.BufLen - FPkt^.Offset;
end;

function TNetBuffer.SkipData(Len: Word): Boolean;
begin
  if FPkt = nil then
  begin
    Result := True;
    Exit;
  end;
  Inc(FPkt^.Offset, Len);
  Result := FPkt^.Offset >= FPkt^.BufLen;
end;

procedure TNetBuffer.AddStr(Value: String);
begin
  AddPacket(@Value[1], Length(Value)); 
end;

function TNetBuffer.GetStr: String;
var
  p: array[0..CNetPktLen] of Char;
begin
  p[GetPacket(@p)] := #0;
  Result := PChar(@p);
end;

function InitMySocket(var WSA: TWSAData): LongWord;
begin
  Result := WSAStartup(MAKEWORD(1, 1), WSA);
end;

procedure FinalMySocket;
begin
  WSACleanUp;
end;

//////////////////////////////////////////////////////////////////////////////////////////////////////////
{$IFNDEF USE_FORMS}
type
  PObjectInstance = ^TObjectInstance;
  TObjectInstance = packed record
    Code: Byte;
    Offset: Integer;
    case Integer of
      0: (Next: PObjectInstance);
      1: (Method: TWndMethod);
  end;

  PInstanceBlock = ^TInstanceBlock;
  TInstanceBlock = packed record
    Next: PInstanceBlock;
    Code: array[1..2] of Byte;
    WndProcPtr: Pointer;
    Instances: array[0..100] of TObjectInstance;
  end;

var
  InstBlockList: PInstanceBlock;
  InstFreeList: PObjectInstance;

{ Standard window procedure }
{ In    ECX = Address of method pointer }
{ Out   EAX = Result }

function StdWndProc(Window: HWND; Message, WParam: Longint;
  LParam: Longint): Longint; stdcall; assembler;
asm
          XOR     EAX,EAX
          PUSH    EAX
          PUSH    LParam
          PUSH    WParam
          PUSH    Message
          MOV     EDX,ESP
          MOV     EAX,[ECX].Longint[4]
          CALL    [ECX].Pointer
          ADD     ESP,12
          POP     EAX
end;

{ Allocate an object instance }
function CalcJmpOffset(Src, Dest: Pointer): Longint;
begin
  Result := Longint(Dest) - (Longint(Src) + 5);
end;

function MakeObjectInstance(Method: TWndMethod): Pointer;
const
  BlockCode: array[1..2] of Byte = (
    $59,       { POP ECX }
    $E9);      { JMP StdWndProc }
  PageSize = 4096;
var
  Block: PInstanceBlock;
  Instance: PObjectInstance;
begin
  if InstFreeList = nil then
  begin
    Block := VirtualAlloc(nil, PageSize, MEM_COMMIT, PAGE_EXECUTE_READWRITE);
    Block^.Next := InstBlockList;
    Move(BlockCode, Block^.Code, SizeOf(BlockCode));
    Block^.WndProcPtr := Pointer(CalcJmpOffset(@Block^.Code[2], @StdWndProc));
    Instance := @Block^.Instances;
    repeat
      Instance^.Code := $E8;  { CALL NEAR PTR Offset }
      Instance^.Offset := CalcJmpOffset(Instance, @Block^.Code);
      Instance^.Next := InstFreeList;
      InstFreeList := Instance;
      Inc(Longint(Instance), SizeOf(TObjectInstance));
    until Longint(Instance) - Longint(Block) >= SizeOf(TInstanceBlock);
    InstBlockList := Block;
  end;
  Result := InstFreeList;
  Instance := InstFreeList;
  InstFreeList := Instance^.Next;
  Instance^.Method := Method;
end;

{ Free an object instance }
procedure FreeObjectInstance(ObjectInstance: Pointer);
begin
  if ObjectInstance <> nil then
  begin
    PObjectInstance(ObjectInstance)^.Next := InstFreeList;
    InstFreeList := ObjectInstance;
  end;
end;

var
  UtilWindowClass: TWndClass = (
    style: 0;
    lpfnWndProc: @DefWindowProc;
    cbClsExtra: 0;
    cbWndExtra: 0;
    hInstance: 0;
    hIcon: 0;
    hCursor: 0;
    hbrBackground: 0;
    lpszMenuName: nil;
    lpszClassName: 'MySockUtilWindow'
  );

function AllocateHWnd(Method: TWndMethod): THandle;
var