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.