unit Unit1;

interface

uses
 Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
 Dialogs, ScktComp, StdCtrls;

type
 TForm1 = class(TForm)
   Button1: TButton;
   ClientSocket1: TClientSocket;
   procedure Button1Click(Sender: TObject);
 private
   { Private declarations }
 public
   { Public declarations }
 end;

var
 Form1: TForm1;

implementation
uses WinSock,RTLConsts;
{$R *.dfm}

const
 LF = #10; CR = #13;
 EOL = CR + LF;
const
 DefTimeout:Longint=60000;
 DefMaxLineLength:integer=MaxWord;

function SockWaitForData(ASocket:TSocket; ATimeout: Longint): Boolean;
var
 FDSet: TFDSet;
 TimeVal: TTimeVal;
begin
 if ATimeout=-1 then ATimeout:=DefTimeout;
 TimeVal.tv_sec := ATimeout div 1000;
 TimeVal.tv_usec := (ATimeout mod 1000) * 1000;
 FD_ZERO(FDSet);
 FD_SET(ASocket, FDSet);
 Result := select(0, @FDSet, nil, nil, @TimeVal) > 0;
end;

function LCharPos(Str:PChar;char:char;Size:integer): Integer;
asm  {Str - EAX, char - DL (EDX), Size - ECX}
       PUSH    EDI
       MOV     EDI, EAX { Point EDI to str}

       MOV     AL,DL        { AL = Search char}
       MOV     EDX,ECX   {remember Length}

       REPNE   SCASB
       JNE     @@fail
       MOV     EAX,EDX { Calc offset }
       SUB     EAX,ECX
       JMP     @@fin
@@fail:
       XOR     EAX,EAX
@@fin:
       POP     EDI
end;

function CharPos(const str:string;char:char): Integer;
asm
       TEST    EAX, EAX
       JE     @@exit
       MOV     ECX, [EAX-4]
       call    LCharPos
@@exit:
end;

function Fetch(var AInput:string;const ADelim:char):string;
var LPos: Integer;
begin
 LPos:=CharPos(AInput,ADelim);
 if LPos=0 then
 begin
   Result:=AInput;
   AInput:='';
 end else
 begin
   Result:=Copy(AInput,1,LPos-1);
   AInput:=Copy(AInput,LPos+1,MaxInt);
 end;
end;

function SockReadLn(ASocket:TSocket;ATerminator:char=LF;AMaxLineLength:integer=MaxWord;AT imeOut:Longint=0):string;
var
 Buf:array[byte] of char;
 SizeBuf:integer;
 r,i:integer;
 s:string;
begin
 if ATimeout=0 then ATimeout:=DefTimeout;
 SizeBuf:=SizeOf(Buf);
 result:='';
 while SockWaitForData(ASocket,ATimeOut) do
 begin
   r:=recv(ASocket, Buf, SizeBuf, MSG_PEEK);
   if r=0 then Break;
   if r=SOCKET_ERROR then Raise Exception.Create('recv');

   i:=LCharPos(@Buf,ATerminator,r);
   if i<>0 then r:=i;

   r:=recv(ASocket, Buf, r, 0);
   if r=0 then Break;
   if r=SOCKET_ERROR then Raise Exception.Create( 'recv');

   SetString(s,Buf,r);
   result:=result+s;
   if i<>0 then Break;
 end;
 if length(result)=0 then exit;
 i:=length(result)-1;
 if (ATerminator=LF) and (result[i]=CR) then Dec(i);
 SetLength(result,i);
end;

procedure WriteBuffer(ASocket:TSocket; const Buffer; Count: Longint;ATimeout:Longint=0);
var
 Overlapped: TOverlapped;
 ErrorCode,Result: Integer;
