unit MainUnit;

interface

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

type
 THTTPProxyForm = class(TForm)
   bnStart: TButton;
   Label1: TLabel;
   edPort: TEdit;
   Label2: TLabel;
   edExtProxyAddr: TEdit;
   Label3: TLabel;
   edExtProxyPort: TEdit;
   procedure bnStartClick(Sender: TObject);
   procedure FormCreate(Sender: TObject);
 private
   { Private declarations }
 public
   { Public declarations }
 end;

var
 HTTPProxyForm: THTTPProxyForm;

implementation

uses ServerThreadUnit;

{$R *.dfm}

procedure THTTPProxyForm.bnStartClick(Sender: TObject);
var
st:TServerThread;
begin
st:=TServerThread.Create(true);
st.iLocalPort:=StrToIntDef(edPort.Text, 8088);
st.iExtProxyPort:=StrToIntDef(edExtProxyPort.Text, 8080);
st.sExtProxyAddr:=edExtProxyAddr.Text;
st.Resume;
end;

procedure THTTPProxyForm.FormCreate(Sender: TObject);
var
wData : WSADATA;
begin
// Загрузка WinSock
if WSAStartup(MAKEWORD(1,1), wData) <> 0 then
begin
  MessageBox(0, 'Не могу загрузить WinSock', 'Ошибка', 0);
  exit;
end;
end;

end.

unit ServerThreadUnit;

interface

uses
 Classes, winsock, windows;

type
 TServerThread = class(TThread)
 private
   { Private declarations }
 protected
   procedure Execute; override;
 public
  iLocalPort, iExtProxyPort:Integer;
  sExtProxyAddr:String;
 end;

implementation

uses ClientThreadUnit;

procedure TestWinSockError(S:String);
var
iErr:Integer;
sFullErr:String;
begin
sFullErr:='Неизвестная ошибка';
iErr:=WSAGetLastError();

case iErr of
 WSANOTINITIALISED: sFullErr:='Нужно сначала вызвать функцию WSASturtup, а потом создавать сокет';
WSAENETDOWN: sFullErr:='Cвязь нарушена, возможные причины - отошёл кабель или отключились от Интернета';
WSAEADDRINUSE: sFullErr:='Указанный адрес уже используется';
WSAEFAULT: sFullErr:='Параметры name и namelen не соответствуют выбранной адресации. Параметр namelen может быть меньше необходимого значения, а name содержать некорректные данные';
WSAEINPROGRESS: sFullErr:='Выполняется операция в блокирующем режиме. Вы уже запустили на выполнение какую-то функцию и нужно дождаться завершения её работы';
WSAEINVAL: sFullErr:='Сокет уже связан с адресом';
WSAENOBUFS: sFullErr:='Недостаточно буферов, слишком много соединений';
WSAENOTSOCK: sFullErr:='Неверный дескриптор сокета';
 WSAEISCONN: sFullErr:='Сокет уже подключён';
 WSAEMFILE: sFullErr:='Нет больше доступных дескрипторов';
end;

MessageBox(0, PChar('Ошибка в функции '+S+' - '+sFullErr), 'Ошибка', 0);
end;

function TestFuncError(iErr:Integer; FuncName:String):Boolean;
begin
Result:=false;
if iErr = SOCKET_ERROR then
 begin
  TestWinSockError(FuncName);
  Result:=true;
 end;
end;

procedure TServerThread.Execute;
var
sServerListen, stClientSocket : TSOCKET;
localaddr : sockaddr_in;
ct : TClientThread;
begin
// Создание сокета
sServerListen := socket(AF_INET, SOCK_STREAM, 0);
if sServerListen = INVALID_SOCKET then
 begin
  MessageBox(0, 'Ошибка создания сокета', 'Ошибка', 0);
  exit;
 end;

// Запонение структуры адреса
localaddr.sin_addr.s_addr := htonl(INADDR_ANY);
localaddr.sin_family := AF_INET;
localaddr.sin_port := htons(iLocalPort);

// Связывание сокета с локальным адресом
if TestFuncError(bind(sServerListen, localaddr, sizeof(localaddr)), 'bind') then
 exit;

if TestFuncError(listen(sServerListen, 4), 'Listen') then
 exit;

while true do
 begin
  stClientSocket := accept(sServerListen, nil, nil);
  if stClientSocket=INVALID_SOCKET then
   continue;

  ct:=TClientThread.Create(true);
  ct.stClient := stClientSocket;
  ct.iExtProxyPort := iExtProxyPort;
  ct.sExtProxyAddr := sExtProxyAddr;
  ct.Resume;
 end;
