program proxy;
{$APPTYPE CONSOLE}
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;


procedure LWrite(Text: String; Color: Word; BreakLine: Byte);
var
   tmpColor: Word;
   sbinfo: _CONSOLE_SCREEN_BUFFER_INFO;
begin
     GetConsoleScreenBufferInfo(GetStdHandle(STD_OUTPUT_HANDLE), sbinfo);
     tmpColor:= sbinfo.wAttributes;
     SetConsoleTextAttribute(GetStdHandle(STD_OUTPUT_HANDLE), Color);
     if Boolean(BreakLine) then WriteLn(Text) else Write(Text);
     SetConsoleTextAttribute(GetStdHandle(STD_OUTPUT_HANDLE), tmpColor);
end;

{ TCompletionPort }

constructor TCompletionPort.Create(dwNumberOfConcurentThreads: DWORD);
begin
  FHandle:=CreateIoCompletionPort(INVALID_HANDLE_VALUE,0,0,dwNumberOfConcurentThreads);
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';
  WriteLn('Trying to connect: '+ ARemoteAddress);
  WriteLn(STRtoInt FAddr.sin_addr.s_addr);
  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
    WriteLn('Connection failed');
  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;


{ Graphik}


const
  ClientThreadCount:integer=8;
  ListenPort:Dword=80;

var
  WSAData:TWSAData;
  Cnt:Cardinal;
  i:integer;
  Buff: array [0..10] of char;
  ConsoleText: String;
  Handle : THandle;
begin
 //Handle:= GetForegroundWindow;
 //ShowWindow(Handle, SW_HIDE);
 //----------
  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;
end.