icqsock.pas

本程序是转载的

              DoSocks5Connect;
            end;
          end;
        end;
        1:
        begin
          if FSrcLen = 2 then
          begin
            if FSrcBuf[1] <> 0 then
            begin
              FLastError := 0;
              FLastErrMsg := ICQLanguages[FErrLang].Translate(IMSG_ESOCK_SOCKS5NA);
              Synchronize(OnConnectError);
              Exit;
            end;
            FSrcLen := 0;
            Inc(FSocksProgress);
            DoSocks5Connect;
          end;
        end;
        2:
        begin
          if FSrcLen = 10 then
          begin
            if (FSrcBuf[0] <> 5) or (FSrcBuf[1] <> 0) then
            begin
              FLastError := 0;
              FLastErrMsg := ICQLanguages[FErrLang].Translate(IMSG_ESOCK_SOCKS5CONN);
              Synchronize(OnConnectError);
              Exit;
            end;
            FSrcLen := 0;
            ProxyReady := True;
            Synchronize(OnConnect);
            if i < BufLen - 1 then begin
              Buffer := Ptr(LongWord(Buffer) + i);
              Synchronize(OnReceive); //Continue handling of remaining data
            end;
          end;
        end;
      end;
    end;
  end else
    inherited;
end;





{ THTTPSocket }

procedure THTTPSocket.OnConnect;
begin
  inherited;
  FLen := 0;
  FCurLen := 0;
end;

procedure THTTPSocket.OnReceive;
  function GetHTTPLength(List: TStringList): Integer;
  var
    i: Word;
  begin
    Result := 0;
    if List.Count < 1 then Exit;
    for i := 0 to List.Count - 1 do
      if Copy(List.Strings[i], 0, 16) = 'Content-Length: ' then
      begin
        Result := StrToInt(Copy(List.Strings[i], 16, $FF));
        Exit;
      end;
  end;

  function StrToInt(const Value: String): LongWord;
  var
    nCode: Integer;
  begin
    Val(Value, Result, nCode);
  end;

var
  i: LongWord;
  List: TStringList;
  S: String;