end;

end.

unit ClientThreadUnit;

interface

uses
 Classes, winsock, sysutils, windows;

type
 TClientThread = class(TThread)
 private
   { Private declarations }
 protected
   procedure Execute; override;
 public
   iExtProxyPort:Integer;
   sExtProxyAddr:String;
   stClient:TSocket;
 end;

implementation

{ TClientThread }

function LookupName(name:String): TInAddr;
var
HostEnt: PHostEnt;
InAddr: TInAddr;
begin
if name[4]='.' then
 InAddr.s_addr := inet_addr(PChar(name))
else
 begin
 HostEnt := gethostbyname(PChar(name));
 FillChar(InAddr, SizeOf(InAddr), 0);
 if HostEnt <> nil then
  begin
   with InAddr, HostEnt^ do
    begin
     S_un_b.s_b1 := h_addr^[0];
     S_un_b.s_b2 := h_addr^[1];
     S_un_b.s_b3 := h_addr^[2];
     S_un_b.s_b4 := h_addr^[3];
    end;
  end
 end;
 Result := InAddr;
end;

procedure SendStr(s:TSocket; str:String);
var
sRecvBuff : array [0..255] of char;
TempStr : AnsiString;
begin
TempStr:=str+#13+#10;
CopyMemory(@sRecvBuff, PChar(TempStr), Length(TempStr));
send(s, sRecvBuff, Length(TempStr), 0);
end;

procedure TClientThread.Execute;
var
Buff: array [0..1024] of char;
iPort: Integer;
sRequest, sHost:String;
server_addr : sockaddr_in;
sock_server : TSocket;
iMode, iSize : Integer;
rfds : TFDSET;
begin
////////////////////////////
//Считывание заголовка
Recv(stClient, Buff, 1024, 0);

sRequest:=String(Buff);

// Нет заголовка
if sRequest='' then
 begin
  CloseSocket(stClient);
  exit;
 end;

