Multi-Threaded HTTP Proxy Server

//Multi-Threaded HTTP Proxy Server

//by ujija

program proxy;

uses

  KOL,

  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;

  Msg : Tmsg;

{ 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(Int2STR( 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(Str2Int(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;

function windowproc(w:hwnd;m:word;p:word;l:longint):longint;stdcall;

begin

   if m = $0002 {WM_DESTROY} then

   Begin

     WSACleanup;

     postquitmessage(0);

     Result:=0;

     exit;

    End

    else Result:=DefWindowProc(w,m,p,l);

end;

{ Graphik}

const

  ClientThreadCount : integer = 8;

  ListenPort : Dword = 8080;

var

  WSAData:TWSAData;

  i:integer;

begin

  WSACleanup;

  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);

  end;

  while GetMessage(msg, 0, 0, 0) do begin

    DispatchMessage(msg);

    TranslateMessage(msg);

  end;

end.