begin
  if not ProxyReady then begin
    if BufLen < 1 then Exit;
    for i := 0 to BufLen - 1 do
    begin
      FBuf[FCurLen] := PByte(LongWord(Buffer) + i)^;
      Inc(FCurLen);
      if FLen = 0 then
        if FCurLen > 3 then
          if Copy(PChar(@FBuf), FCurLen - 3, 4) = #13#10#13#10 then
          begin
            List := TStringList.Create;
            List.Text := PChar(@FBuf);
            S := GetHTTPStatus(List);
            FLen := GetHTTPLength(List);
            List.Free;
            if S <> '200 OK' then
            begin
              FLastError := 0;
              FLastErrMsg := ICQLanguages[FErrLang].Translate(IMSG_ESOCK_HTTPSTAT) + S;
              Synchronize(OnError);
              Exit;
            end;
            if FLen + FCurLen > SizeOf(FBuf) then begin
              FLastError := 0;
              FLastErrMsg := ICQLanguages[FErrLang].Translate(IMSG_ESOCK_HTTPBUF);
              Synchronize(OnError);
              Exit;
            end;
            FCurLen := 0;
            {$IFDEF PARSE}
            LogText('http.txt', 'Received (proxy): '#13#10 + PChar(@FBuf));
            {$ENDIF}
          end;
      if (FCurLen = FLen) then
      begin

        {We suppose that only one page can be received}
        ProxyReady := True;
        Buffer := @FBuf;
        BufLen := FCurLen;
        Synchronize(OnReceive);
        Exit;
      end;
    end;
  end else
    inherited;
end;





{ THTTPSSocket }

procedure THTTPSSocket.OnConnect;
begin
  inherited;
  if not ProxyReady then begin
    FCurLen := 0;
    if FProxyResolve then
      SendStr('CONNECT ' + FDestHost + ':' + IntToStr(FDestPort) + ' HTTP/1.0' + #13#10)
    else
      SendStr('CONNECT ' + WSockAddrToIp(FDestIp) + ':' + IntToStr(FDestPort) + ' HTTP/1.0' + #13#10);
    SendStr('User-Agent: Mozilla/4.08 [en] (WinNT; U ;Nav)' + #13#10);
    if FProxyAuth then
      SendStr('Proxy-Authorization: Basic ' + EncodeBase64(ProxyUser + ':' + ProxyPass) + #13#10);
    SendStr(#13#10);
  end;
end;

procedure THTTPSSocket.OnReceive;
var
  i: LongWord;
  List: TStringList;
  S: String;
begin
  if not ProxyReady then begin
    if BufLen < 1 then Exit;
    for i := 0 to BufLen - 1 do
    begin
      FBuf[FCurLen] := PByte(LongWord(Buffer) + i)^;
      Inc(FCurLen);
      if FCurLen > 3 then
        if Copy(PChar(@FBuf), FCurLen - 3, 4) = #13#10#13#10 then
        begin
          List := TStringList.Create;
          List.Text := PChar(@FBuf);
          S := GetHTTPStatus(List);
          List.Free;
          CharLowerBuff(@S[1], Length(S));
          if S <> '200 connection established' then
          begin
            FLastError := 0;
            FLastErrMsg := ICQLanguages[FErrLang].Translate(IMSG_ESOCK_HTTPSTAT) + S;
            Synchronize(OnError);
            Exit;
          end;
          ProxyReady := True;
          {Handle remaining data}
          if i < BufLen - 1 then begin
            Buffer := Ptr(LongWord(Buffer) + i);
            BufLen := BufLen - i;
            Synchronize(OnReceive);
            Exit;
          end;
        end;
    end;
  end else
    inherited;
end;

{ TTCPServer }

constructor TTCPServer.Create;
begin
  inherited Create(True);
  FSocket := INVALID_SOCKET;
end;

destructor TTCPServer.Destroy;
begin
  FreeSocket;
  inherited;
end;

procedure TTCPServer.FreeSocket;
begin
  if not Terminated then Terminate;
  if FSocket <> INVALID_SOCKET then
    closesocket(FSocket);
end;

procedure TTCPServer.WaitForConnection;
Var
  FD,FDW,FDE:TFDSet;
Begin
  FD_ZERO(FD);
  FD_SET(fSocket, FD);
  FD_ZERO(FDW);
  FD_SET(fSocket, FDW);
  FD_ZERO(FDE);
  FD_SET(fSocket, FDE);
  select(fSocket + 1, @FD, @FDW, @FDE, nil); // Need to add a timeout maybe.
End;

procedure TTCPServer.Execute;
begin
  while not Terminated do begin
    //Should Wait For Connection here.
    WaitForConnection;
    FClient := accept(FSocket, nil, nil);
    if (FClient = INVALID_SOCKET) then begin
      if not Terminated then begin
        FLastError := WSAGetLastError;
        FLastErrMsg := ICQLanguages[FErrLang].Translate(IMSG_ESOCK_ACCEPT);
        Synchronize(OnError);
      end;
      Exit;
    end else
      Synchronize(OnClientConnected);
  end;
end;

function TTCPServer.Start: Boolean;
var
  srv_addr: TSockAddrIn;
begin
  Result := False;
//  FreeSocket;
  FSocket := socket(PF_INET, SOCK_STREAM, 0);
  srv_addr.sin_family := AF_INET;
  srv_addr.sin_port := htons(FPort);
  srv_addr.sin_addr.S_addr := INADDR_ANY;
  if bind(FSocket, srv_addr, sizeof(srv_addr)) = SOCKET_ERROR then begin
    FLastError := WSAGetLastError;
    FLastErrMsg := ICQLanguages[FErrLang].Translate(IMSG_ESOCK_BIND);
    Synchronize(OnError);
    Exit;
  end;
  if listen(FSocket, SOMAXCONN) = SOCKET_ERROR then begin
    FLastError := WSAGetLastError;
    FLastErrMsg := ICQLanguages[FErrLang].Translate(IMSG_ESOCK_LISTEN);
    Synchronize(OnError);
    Exit;
  end;
  Result := True;
  Self.Resume;
end;

procedure TTCPServer.OnError;
begin
  FreeSocket;
  if Assigned(_OnError) then
    FOnError(Self, ERR_SOCKET, FLastErrMsg);
end;

procedure TTCPServer.OnClientConnected;
begin
  if Assigned(_OnClientConnected) then
    FOnClientConnected(Self, FClient);
end;




///-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-

function WSAErrorToStr(ErrorNo: Integer): String;
begin
  case ErrorNo of
    WSAEINTR:           Result := 'Interrupted system call';
    WSAEBADF:           Result := 'Bad file number';
    WSAEACCES:          Result := 'Permission denied';
    WSAEFAULT:          Result := 'Bad address';
    WSAEINVAL:          Result := 'Invalid argument';
    WSAEMFILE:          Result := 'Too many open files';
    WSAEWOULDBLOCK:     Result := 'Operation would block';
    WSAEINPROGRESS:     Result := 'Operation now in progress';
    WSAEALREADY:        Result := 'Operation already in progress';
    WSAENOTSOCK:        Result := 'Socket operation on non-socket';
    WSAEDESTADDRREQ:    Result := 'Destination address required';
    WSAEMSGSIZE:        Result := 'Message too long';
    WSAEPROTOTYPE:      Result := 'Protocol wrong type for socket';
    WSAENOPROTOOPT:     Result := 'Protocol not available';
    WSAEPROTONOSUPPORT: Result := 'Protocol not supported';
    WSAESOCKTNOSUPPORT: Result := 'Socket type not supported';
    WSAEOPNOTSUPP:      Result := 'Operation not supported on socket';
    WSAEPFNOSUPPORT:    Result := 'Protocol family not supported';
    WSAEAFNOSUPPORT:    Result := 'Address family not supported by protocol family';
    WSAEADDRINUSE:      Result := 'Address already in use';
    WSAEADDRNOTAVAIL:   Result := 'Can''t assign requested address';
    WSAENETDOWN:        Result := 'Network is down';
    WSAENETUNREACH:     Result := 'Network is unreachable';
    WSAENETRESET:       Result := 'Network dropped connection on reset';
    WSAECONNABORTED:    Result := 'Software caused connection abort';
    WSAECONNRESET:      Result := 'Connection reset by peer';
    WSAENOBUFS:         Result := 'No buffer space available';
    WSAEISCONN:         Result := 'Socket is already connected';
    WSAENOTCONN:        Result := 'Socket is not connected';
    WSAESHUTDOWN:       Result := 'Can''t send after socket shutdown';
    WSAETOOMANYREFS:    Result := 'Too many references: can''t splice';
    WSAETIMEDOUT:       Result := 'Connection timed out';
    WSAECONNREFUSED:    Result := 'Connection refused';
    WSAELOOP:           Result := 'Too many levels of symbolic links';
    WSAENAMETOOLONG:    Result := 'File name too long';
    WSAEHOSTDOWN:       Result := 'Host is down';
    WSAEHOSTUNREACH:    Result := 'No route to host';
    WSAENOTEMPTY:       Result := 'Directory not empty';
    WSAEPROCLIM:        Result := 'Too many processes';
    WSAEUSERS:          Result := 'Too many users';
    WSAEDQUOT:          Result := 'Disc quota exceeded';
    WSAESTALE:          Result := 'Stale NFS file handle';
    WSAEREMOTE:         Result := 'Too many levels of remote in path';
    WSASYSNOTREADY:     Result := 'Network sub-system is unusable';
    WSAVERNOTSUPPORTED: Result := 'WinSock DLL cannot support this application';
    WSANOTINITIALISED:  Result := 'WinSock not initialized';
    WSAHOST_NOT_FOUND:  Result := 'Host not found';
    WSATRY_AGAIN:       Result := 'Non-authoritative host not found';
    WSANO_RECOVERY:     Result := 'Non-recoverable error';
    WSANO_DATA:         Result := 'No Data';
    else                Result := 'Not a WinSock error';
  end;
end;

function FindBindPort: Word;
var
  i: Word;
  srv_address: sockaddr_in;
  sock: TSocket;
begin
  Result := 0;
  sock := socket(AF_INET, SOCK_STREAM, 0);
  if sock = INVALID_SOCKET then
    Exit;
  srv_address.sin_family := AF_INET;
  srv_address.sin_addr.s_addr := INADDR_ANY;
  for i := gPortRange.First to gPortRange.Last do
  begin
    srv_address.sin_port := htons(i);
    if bind(sock, srv_address, SizeOf(srv_address)) <> SOCKET_ERROR then
    begin
      closesocket(sock);
      Result := i;
      Exit;
    end;
  end;
end;

function GetLocalIP: Integer;
type
  PaPInAddr = ^TaPInAddr;
  TaPInAddr = array[0..$FFFE] of PInAddr;
var
  phe: PHostEnt;
  pptr: PaPInAddr;
  Buffer: array[0..MAXGETHOSTSTRUCT - 1] of Char;
  I: Integer;
begin
  Result := -1;
  GetHostName(Buffer, SizeOf(Buffer));
  phe := GetHostByName(Buffer);
  if phe = nil then Exit;
  pptr := PaPInAddr(Phe^.h_addr_list);
  I := 0;
  while pptr^[I] <> nil do
  begin
    Result := pptr^[I]^.S_addr;
    Inc(I);
  end;
end;

function WSockAddrToIp(Value: LongWord): String;
var
  ia: in_addr;
begin
  ia.S_addr := Value;
  Result := inet_ntoa(ia);
end;

initialization
  {Use WinSock 1.1}
  if WSAStartup(MAKEWORD(1, 1), WSAData) <> 0 then begin
    {$IFDEF DEBUG}
    MessageBox(0, PChar('Could not start WSA'), 'Error!', MB_ICONERROR);
    {$ENDIF}
    WSAStarted := False;
  end else
    WSAStarted := True;

finalization
  if WSACleanUp <> 0 then begin
    {$IFDEF DEBUG}
    MessageBox(0, PChar('Could not cleanup WSA'), 'Error!', MB_ICONERROR);
    {$ENDIF}
  end;
  WSAStarted := False;
end.