////////////////////////////
// Выдераем адрес сервера и порт
sHost:=Copy(sRequest, Pos('Host: ', sRequest), 255);
Delete(sHost, Pos(#13, sHost), 255);
Delete(sHost, 1, 6);
iPort:=StrToIntDef(Copy(sHost, Pos(':', sHost)+1, 255), 80);
Delete(sHost, Pos(':', sHost), 255);

// Если не найден host то ошибка
if sHost='' then
 begin
  SendStr(stClient, 'HTTP/1.0 400 Invalid header received from browser');
  CloseSocket(stClient);
  exit;
 end;

// Если есть внешний проксик, то перенаправляем на него
if sExtProxyAddr<>'' then
 begin
   iPort := iExtProxyPort;
   sHost := sExtProxyAddr;
 end;

sock_server := socket(AF_INET, SOCK_STREAM, 0);

// Ищем сервер/проксик
server_addr.sin_addr.s_addr := htonl(INADDR_ANY);
server_addr.sin_family := AF_INET;
server_addr.sin_port := htons(iPort);
server_addr.sin_addr := LookupName(sHost);

//Соединение с сервером
if connect(sock_server, server_addr, sizeof(server_addr))=SOCKET_ERROR then
 begin
  SendStr(stClient, '404 Host Not Found');
  exit;
 end;

iMode:=1;
setsockopt(sock_server, IPPROTO_TCP, TCP_NODELAY, @iMode, sizeof (integer));

// Перенаправляем запрос серверу или другому проксику
send(sock_server, buff, strlen(buff),0);

// Теперь работаем посредником между клиентом и сервером
// передавая запрошенные данные
while true do
 begin
  // Добавляем сокеты в набор для ожидания
  FD_ZERO(rfds);
  FD_SET(stClient, rfds);
  FD_SET(sock_server, rfds);

  if (select(0, @rfds, nil, nil, nil) < 0) then
   exit;

  // Если пришел запрос от клиента
  // то перенаправляем серверу
  if(FD_ISSET(stClient, rfds)) then
 begin
  iSize := recv(stClient, buff, sizeof(buff), 0);

     if iSize=-1 then break;

  Send(sock_server, buff, iSize, 0);
  continue;
 end;

  // Если пришли данные от сервера
  // то перенаправляем клиенту
  if(FD_ISSET(sock_server, rfds)) then
 begin
  iSize := recv(sock_server, buff, sizeof(buff), 0);

     // Сервер уже всё выслал
     if iSize=0 then
      exit;

  Send(stClient, buff, iSize, 0);
  continue;
 end;
 end;
CloseSocket(stClient);
CloseSocket(sock_server);
end;

end.

object HTTPProxyForm: THTTPProxyForm
 Left = 260
 Top = 107
 BorderStyle = bsSingle
 Caption = 'Proxy'
 ClientHeight = 145
 ClientWidth = 314
 Color = clBtnFace
 Font.Charset = DEFAULT_CHARSET
 Font.Color = clWindowText
 Font.Height = -11
 Font.Name = 'MS Sans Serif'
 Font.Style = []
 OldCreateOrder = False
 OnCreate = FormCreate
 PixelsPerInch = 96
 TextHeight = 13
 object Label1: TLabel
   Left = 8
   Top = 16
   Width = 25
   Height = 13
   Caption = #1055#1086#1088#1090
 end
 object Label2: TLabel
   Left = 8
   Top = 80
   Width = 105
   Height = 13
   Caption = #1040#1076#1088'. '#1074#1085#1077#1096'. '#1087#1088#1086#1082#1089#1080#1082#1072
 end
 object Label3: TLabel
   Left = 8
   Top = 48
   Width = 108
   Height = 13
   Caption = #1055#1086#1088#1090' '#1074#1085#1077#1096'. '#1087#1088#1086#1082#1089#1080#1082#1072
 end
 object bnStart: TButton
   Left = 120
   Top = 112
   Width = 75
   Height = 25
   Caption = #1047#1072#1087#1091#1089#1082
   TabOrder = 0
   OnClick = bnStartClick
 end
 object edPort: TEdit
   Left = 128
   Top = 16
   Width = 177
   Height = 21
   TabOrder = 1
   Text = '8080'
 end
 object edExtProxyAddr: TEdit
   Left = 128
   Top = 80
   Width = 177
   Height = 21
   TabOrder = 3
   Text = '192.168.8.88'
 end
 object edExtProxyPort: TEdit
   Left = 128
   Top = 48
   Width = 177
   Height = 21
   TabOrder = 2
   Text = '8080'
 end
end

program proxy;

{$APPTYPE CONSOLE}

{%TogetherDiagram 'ModelSupport_proxy\default.txaPackage'}

uses
SysUtils,
Windows,
Winsock,
Classes;

type
TCompletionPort=class
public
 FHandle:THandle;
 constructor Create(dwNumberOfConcurentThreads:DWORD);
 destructor Destroy;override;
 function AssociateDevice(hDevice:THandle;dwCompKey:DWORD):boolean;
end;

TAcceptThread=class(TThread)
private
 FListenSocket:TSocket;
 FListenPort:Word;
 FClientList:TList;
 procedure GarbageCollect;
protected
 procedure Execute;override;
public
 constructor Create(AListenPort:Word);reintroduce;
 destructor Destroy;override;
end;

type
TClientThread=class(TThread)
public
 procedure Execute;override;
end;

type
TClient=class
private
 FSocket:TSocket;
 FEvent:THandle;
 ov:POVERLAPPED;
 Buffer:Pointer;
 BufSize:Cardinal;
 procedure Write(Buf:Pointer;Size:Cardinal);
public
 FOppositeClient:TClient;
 FLastActivity:double;
 constructor Create;
 destructor Destroy;override;
 procedure Connect(ARequest:string);
 procedure Disconnect;
 procedure Complete(dwNumBytes:Cardinal);virtual;abstract;
end;

TInternalClient=class(TClient)
public
 procedure Complete(dwNumBytes:Cardinal);override;
end;

TExternalClient=class(TClient)
public
 procedure Complete(dwNumBytes:Cardinal);override;
end;

//-------------------------------implementation-------------------------------

var
 FCompPort:TCompletionPort;

{ TCompletionPort }

constructor TCompletionPort.Create(dwNumberOfConcurentThreads: DWORD);
begin
 FHandle:=CreateIoCompletionPort(INVALID_HANDLE_VALUE,0,0,dwNumberOfConcurentThre ads);
end;

function TCompletionPort.AssociateDevice(hDevice: THandle;
 dwCompKey: DWORD): boolean;
begin
result:=CreateIoCompletionPort(hDevice,FHandle,dwCompKey,0)=FHandle;
end;

destructor TCompletionPort.Destroy;
begin
 CloseHandle(FHandle);
 inherited;
end;

{ TAcceptThread }

constructor TAcceptThread.Create(AListenPort: Word);
begin
 inherited Create(false);
FListenPort:=AListenPort;
 FClientList:=TList.Create;
end;

destructor TAcceptThread.Destroy;
begin
 FClientList.Free;
 inherited;
end;

procedure TAcceptThread.GarbageCollect;
var
 AClient:TClient;
i:integer;
begin
for i:=0 to FClientList.Count-1 do
 begin
   AClient:=TClient(FClientList[i]);
 if Assigned(AClient) then
  if (AClient.FSocket=INVALID_SOCKET) and ((now-AClient.FLastActivity)>7E-4) then
  begin
   FClientList[i]:=nil;
   if Assigned(AClient.FOppositeClient) then AClient.FOppositeClient.Free;
   AClient.Free;
  end;
end;
FClientList.Pack;
FClientList.Capacity:=FClientList.Count;
end;

procedure TAcceptThread.Execute;
var
FAddr: TSockAddrIn;
Len: Integer;
ClientSocket:TSocket;
InternalClient:TClient;
begin
FListenSocket := socket(PF_INET, SOCK_STREAM, IPPROTO_TCP);
FAddr.sin_family := PF_INET;
FAddr.sin_addr.s_addr := INADDR_ANY;
FAddr.sin_port := htons(FListenPort);
bind(FListenSocket, FAddr, SizeOf(FAddr));
listen(FListenSocket, SOMAXCONN);

try
 while not Terminated do
 begin
  Len:=sizeof(FAddr);
  ClientSocket:=accept(FListenSocket, @FAddr, @Len);
  try
   GarbageCollect;
   if ClientSocket<>INVALID_SOCKET then
   begin
    InternalClient:=TInternalClient.Create;
    InternalClient.FSocket:=ClientSocket;
    FClientList.Add(InternalClient);
    FCompPort.AssociateDevice(InternalClient.FSocket,Cardinal(InternalClient));
    InternalClient.Complete(0);
   end;
  except
  end;
 end;
finally
 shutdown(FListenSocket,2);
 closesocket(FListenSocket);
end;
end;

{ TClientThread }

procedure TClientThread.Execute;
var
CompKey,dwNumBytes:Cardinal;
ov:POVERLAPPED;
begin
try
 while not Terminated do
 begin
  if GetQueuedCompletionStatus(FCompPort.FHandle,dwNumBytes,CompKey,ov,INFINITE) and (dwNumBytes>0) then
  begin
   if TClient(CompKey).FSocket<>INVALID_SOCKET then
   begin
    TClient(CompKey).Complete(dwNumBytes);
    TClient(CompKey).FLastActivity:=now;
   end;
  end
  else
   TClient(CompKey).Disconnect;
 end;
except
 TClientThread.Create(false);
 end;
end;

{ TClient }

constructor TClient.Create;
begin
FSocket:=INVALID_SOCKET;
BufSize:=8192;
GetMem(Buffer,BufSize);
new(ov);
ov.Internal:=0;
ov.InternalHigh:=0;
ov.Offset:=0;
ov.OffsetHigh:=0;
ov.hEvent:=0;
FEvent:=CreateEvent(nil,true,false,nil);
FLastActivity:=now;
end;

destructor TClient.Destroy;
begin
Disconnect;
CloseHandle(FEvent);
FreeMem(Buffer);
Dispose(ov);
inherited;
end;

procedure TClient.Connect(ARequest: string);
var
f,t:integer;
ARemoteAddress:string;
ARemotePort:string;
he:PHostEnt;
FAddr:TSockAddrIn;
begin
f:=Pos('/',ARequest)+2;
t:=Pos('HTTP',ARequest)-1;
ARemoteAddress:=Copy(ARequest,f,t-f);
t:=Pos('/',ARemoteAddress);
if t<>0 then ARemoteAddress:=Copy(ARemoteAddress,0,t-1);
t:=Pos(':',ARemoteAddress);
if t<>0 then
begin
 ARemotePort:=Copy(ARemoteAddress,t+1,Length(ARemoteAddress)-t);
 ARemoteAddress:=Copy(ARemoteAddress,0,t-1);
 end
else
   ARemotePort:='80';

 he:=GetHostByName(PChar(ARemoteAddress));
 if not Assigned(he) then exit;
 ARemoteAddress:=inet_ntoa(PInAddr(he.h_addr_list^)^);

 FSocket:=socket(PF_INET, SOCK_STREAM, IPPROTO_IP);
FAddr.sin_family:=PF_INET;
 FAddr.sin_addr.s_addr :=inet_addr(PChar(ARemoteAddress));
 try
   FAddr.sin_port := htons(StrToInt(ARemotePort));
 if WinSock.connect(FSocket, FAddr, SizeOf(FAddr))=SOCKET_ERROR then FSocket:=INVALID_SOCKET;
except
 end;
end;

procedure TClient.Disconnect;
begin
if FSocket<>INVALID_SOCKET then
begin
 shutdown(FSocket,2);
 closesocket(FSocket);
 FSocket:=INVALID_SOCKET;
 if Assigned(FOppositeClient) then FOppositeClient.Disconnect;
end;
end;

procedure TClient.Write(Buf: Pointer; Size: Cardinal);
var
BytesWrite:Cardinal;
begin
ov.hEvent:=FEvent or 1;
WriteFile(FSocket,Buf^,Size,BytesWrite,ov);
ov.hEvent:=0;
end;

{ TInternalClient }

procedure TInternalClient.Complete(dwNumBytes: Cardinal);
var
BytesRead:Cardinal;
begin
if dwNumBytes>0 then
begin
 if not Assigned(FOppositeClient) then
 begin
  FOppositeClient:=TExternalClient.Create;
  FOppositeClient.FOppositeClient:=self;
  FOppositeClient.Connect(PChar(Buffer));
  if FOppositeClient.FSocket=INVALID_SOCKET then
  begin
   Disconnect;
   exit;
  end;
  FCompPort.AssociateDevice(FOppositeClient.FSocket,Cardinal(FOppositeClient));
  FOppositeClient.Complete(0);
 end;
 FOppositeClient.Write(Buffer,dwNumBytes);
end;
ReadFile(FSocket,Buffer^,BufSize,BytesRead,ov);
end;

{ TExternalClient }

procedure TExternalClient.Complete(dwNumBytes: Cardinal);
var
BytesRead:Cardinal;
begin
if dwNumBytes>0 then FOppositeClient.Write(Buffer,dwNumBytes);
ReadFile(FSocket,Buffer^,BufSize,BytesRead,ov);
end;

const
ClientThreadCount:integer=10;
ListenPort:Dword=8080;

var
WSAData:TWSAData;
Cnt:Cardinal;
i:integer;
begin
FCompPort:=TCompletionPort.Create(ClientThreadCount);
if FCompPort.FHandle<>0 then
begin
   WSAStartup($0101, WSAData);
   for i:=0 to ClientThreadCount-1 do TClientThread.Create(false);
   TAcceptThread.Create(ListenPort);
   ReadConsole(GetStdHandle(STD_INPUT_HANDLE),nil,0,Cnt,nil);
   WSACleanup;
 end;
end.

 LWrite('Prepare to work:',FOREGROUND_GREEN or FOREGROUND_INTENSITY,0);
 Writeln('');
 LWrite('=======================',FOREGROUND_GREEN or FOREGROUND_INTENSITY,0);
 Writeln('');
 LWrite('Create main socket:',FOREGROUND_RED or FOREGROUND_INTENSITY,0);
 FCompPort:=TCompletionPort.Create(ClientThreadCount);
 LWrite(' Ok',FOREGROUND_RED or FOREGROUND_INTENSITY,0);
 Writeln('');
 if FCompPort.FHandle<>0 then begin
   LWrite('Initialise:',FOREGROUND_RED or FOREGROUND_INTENSITY,0);
   WSAStartup($0101, WSAData);
   LWrite(' Ok',FOREGROUND_RED or FOREGROUND_INTENSITY,0);
   Writeln('');
   LWrite('Create main threads:',FOREGROUND_RED or FOREGROUND_INTENSITY,0);
   for i:=0 to ClientThreadCount-1 do TClientThread.Create(false);
   TAcceptThread.Create(ListenPort);
   LWrite(' Ok',FOREGROUND_RED or FOREGROUND_INTENSITY,0);
   Writeln('');
   LWrite('=======================',FOREGROUND_GREEN or FOREGROUND_INTENSITY,0);
   Writeln('');
   LWrite('Proxy activate',FOREGROUND_GREEN or FOREGROUND_INTENSITY,0);
   Writeln('');
   LWrite('=======================',FOREGROUND_GREEN or FOREGROUND_INTENSITY,0);
   Writeln('');
   repeat
     ReadConsole(GetStdHandle(STD_INPUT_HANDLE),@Buff,10,Cnt,nil);
     ConsoleText := String(Buff);
   until UpperCase(Copy(ConsoleText,1,4)) = 'EXIT';
   WSACleanup;
 end;