begin
 if ATimeout=0 then ATimeout:=DefTimeout;
 FillChar(OVerlapped,SizeOf(Overlapped),0);
 Overlapped.hEvent:=CreateEvent(nil,True,False,'');
 try
   if not WriteFile(ASocket, Buffer, Count, DWORD(Result),
     @Overlapped) and (GetLastError <> ERROR_IO_PENDING) then
   begin
     ErrorCode := GetLastError;
     raise ESocketError.CreateResFmt(@sSocketIOError, [sSocketWrite, ErrorCode,
       SysErrorMessage(ErrorCode)]);
   end;
   if WaitForSingleObject(Overlapped.hEvent, ATimeout)<>WAIT_OBJECT_0 then
     Result := 0
   else GetOverlappedResult(ASocket, Overlapped, DWORD(Result), False);
 finally
   CloseHandle(Overlapped.hEvent);
 end;
end;

procedure SockWriteLn(ASocket:TSocket;const AOut:string='');
begin
 if Length(AOut)>0 then
   WriteBuffer(ASocket,Pointer(AOut)^, Length(AOut));
 WriteBuffer(ASocket,EOL,Length(EOL));
end;

const
 ProxyHost='192.168.14.2';
 ProxyPort=3128;

 RemoteHost='www.ya.ru';
 RemotePort=80;
 proxy=true;

procedure TForm1.Button1Click(Sender: TObject);
var
 s:string;
 Code,i:integer;
begin
 ClientSocket1.ClientType:=ctBlocking;
 if proxy then
 begin
   ClientSocket1.Host:=ProxyHost;
   ClientSocket1.Port:=ProxyPort;
 end else
 begin
   ClientSocket1.Host:=RemoteHost;
   ClientSocket1.Port:=RemotePort;
 end;
 ClientSocket1.Open;
 if proxy then
 begin
   SockWriteLn(ClientSocket1.Socket.SocketHandle,format('CONNECT %s:%d HTTP/1.1'#13#10,[RemoteHost,RemotePort]));
   s:=SockReadLn(ClientSocket1.Socket.SocketHandle);
   if Length(s)=0 then raise Exception.Create('Bad HTTP respond');
   Fetch(s,' ');// to remove the http/1.0 or http/1.1
   Code:=StrToIntDef(Fetch(s,' '),200); // if invalid response then we assume it succeeded
   if Code<>200 then raise Exception.CreateFmt('Bad HTTP status code: %d %s',[Code,s]);
   i:=128;
   repeat dec(i) until
     (SockReadLn(ClientSocket1.Socket.SocketHandle) = '') or (i<=0);
   if i<=0 then
     raise Exception.Create('Too many headers or wrong protocol');
 end;

 DOWORK;

end;

end.

ClientSocket1.Host:=ProxyHost;
ClientSocket1.Port:=ProxyPort;

function BasicAuthentication(const Username,Password:string): String;
begin
 with TIdEncoderMIME.Create do try
   Result := 'Basic ' + Encode(Username + ':' + Password); {do not localize}
 finally Free; end;
end;

SockWriteLn(ClientSocket1.Socket.SocketHandle,format('CONNECT %s:%d HTTP/1.1',[RemoteHost,RemotePort]));
SockWriteLn(ClientSocket1.Socket.SocketHandle,format('Proxy-Authorization: %s'#13#10,[BasicAuthentication(Username,Password)]));

SockWriteLn(ClientSocket1.Socket.SocketHandle,format('CONNECT %s:%d  HTTP/1.1',[RemoteHost,RemotePort]));// один перевод строки

SockWriteLn(ClientSocket1.Socket.SocketHandle,format('Proxy-Authorization: %s'#13#10,[BasicAuthentication(Username,Password)]));// два перевода строки
или записать по другому
SockWriteLn(ClientSocket1.Socket.SocketHandle,format('Proxy-Authorization: %s',[BasicAuthentication(Username,Password)]));// один перевод строки
SockWriteLn('');// еще один перевод строки

allow * * * 443,8443 HTTPS

allow * * * * HTTPS

dim root
dim tpranges
dim newrange
set root = createobject("FPC.Root")
set tpranges = root.GetContainingArray.ArrayPolicy.WebProxy.TunnelPortRanges
set newRange = tpRanges.AddRange("SSL 4433", 4433, 4433)
tpRanges.Save