{:Generic non-caching HTTP/1.0 and HTTPS proxy component. Uses Francois Piette's ICS suite
(http://www.overbyte.be/). Based on the work of Wilfried Mestdagh.
Latest version of this component can always be found at
http://gp.17slon.com/gp/tgphttpproxy.htm.
Thanks to: Wilfried Mestdagh, Miha Remec, Stanislav Korotky, Brian Milburn
@author Primoz Gabrijelcic, gabr@17slon.com, http://17slon.com/gp
@desc <pre>
This software is distributed under the BSD license.
Copyright (c) 2004, Primoz Gabrijelcic
All rights reserved.
Redistribution and use in source and binary forms, with or without modification,
are permitted provided that the following conditions are met:
- Redistributions of source code must retain the above copyright notice, this
list of conditions and the following disclaimer.
- Redistributions in binary form must reproduce the above copyright notice,
this list of conditions and the following disclaimer in the documentation
and/or other materials provided with the distribution.
- The name of the Primoz Gabrijelcic may not be used to endorse or promote
products derived from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR
ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Author : Primoz Gabrijelcic
Version : 2.0
Creation date : 2000-03-08
Last modification : 2004-03-17
</pre>}{
Version history:
2.0: 2004-03-17
- Pulled in modifications from another (commercial) project to implement some fixes
in HTTP proxy and add HTTPS proxy support.
1.02: 2001-11-07
- Added 'Host:' header processing.
- Modified OnClientHeaderAvailable event to accept additional parameter -
value of the Host: header.
Thanks to the Stanislav Korotky for pointing out the problem.
- Added OPTIONS request processing.
1.01c: 2001-10-17
- Bug fixes in next-hop-proxy handling and in username:password handling.
1.01b: 2001-02-01
- Fixed incompatibility between bugfix introduced in 1.01a and
caching/blocking functionality introduced in 1.01.
1.01a: 2001-01-30
- Bug fixed: connection was sometimes (still) closed too early (thanks to
Wilfried Mestdagh for the fix).
- Bug fixed: result of TGpHTTPProxy.Listen was not always initialized.
1.01: 2001-01-29
- Completely rewritten OnClientHeaderAvailable event now supports caching,
blocking, and redirecting (see info in TProxyHeaderEvent,
TGpHTTPProxy.ProcessHeader, and demo application).
- New event OnRemoteSocketPrepared is called from the same place as
OnClientHeaderAvailable was called before.
- New event OnRemoteDNSLookupDone.
- Property TGpHTTPProxy.ClientCount is now decremented *before*
OnClientDisconnect event handler is called.
- Bug fixed: connection was sometimes closed too early (thanks to Miha
Remec for the fix).
1.0a: 2000-03-14
- Small fix to enable app to close without calling TGpHTTPProxy.Close
first.
1.0: 2000-03-13
- First release.
What's missing:
- A method to connect to external page cache.
- A method to connect to external DNS cache.
- An event to redirect data query.
}
{$IFNDEF MSWindows}{$IFDEF Win32}{$DEFINE MSWindows}{$DEFINE OldDelphi}{$ENDIF Win32}{$ENDIF MSWindows}
unit GpHTTPProxy;
interface
uses
Windows,
Messages,
Forms,
ExtCtrls,
WinSock,
WSocket,
WSockets,
SysUtils,
Classes,
Contnrs,
GpIPSec,
GpProxyData;
const
{:Default 'HTTP proxy closed' response.}
CHTTPClosed =
'HTTP/1.1 403 Closed'#13#10+
'Connection: close'#13#10+
'Content-Type: text/html'#13#10#13#10+
'<HTML><HEAD>'#13#10+
'<TITLE>Closed</TITLE>'#13#10+
'</HEAD><BODY>'#13#10+
'<H1>Closed</H1>'#13#10+
'HTTP proxy is closed.<P>'#13#10+
'</BODY></HTML>'#13#10;
{:Default 'URL blocked' response.}
CHTTPBlocked =
'HTTP/1.1 403 Forbidden'#13#10+
'Connection: close'#13#10+
'Content-Type: text/html'#13#10#13#10+
'<HTML><HEAD>'#13#10+
'<TITLE>Blocked</TITLE>'#13#10+
'</HEAD><BODY>'#13#10+
'<H1>Blocked</H1>'#13#10+
'You are not allowed to access this URL.<P>'#13#10+
'</BODY></HTML>'#13#10;
{:Default 'HTTP error - Bad request' response.}
CHTTPBadRequest =
'HTTP/1.1 400 Bad request'#13#10+
'Connection: close'#13#10+
'Content-Type: text/html'#13#10#13#10+
'<HTML><HEAD>'#13#10+
'<TITLE>Bad request</TITLE>'#13#10+
'</HEAD><BODY>'#13#10+
'<H1>Bad request</H1><P>'#13#10+
'</BODY></HTML>'#13#10;
{:Default 'HTTP error - Forbidden IP' response.}
CHTTPIPForbidden =
'HTTP/1.1 403 Forbidden'#13#10+
'Connection: close'#13#10+
'Content-Type: text/html'#13#10#13#10+
'<HTML><HEAD>'#13#10+
'<TITLE>Forbidden</TITLE>'#13#10+
'</HEAD><BODY>'#13#10+
'<H1>Forbidden</H1>'#13#10+
'You are not allowed to access the proxy from this IP address<P>'#13#10+
'</BODY></HTML>'#13#10;
{:Default 'TCP Tunnel established' response.}
CTcpTunnelEstablished =
'HTTP/1.0 200 Connection established'#13#10#13#10;
{:Default 'TCP Tunnel proxy closed' response.}
CTcpTunnelClosed =
'HTTP/1.0 403 Closed'#13#10+
'Connection: close'#13#10#13#10;
{:Default 'TCP Tunnel connection blocked' response.}
CTcpTunnelBlocked =
'HTTP/1.0 403 Forbidden'#13#10+
'Connection: close'#13#10#13#10;
{:Default 'TCP Tunnel error - bad request' response.}
CTcpTunnelBadRequest=
'HTTP/1.0 400 Bad request'#13#10+
'Connection: close'#13#10#13#10;
{:Default 'TCP Tunnel connection forbidden' response.}
CTcpTunnelIPForbidden =
'HTTP/1.0 403 Forbidden'#13#10+
'Connection: close'#13#10#13#10;
type
{:All supported proxy types.
}
TGpProxyType = (ptHTTP, ptTCPTunnel);
{:Set of all supported proxy types.
}
TGpProxyTypes = set of TGpProxyType;
{:Configurable HTTP & TCP Tunnel proxy responses.
}
TGpProxyStrings = class(TPersistent)
private
FStrings: array [1..9] of TStrings;
protected
function GetString(const Index: Integer): TStrings; virtual;
procedure SetString(const Index: Integer; const Value: TStrings); virtual;
public
constructor Create;
destructor Destroy; override;
procedure Assign(Source: TPersistent); override;
published
{:'HTTP proxy closed' response.}
property sHTTPClosed: TStrings index 1 read GetString write SetString;
{:'URL blocked' response.}
property sHTTPBlocked: TStrings index 2 read GetString write SetString;
{:'HTTP error - bad request' response.}
property sHTTPBadRequest: TStrings index 3 read GetString write SetString;
{:'HTTP error - IP forbidden' response.}
property sHTTPIPForbidden: TStrings index 4 read GetString write SetString;
{:'TCP Tunnel established' response.}
property sTCPTunnelEstablished: TStrings index 5 read GetString write SetString;
{:'TCP Tunnel proxy closed' response.}
property sTCPTunnelClosed: TStrings index 6 read GetString write SetString;
{:'TCP Tunnel connection blocked' response.}
property sTCPTunnelBlocked: TStrings index 7 read GetString write SetString;
{:'TCP Tunnel error - bad request' response.}
property sTCPTunnelBadRequest: TStrings index 8 read GetString write SetString;
{:'TCP Tunnel error - IP forbidden' response.}
property sTCPTunnelIPForbidden: TStrings index 9 read GetString write SetString;
end; { TGpProxyStrings }
TGpProxyClient = class;
{:Client socket class. Instance of this class is passed as an argument in
various TGpHttpProxy events. To turn off the logging for that instance,
set the Logging property to False in the event handler. This will disable
TGpHttpProxy.OnClientDataAvailable and TGpHttpProxy.OnRemoteDataAvailable
handler for this instance.
}
TGpProxyClient = class(TWSocketClient)
private
FAborted : boolean;
FCanCloseNow : boolean;
FGotHeader : boolean;
FGotRespHeader: boolean;
FLastSendTime : int64;
FLogging : boolean;
FOnDone : TNotifyEvent;
FPassword : string;
FPeerAddrLong : u_long;
FProxyType : TGpProxyType;
FRcvd : string;
FRemoteContent: string;
FRemoteRcvd : string;
FRemoteSocket : TWSocket;
FSendBuffer : string;
FUsername : string;
FUsingNextHop : boolean;
protected
procedure CreateRemoteSocket; virtual;
procedure DestroyRemoteSocket; virtual;
procedure DoDataSent(sender: TObject; error: word); virtual;
procedure DoSessionClosed(sender: TObject; error: word); virtual;
procedure Kill;
procedure SetProxyType(proxyType: TGpProxyType); virtual;
procedure Stop(errorCode: integer);
procedure Stop2;
procedure TriggerDataSent(error: word); override;
function TrySendFromBuffer: integer; virtual;
{properties}
{:Indicates that socket is shutting down.}
property Aborted: boolean read FAborted;
{:Indicates whether socket should be closed when all data will be sent.}
property CanCloseNow: boolean read FCanCloseNow write FCanCloseNow;
{:True when HTTP header was completely received.}
property GotHeader: boolean read FGotHeader write FGotHeader;
{:True when TCP Tunnel response from the remote machine was received.}
property GotResponseHeader: boolean read FGotRespHeader write FGotRespHeader;
{:Time (ticks) when last data was sent to the client.}
property LastSendTime: int64 read FLastSendTime write FLastSendTime;
{:Password for the remote site.}
property Password: string read FPassword write FPassword;
{:PeerAddr converted to u_long.}
property PeerAddrLong: u_long read FPeerAddrLong write FPeerAddrLong;
{:Received (but not yet processed) data.}
property Received: string read FRcvd write FRcvd;
{:Fake content that should be returned instead of the true content (HTTP proxy).}
property RemoteContent: string read FRemoteContent write FRemoteContent;
{:Received from the remote.}
property RemoteReceived: string read FRemoteRcvd write FRemoteRcvd;
{:Username for the remote site.}
property Username: string read FUsername write FUsername;
{:True if next-hop proxy is used.}
property UsingNextHop: boolean read FUsingNextHop write FUsingNextHop;
{:Triggered when client has terminated.}
property OnDone: TNotifyEvent read FOnDone write FOnDone;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function SendStr(const data: string): integer; override;
{properties}
{:Set to False to disable logging of this client socket.}
property Logging: boolean read FLogging write FLogging default true;
{:Type of this connection - HTTP proxy or TCP Tunnel proxy.}
property ProxyType: TGpProxyType read FProxyType;
{:Remote socket this client socket is connected to.}
property RemoteSocket: TWSocket read FRemoteSocket;
end; { TGpProxyClient }
{:TGpProxyClient class reference type.
}
TGpProxyClientClass = class of TGpProxyClient;
{:Generic proxy event - on connect, on disconnect...
@param Sender Instance of TGpGenericProxy that generated the event.
@param Client Client socket.
}
TGpProxyEvent = procedure(sender: TObject; Client: TGpProxyClient) of object;
{:Data Available event.
@param Sender Instance of TGpGenericProxy that generated the event.
@param Client Client socket.
@param data Received data.
}
TGpProxyReceiveEvent = procedure(sender: TObject; Client: TGpProxyClient;
data: string) of object;
{:Header available event. Triggered after the header is received but before
connection to remote is established. Application can at that point modify
the target url, force next hop proxy to be ignored, or return appropriate
HTTP response.
@param Sender Instance of TGpHttpProxy that generated the event.
@param Client Client socket.
@param url Requested URL.
@param header HTTP request header. May be modified in event handler.
@param proto Protocol part of URL. May be modified in event handler.
@param user User part of URL. May be modified in event handler.
@param pass Password part of URL. May be modified in event handler.
@param host Host part of URL. May be modified in event handler.
@param path Path part of URL. May be modified in event handler.
@param hdrHost Contents of the Host: HTTP header line. May be modified in
event handler.
@param ignoreNextHopProxy False when event handler is called. If set to
true in event handler, next hop proxy will be ignored for
this request.
@param returnContent Empty when event handler is called. If set to some
value, no connection will be established and contents of
'returnContent' will be returned to the client socket. Use
to implement caching or blocking. If set, next hop proxy
will be ignored regardless of 'ignoreNextHopProxy' flag.
}
TGpProxyHeaderEvent = procedure(sender: TObject; Client: TGpProxyClient;
url: string; var header, proto, user, pass, host, port, path, hdrHost: string;
var ignoreNextHopProxy: boolean; var returnContent: string) of object;
{:Tunnel requested event. Triggered after the tunnel request header is
received but before the connection to remote host is established.
Application can at that point modify the target address and port, force next
hop proxy to be ignored, or return appropriate response.
@param Sender Instance of TGpHttpProxy that generated the event.
@param Client Client socket.
@param host Remote address. May be modified in event handler.
@param port Remote port. May be modified in event handler.
@param ignoreNextHopProxy False when event handler is called. If set to
true in event handler, next hop proxy will be ignored for
this request.
@param returnContent Empty when event handler is called. If set to some
value, no connection will be established and contents of
'returnContent' will be returned to the client socket. Use
to implement caching or blocking. If set, next hop proxy
will be ignored regardless of 'ignoreNextHopProxy' flag.
}
TGpProxyTunnelRequestEvent = procedure(sender: TObject;
Client: TGpProxyClient; var host, port: string;
var ignoreNextHopProxy: boolean; var returnContent: string) of object;
{:Debug log event
@since 2003-09-21
}
TGpProxyDebugLogEvent = procedure(sender: TObject;
const logMessage: string) of object;
{:Server closed event.
@since 2004-01-08
}
TGpProxyServerClosedEvent = procedure(sender: TObject; error: word) of object;
{:Remote connection connected (or connection failed) event.
@since 2004-03-14
}
TGpProxyRemoteConnectEvent = procedure(sender: TObject;
socket: TGpProxyClient) of object;
{:Remote connection disconnected (or disconnection failed) event.
@since 2004-03-14
}
TGpProxyRemoteDisconnectEvent = procedure(sender: TObject;
socket: TGpProxyClient) of object;
{:Abstract class for all proxy components.
}
TGpGenericProxy = class(TComponent)
private
FActive : boolean;
FAllowedIP : TStrings;
FClientCount : integer;
FIPSec : TGpIPSec;
FLocalAddress : string;
FOnClientConnect : TGpProxyEvent;
FOnClientDataAvailable : TGpProxyReceiveEvent;
FOnClientDisconnect : TGpProxyEvent;
FOnDebugLog : TGpProxyDebugLogEvent;
FOnRemoteConnect : TGpProxyRemoteConnectEvent;
FOnRemoteDataAvailable : TGpProxyReceiveEvent;
FOnRemoteDisconnect : TGpProxyRemoteDisconnectEvent;
FOnRemoteDNSLookupDone : TGpProxyEvent;
FOnRemoteSocketPrepared: TGpProxyEvent;
FOnServerClosed : TGpProxyServerClosedEvent;
FOnServerListening : TNotifyEvent;
FPort : integer;
FWSocketServer : TWSocketServer;
protected
procedure AllowedIPChanged(sender: TObject); virtual;
procedure BgException(sender: TObject; E: Exception; var CanClose: Boolean); virtual;
procedure CloseSocketServer; virtual;
procedure DoClientConnect(Client: TGpProxyClient); virtual;
procedure DoClientDataAvailable(Client: TGpProxyClient; data: string); virtual;
procedure DoClientDisconnect(Client: TGpProxyClient); virtual;
procedure DoOnDebugLog(const logMessage: string); virtual;
procedure DoRemoteConnect(Client: TGpProxyClient); virtual;
procedure DoRemoteDataAvailable(Client: TGpProxyClient; data: string); virtual;
procedure DoRemoteDisconnect(Client: TGpProxyClient); virtual;
procedure DoRemoteDNSLookupDone(Client: TGpProxyClient); virtual;
procedure DoRemoteSocketPrepared(Client: TGpProxyClient); virtual;
procedure DoServerClosed(error: word); virtual;
procedure DoServerListening; virtual;
function GetClientClass: TGpProxyClientClass; virtual;
procedure HookRemoteEvents(RemoteSocket: TWSocket); virtual;
procedure InternalClose(Client: TGpProxyClient); virtual;
function OpenSocketServer: string; virtual;
procedure ProxyClientDataAvailable(sender: TObject; error: word); virtual;
procedure RemoteDnsLookupDone(sender: TObject; error: word); virtual;
procedure RemoteSessionClosed(sender: TObject; error: word); virtual;
procedure SendText(socket: TWSocket; data: string); virtual;
procedure SetAllowedIP(const Value: TStrings); virtual;
procedure SetClientClass(const Value: TGpProxyClientClass); virtual;
procedure SetLocalAddress(const Value: string); virtual;
procedure SetPort(const Value: integer); virtual;
procedure WSocketServerClientConnect(sender: TObject; Client: TWSocketClient; error: word); virtual;
procedure WSocketServerClientCreate(sender: TObject; Client: TWSocketClient); virtual;
procedure WSocketServerClientDisconnect(sender: TObject; Client: TWSocketClient; error: word); virtual;
procedure WSocketServerSessionClosed(sender: TObject; error: word); virtual;
// procedure WSocketServerSessionConnected(sender: TObject; error: word); virtual;
{abstract}
procedure ReceivedFromClient(Client: TGpProxyClient; clientData: string); virtual; abstract;
procedure RemoteDataAvailable(sender: TObject; error: word); virtual; abstract;
procedure RemoteSessionConnected(sender: TObject; error: word); virtual; abstract;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Close; virtual;
function Listen: string; virtual;
{properties}
{:True if proxy is listening.}
property Active: boolean read FActive;
{:TGpProxyClient derived class to instantiate for each client. Can be
set only when proxy is not Active.}
property ClientClass: TGpProxyClientClass read GetClientClass write SetClientClass;
{:Access to underlying TWSocketServer.}
property SocketServer: TWSocketServer read FWSocketServer;
{published}
{:List of the IP addresses allowed to access the proxy. Each line should
contain:
- string 'localhost' (macro for all server IP addresses)
- host name 'my.host.com'
- IP address 'xxx.yyy.www.zzz'
- IP address + mask 'xxx.yyy.www.zzz/nnn.nnn.nnn.nnn'}
property AllowedIP: TStrings read FAllowedIP write SetAllowedIP;
{:Number of connected clients.}
property ClientCount: integer read FClientCount;
{:Local address. Default = '' meaning 'bind to anything'.}
property LocalAddress: string read FLocalAddress write SetLocalAddress;
{:Listening port. Can be set only when proxy is not Active.}
property Port: integer read FPort write SetPort;
{events}
{:Triggered when client connects to proxy. Set Client socket parameters here.}
property OnClientConnect: TGpProxyEvent
read FOnClientConnect write FOnClientConnect;
{:Triggered when proxy receives data from client.}
property OnClientDataAvailable: TGpProxyReceiveEvent
read FOnClientDataAvailable write FOnClientDataAvailable;
{:Triggered when client disconnects from proxy.}
property OnClientDisconnect: TGpProxyEvent
read FOnClientDisconnect write FOnClientDisconnect;
{:Triggered when remote connects to proxy.}
property OnRemoteConnect: TGpProxyRemoteConnectEvent
read FOnRemoteConnect write FOnRemoteConnect;
{:Triggered when proxy receives data from remote.}
property OnRemoteDataAvailable: TGpProxyReceiveEvent
read FOnRemoteDataAvailable write FOnRemoteDataAvailable;
{:Triggered when remote disconnects from proxy.}
property OnRemoteDisconnect: TGpProxyRemoteDisconnectEvent
read FOnRemoteDisconnect write FOnRemoteDisconnect;
{:Triggered when DNS lookup on remote address is done.}
property OnRemoteDNSLookupDone: TGpProxyEvent
read FOnRemoteDNSLookupDone write FOnRemoteDNSLookupDone;
{:Triggered when remote socket is created but before it is connected. Event
handler can modify properties for Client.RemoteSocket at this point.}
property OnRemoteSocketPrepared: TGpProxyEvent
read FOnRemoteSocketPrepared write FOnRemoteSocketPrepared;
{:Triggered when server stops listening.}
property OnServerClosed: TGpProxyServerClosedEvent
read FOnServerClosed write FOnServerClosed;
{:Triggered when server starts listening.}
property OnServerListening: TNotifyEvent
read FOnServerListening write FOnServerListening;
published
//:Debug log.
property OnDebugLog: TGpProxyDebugLogEvent
read FOnDebugLog write FOnDebugLog;
end; { TGpGenericProxy }
{:Non-caching proxy component supporting HTTP connections and TCP Tunneling.
}
TGpHttpProxy = class(TGpGenericProxy)
private
FEnabledTypes : TGpProxyTypes;
FNextHopProxy : array [ptHTTP..ptTCPTunnel] of TGpProxyData;
FOnClientHeaderAvailable: TGpProxyHeaderEvent;
FOnTunnelRequest : TGpProxyTunnelRequestEvent;
FResponse : TGpProxyStrings;
protected
procedure DoClientHeaderAvailable(Client: TGpProxyClient; url: string;
var header, proto, user, pass, host, port, path, hdrHost: string;
var ignoreNextHopProxy: boolean; var returnContent: string); virtual;
procedure DoTunnelRequest(Client: TGpProxyClient; var ahost,
aport: string; var ignoreNextHopProxy: boolean; var returnContent: string);
function ExtractHeader(header, headerTag: string): string;
function GetNextHopProxy(index: TGpProxyType): TGpProxyData;
procedure ProcessHeader(Client: TGpProxyClient); virtual;
function ProcessHTTPHeader(Client: TGpProxyClient;
var header, ahost, aport, returnContent: string): boolean;
function ProcessTCPTunnelHeader(Client: TGpProxyClient;
var header, ahost, aport, returnContent: string): boolean; virtual;
procedure ReplaceHeader(var header: string; headerTag,
newValue: string);
procedure SetNextHopProxy(index: TGpProxyType; const Value: TGpProxyData); virtual;
procedure SetResponse(const Value: TGpProxyStrings); virtual;
{override}
procedure ReceivedFromClient(Client: TGpProxyClient; clientData: string); override;
procedure RemoteDataAvailable(sender: TObject; error: word); override;
procedure RemoteSessionConnected(sender: TObject; error: word); override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property AllowedIP;
property LocalAddress;
property Port;
property OnClientConnect;
property OnClientDataAvailable;
property OnClientDisconnect;
property OnRemoteConnect;
property OnRemoteDataAvailable;
property OnRemoteDisconnect;
property OnRemoteDNSLookupDone;
property OnRemoteSocketPrepared;
property OnServerClosed;
property OnServerListening;
{introduced}
{:Enabled proxy types. HTTP and TCP Tunnel are enabled by default.}
property EnabledTypes: TGpProxyTypes
read FEnabledTypes write FEnabledTypes default [ptHTTP..ptTCPTunnel];
{:Next hop HTTP proxy. If you want to connect directly to internet, set
Address subproperty to ''.}
property NextHopHTTP: TGpProxyData index ptHTTP
read GetNextHopProxy write SetNextHopProxy;
{:Next hop TCP Tunneling proxy. If you want to connect directly to internet,
set Address subproperty to ''.}
property NextHopTCPTunnel: TGpProxyData index ptTCPTunnel
read GetNextHopProxy write SetNextHopProxy;
{:Configurable response strings.}
property Response: TGpProxyStrings read FResponse write SetResponse;
{events}
{:Triggered when complete header is available. Set Client.RemoteSocket
parameters here. Use HTTPProt.ParseURL to split url into parts.}
property OnClientHeaderAvailable: TGpProxyHeaderEvent
read FOnClientHeaderAvailable write FOnClientHeaderAvailable;
{:Triggered when tunnel request header is received.}
property OnTunnelRequest: TGpProxyTunnelRequestEvent
read FOnTunnelRequest write FOnTunnelRequest;
end; { TGpHttpProxy }
procedure Register;
implementation
uses
{$IFNDEF OldDelphi}
{$WARN UNIT_PLATFORM OFF}
{$ENDIF OldDelphi}
FileCtrl,
HTTPProt,
GpString;
const
//:CR/LF pair.
CRLF = #13#10;
//:Two CR/LF sequences in a row.
CRLFCRLF = CRLF+CRLF;
//:.CRLF - message terminator.
DotCRLF = '.'#13#10;
type
TStringListFriend = class(TStringList);
{ globals }
procedure Register;
begin
RegisterComponents('FPiette', [TGpHttpProxy]);
end; { Register }
{:Missing parts of Windows' ICS.
}
function Posn(const s, t: string; count: integer): integer;
var
i, h, Last: integer;
u : string;
begin
u := t;
if count > 0 then begin
Result := Length(t);
for i := 1 to count do begin
h := Pos(s, u);
if h > 0 then
u := Copy(u, h + 1, Length(u))
else begin
u := '';
Inc(Result);
end;
end;
Result := Result - Length(u);
end
else if count < 0 then begin
Last := 0;
for i := Length(t) downto 1 do begin
u := Copy(t, i, Length(t));
h := Pos(s, u);
if (h <> 0) and ((h + i) <> Last) then begin
Last := h + i - 1;
Inc(count);
if count = 0 then
break; //for i
end;
end;
if count = 0 then
Result := Last
else
Result := 0;
end
else
Result := 0;
end; { Posn }
procedure ParseURL(const url: string; var Proto, User, Pass, Host, Port,
Path: string);
var
p, q : integer;
s : string;
CurPath: string;
begin
CurPath := Path;
proto := '';
User := '';
Pass := '';
Host := '';
Port := '';
Path := '';
if Length(url) < 1 then
Exit;
{ Handle path beginning with "./" or "../". }
{ This code handle only simple cases ! }
{ Handle path relative to current document directory }
if (Copy(url, 1, 2) = './') then begin
p := Posn('/', CurPath, -1);
if p > Length(CurPath) then
p := 0;
if p = 0 then
CurPath := '/'
else
CurPath := Copy(CurPath, 1, p);
Path := CurPath + Copy(url, 3, Length(url));
Exit;
end
{ Handle path relative to current document parent directory }
else if (Copy(url, 1, 3) = '../') then begin
p := Posn('/', CurPath, -1);
if p > Length(CurPath) then
p := 0;
if p = 0 then
CurPath := '/'
else
CurPath := Copy(CurPath, 1, p);
s := Copy(url, 4, Length(url));
{ We could have several levels }
while true do begin
CurPath := Copy(CurPath, 1, p-1);
p := Posn('/', CurPath, -1);
if p > Length(CurPath) then
p := 0;
if p = 0 then
CurPath := '/'
else
CurPath := Copy(CurPath, 1, p);
if (Copy(s, 1, 3) <> '../') then
break; // while
s := Copy(s, 4, Length(s));
end; //while
Path := CurPath + Copy(s, 1, Length(s));
Exit;
end;
p := Pos('://',url);
if p = 0 then begin
if (url[1] = '/') then begin
{ Relative path without protocol specified }
proto := 'http';
p := 1;
if (Length(url) > 1) and (url[2] <> '/') then begin
{ Relative path }
Path := Copy(url, 1, Length(url));
Exit;
end;
end
else if lowercase(Copy(url, 1, 5)) = 'http:' then begin
proto := 'http';
p := 6;
if (Length(url) > 6) and (url[7] <> '/') then begin
{ Relative path }
Path := Copy(url, 6, Length(url));
Exit;
end;
end
else if lowercase(Copy(url, 1, 7)) = 'mailto:' then begin
proto := 'mailto';
p := pos(':', url);
end;
end
else begin
proto := Copy(url, 1, p - 1);
inc(p, 2);
end;
s := Copy(url, p + 1, Length(url));
p := Pos('/', s);
q := Pos('?', s);
if (q > 0) and ((q < p) or (p = 0)) then
p := q;
if p = 0 then
p := Length(s) + 1;
Path := Copy(s, p, Length(s));
s := Copy(s, 1, p-1);
p := Posn(':', s, -1);
if p > Length(s) then
p := 0;
q := Posn('@', s, -1);
if q > Length(s) then
q := 0;
if (p = 0) and (q = 0) then begin { no user, password or port }
Host := s;
Exit;
end
else if q < p then begin { a port given }
Port := Copy(s, p + 1, Length(s));
Host := Copy(s, q + 1, p - q - 1);
if q = 0 then
Exit; { no user, password }
s := Copy(s, 1, q - 1);
end
else begin
Host := Copy(s, q + 1, Length(s));
s := Copy(s, 1, q - 1);
end;
p := Pos(':', s);
if p = 0 then
User := s
else begin
User := Copy(s, 1, p - 1);
Pass := Copy(s, p + 1, Length(s));
end;
end; { ParseURL }
{:Remove one line from the input.
@param list Multiline input.
@param line (out) First line of the input.
@returns Input without the first line.
}
function GetLineFrom(const list: string; var line: string): string;
var
p: integer;
begin
p := Pos(CRLF,list);
if p > 0 then begin
line := First(list,p-1);
Result := list;
Delete(Result,1,p+1);
end
else
line := '';
end; { GetLineFrom }
{:Get first line from the multiline string.
@param list Multiline string.
@returns First line of the multiline string.
}
function GetFirstLine(const list: string): string;
var
p: integer;
begin
p := Pos(CRLF,list);
if p > 0 then
Result := First(list,p-1)
else
Result := '';
end; { GetFirstLine }
{$IFDEF OldDelphi}
function IncludeTrailingPathDelimiter(const path: string): string;
begin
Result := IncludeTrailingBackslash(path);
end; { IncludeTrailingPathDelimiter }
{$ENDIF OldDelphi}
{:Check if specified amount of time has elapsed.
@param start Start of timed period.
@param timeout Timeout value in milliseconds.
@returns True if more than timeout milliseconds has elapsed since start.
}
function Elapsed(start: int64; timeout: DWORD): boolean;
var
stop: int64;
begin
if timeout = 0 then
Result := true
else begin
stop := GetTickCount;
{$IFNDEF Linux}
if stop < start then
stop := stop + $100000000;
{$ENDIF}
Result := ((stop-start) > timeout);
end;
end; { Elapsed }
function NoCRLF(const s: string): string;
begin
if Last(s, 2) = CRLF then
Result := ButLast(s, 2)
else
Result := s;
end; { NoCRLF }
{:Return address in <quoted> form.
@since 2003-05-11
}
function Quote(const addr: string): string;
begin
if First(TrimL(addr), 1) = '<' then
Result := addr
else
Result := '<' + addr + '>';
end; { Quote }
{:Unquote quoted part of the address and return it.
@since 2003-05-11
}
function Unquote(const addr: string): string;
var
p: integer;
begin
Result := addr;
p := Pos('<', Result);
if p > 0 then begin
Delete(Result, 1, p);
p := Pos('>', Result);
if p > 0 then
Result := Copy(result, 1, p-1);
end
else if (Length(Result) > 0) and (Result[Length(Result)] = '>') then
Delete(Result, Length(Result), 1);
end; { Unquote }
{ TGpProxyClient }
{:Create client socket object. Enable logging by default.
}
constructor TGpProxyClient.Create;
begin
inherited Create(AOwner);
Server := AOwner as TCustomWSocketServer;
FLogging := true;
ComponentOptions := ComponentOptions + [wsoNoReceiveLoop];
OnDataSent := DoDataSent;
OnSessionClosed := DoSessionClosed;
end; { TGpProxyClient.Create }
{:Create remote socket.
}
procedure TGpProxyClient.CreateRemoteSocket;
begin
FRemoteSocket := TWSocket.Create(self);
end; { TGpProxyClient.CreateRemoteSocket }
{:Destroy client socket object. Free remote socket object first.
}
destructor TGpProxyClient.Destroy;
begin
try
DestroyRemoteSocket;
inherited;
except end; // could cause some weird problems when socket's Create fails
end; { TGpProxyClient.Destroy }
{:Destroy remote socket.
}
procedure TGpProxyClient.DestroyRemoteSocket;
begin
FreeAndNil(FRemoteSocket);
end; { TGpProxyClient.DestroyRemoteSocket }
{:Handle own OnDataSent to implement buffered send.
}
procedure TGpProxyClient.DoDataSent(sender: TObject; error: word);
begin
TrySendFromBuffer;
end; { TGpProxyClient.DoDataSent }
procedure TGpProxyClient.DoSessionClosed(sender: TObject; error: word);
begin
if Error <> 0 then
Stop(error)
else
Stop2;
end; { TGpProxyClient.DoSessionClosed }
procedure TGpProxyClient.Kill;
begin
FAborted := true;
if FPaused then
Resume;
Stop(-1);
end; { TGpProxyClient.Kill }
function TGpProxyClient.SendStr(const data: string): integer;
begin
Result := inherited SendStr(data);
LastSendTime := GetTickCount;
end; { TGpProxyClient.SendStr }
{:Set type of proxying done for this client.
}
procedure TGpProxyClient.SetProxyType(proxyType: TGpProxyType);
begin
FProxyType := proxyType;
end; { TGpProxyClient.SetProxyType }
procedure TGpProxyClient.Stop(errorCode: integer);
begin
OnDataSent := nil;
if State in [wsInvalidState, wsClosed] then
Stop2
else
CloseDelayed;
end; { TGpProxyClient.Stop }
procedure TGpProxyClient.Stop2;
begin
OnSessionClosed := nil;
if assigned(FOnDone) then
FOnDone(Self);
end; { TGpProxyClient.Stop2 }
{:Data was sent to the remote socket. Check if socket must shutdown.
}
procedure TGpProxyClient.TriggerDataSent(error: word);
begin
inherited;
if FCanCloseNow then
ShutDown(1);
end; { TGpProxyClient.TriggerDataSent }
{:Try to send one line from the buffer.
@returns Number of bytes sent.
}
function TGpProxyClient.TrySendFromBuffer: integer;
begin
Result := Pos(CRLF,FSendBuffer);
if Result > 0 then begin
Result := inherited SendStr(First(FSendBuffer,Result+1));
LastSendTime := GetTickCount;
Delete(FSendBuffer,1,Result);
end;
end; { TGpProxyClient.TrySendFromBuffer }
{ TGpProxyStrings }
procedure TGpProxyStrings.Assign(Source: TPersistent);
var
iString: integer;
begin
if Source is TGpProxyStrings then
for iString := Low(FStrings) to High(FStrings) do
FStrings[iString].Assign(TGpProxyStrings(Source).GetString(iString))
else
inherited;
end; { TGpProxyStrings.Assign }
constructor TGpProxyStrings.Create;
const
CInitStrings: array [Low(FStrings)..High(FStrings)] of string =
(CHTTPClosed, CHTTPBlocked, CHTTPBadRequest, CHTTPIPForbidden,
CTcpTunnelEstablished, CTcpTunnelClosed, CTcpTunnelBlocked,
CTcpTunnelBadRequest,CTcpTunnelIPForbidden);
var
iString: integer;
begin
for iString := Low(FStrings) to High(FStrings) do begin
FStrings[iString] := TStringList.Create;
FStrings[iString].Text := CInitStrings[iString];
end; //for
end; { TGpProxyStrings.Create }
destructor TGpProxyStrings.Destroy;
var
iString: integer;
begin
for iString := Low(FStrings) to High(FStrings) do
FreeAndNil(FStrings[iString]);
inherited;
end; { TGpProxyStrings.Destroy }
function TGpProxyStrings.GetString(const Index: Integer): TStrings;
begin
Result := FStrings[Index];
end; { TGpProxyStrings.GetString }
procedure TGpProxyStrings.SetString(const Index: Integer;
const Value: TStrings);
begin
FStrings[Index].Assign(Value);
end; { TGpProxyStrings.SetString }
{ TGpGenericProxy }
{:Triggered when AllowedIP property changes.
}
procedure TGpGenericProxy.AllowedIPChanged(sender: TObject);
begin
FIPSec.AllowedIP := FAllowedIP;
// Change AllowedIP property without triggering AllowedIPChanged event.
TStringList(FAllowedIP).OnChange := nil;
FAllowedIP.Assign(FIPSec.AllowedIP);
TStringList(FAllowedIP).OnChange := AllowedIPChanged;
end; { TGpGenericProxy.AllowedIPChanged }
{:Socket background exception handler. Forwards exceptions to the OnBgException
event.
}
procedure TGpGenericProxy.BgException(sender: TObject; E: Exception;
var CanClose: Boolean);
begin
try
CanClose := false; // don't terminate the server!
DoOnDebugLog(Format('Background exception in server: %s', [E.Message]));
except end; // it is not a good idea to crash inside the background exception handler
end; { TGpGenericProxy.BgException }
{:Close proxy object.
}
procedure TGpGenericProxy.Close;
begin
DoOnDebugLog('TGpGenericProxy.Close');
CloseSocketServer;
FActive := false;
end; { TGpGenericProxy.Close }
{:Close all open sockets.
}
procedure TGpGenericProxy.CloseSocketServer;
var
i: integer;
begin
DoOnDebugLog('TGpGenericProxy.CloseSocketServer');
for i := 0 to FWSocketServer.ClientCount - 1 do
if assigned(FWSocketServer.Client[i]) then
FWSocketServer.Client[i].Close;
if not (csDestroying in ComponentState) then
FWSocketServer.Close;
end; { TGpGenericProxy.CloseSocketServer }
{:Create proxy object.
}
constructor TGpGenericProxy.Create(AOwner: TComponent);
begin
inherited;
FWSocketServer := TWSocketServer.Create(nil);
with FWSocketServer do begin
Addr := '0.0.0.0';
Banner := '';
BannerTooBusy := '';
ClientClass := TGpProxyClient;
FlushTimeout := 60;
LineEcho := false;
LineEdit := false;
LineMode := false;
LingerOnOff := wsLingerOn;
LingerTimeout := 0;
LocalAddr := '0.0.0.0';
LocalPort := '0';
MaxClients := 0;
MultiThreaded := false;
Proto := 'tcp';
SendFlags := wsSendNormal;
SocksAuthentication := socksNoAuthentication;
SocksLevel := '5';
OnBgException := BgException;
OnClientConnect := WSocketServerClientConnect;
OnClientCreate := WSocketServerClientCreate;
OnClientDisconnect := WSocketServerClientDisconnect;
OnSessionClosed := WSocketServerSessionClosed;
// OnSessionConnected := WSocketServerSessionConnected;
end;
FIPSec := TGPIPSec.Create;
FAllowedIP := TStringList.Create;
TStringList(FAllowedIP).OnChange := AllowedIPChanged;
end; { TGpGenericProxy.Create }
{:Destroy socket object.
}
destructor TGpGenericProxy.Destroy;
begin
DoOnDebugLog('TGpGenericProxy.Destroy');
CloseSocketServer;
FreeAndNil(FAllowedIP);
FreeAndNil(FIPSec);
FreeAndNil(FWSocketServer);
inherited;
end; { TGpGenericProxy.Destroy }
{:OnClientConnect forwarder.
}
procedure TGpGenericProxy.DoClientConnect(Client: TGpProxyClient);
begin
if assigned(FOnClientConnect) then
FOnClientConnect(self,Client);
end; { TGpGenericProxy.DoClientConnect }
{:OnClientDataAvailable forwarder.
}
procedure TGpGenericProxy.DoClientDataAvailable(Client: TGpProxyClient;
data: string);
begin
if assigned(FOnClientDataAvailable) and Client.Logging then
FOnClientDataAvailable(self,Client,data);
end; { TGpGenericProxy.DoClientDataAvailable }
{:OnClientDisconnect forwarder.
}
procedure TGpGenericProxy.DoClientDisconnect(Client: TGpProxyClient);
begin
if assigned(FOnClientDisconnect) then
FOnClientDisconnect(self,Client);
end; { TGpGenericProxy.DoClientDisconnect }
procedure TGpGenericProxy.DoOnDebugLog(const logMessage: string);
begin
if assigned(FOnDebugLog) then
FOnDebugLog(Self, logMessage);
end; { TGpGenericProxy.DoOnDebugLog }
{:OnRemoteConnect forwarder.
}
procedure TGpGenericProxy.DoRemoteConnect(client: TGpProxyClient);
begin
if assigned(FOnRemoteConnect) then
FOnRemoteConnect(self, client);
end; { TGpGenericProxy.DoRemoteConnect }
{:OnRemoteDataAvailable forwarder.
}
procedure TGpGenericProxy.DoRemoteDataAvailable(Client: TGpProxyClient;
data: string);
begin
if assigned(FOnRemoteDataAvailable) and Client.Logging then
FOnRemoteDataAvailable(self, Client, data);
end; { TGpGenericProxy.DoRemoteDataAvailable }
{:OnRemoteDisconnect forwarder.
}
procedure TGpGenericProxy.DoRemoteDisconnect(client: TGpProxyClient);
begin
if assigned(FOnRemoteDisconnect) then
FOnRemoteDisconnect(self, client);
end; { TGpGenericProxy.DoRemoteDisconnect }
{:OnRemoteDNSLookupDone forwarder.
}
procedure TGpGenericProxy.DoRemoteDNSLookupDone(Client: TGpProxyClient);
begin
if assigned(FOnRemoteDNSLookupDone) then
FOnRemoteDNSLookupDone(self,Client);
end; { TGpGenericProxy.DoRemoteDNSLookupDone }
{:OnRemoteSocketPrepared forwarder.
}
procedure TGpGenericProxy.DoRemoteSocketPrepared(Client: TGpProxyClient);
begin
if assigned(FOnRemoteSocketPrepared) then
FOnRemoteSocketPrepared(self,Client);
end; { TGpGenericProxy.DoRemoteSocketPrepared }
{:OnServerClosed forwarder.
}
procedure TGpGenericProxy.DoServerClosed(error: word);
begin
if assigned(FOnServerClosed) then
FOnServerClosed(self, error);
end; { TGpGenericProxy.DoServerClosed }
{:OnServerListening forwarder.
}
procedure TGpGenericProxy.DoServerListening;
begin
if assigned(FOnServerListening) then
FOnServerListening(self);
end; { TGpGenericProxy.DoServerListening }
{:Return class of the client sockets.
}
function TGpGenericProxy.GetClientClass: TGpProxyClientClass;
begin
Result := TGpProxyClientClass(FWSocketServer.ClientClass);
end; { TGpGenericProxy.GetClientClass }
{:Hook various events for the remote socket object.
}
procedure TGpGenericProxy.HookRemoteEvents(RemoteSocket: TWSocket);
begin
RemoteSocket.OnSessionConnected := {abstract}RemoteSessionConnected;
RemoteSocket.OnDataAvailable := {abstract}RemoteDataAvailable;
RemoteSocket.OnSessionClosed := RemoteSessionClosed;
RemoteSocket.OnBgException := BgException;
RemoteSocket.OnDnsLookupDone := RemoteDnsLookupDone;
end; { TGpGenericProxy.HookRemoteEvents }
{:Close client socket.
}
procedure TGpGenericProxy.InternalClose(Client: TGpProxyClient);
begin
with Client do begin
if bAllSent then
ShutDown(1)
else
CanCloseNow := true;
end; //with
end; { TGpGenericProxy.InternalClose }
{:Start listening on the specified port.
@returns Exception message if port is already in use.
}
function TGpGenericProxy.Listen: string;
begin
Result := '';
if not FActive then begin
try
FWSocketServer.Port := IntToStr(FPort);
if FLocalAddress = '' then
FWSocketServer.Addr := '0.0.0.0'
else
FWSocketServer.Addr := FLocalAddress;
FWSocketServer.Proto := 'tcp';
FWSocketServer.Listen;
Result := OpenSocketServer;
if Result <> '' then begin
DoOnDebugLog(Format('Listen failed (%s), will close', [Result]));
Close;
end
else begin
FActive := true;
DoServerListening;
end;
except
on E:ESocketException do begin
Result := E.Message;
end;
end;
end;
end; { TGpGenericProxy.Listen }
{:Called after socket server went into 'listen' mode but after the status is
returned to the caller. Derived classes can override this function to add
server initialization code. Overridden function should return error message
or '' for 'no error'.
@since 2002-12-18
}
function TGpGenericProxy.OpenSocketServer: string;
begin
Result := '';
end; { TGpGenericProxy.OpenSocketServer }
{:Handler for the client socket's OnDataAvailable event. Process received data.
}
procedure TGpGenericProxy.ProxyClientDataAvailable(sender: TObject; error: word);
var
Client : TGpProxyClient;
clientData: string;
begin
if Error <> 0 then
Exit;
Client := Sender as TGpProxyClient;
clientData := Client.ReceiveStr;
if clientData <> '' then begin
DoClientDataAvailable(Client, clientData);
ReceivedFromClient(Client, clientData);
end;
end; { TGpGenericProxy.ProxyClientDataAvailable }
procedure TGpGenericProxy.RemoteDnsLookupDone(sender: TObject; error: word);
begin
if Error <> 0 then
InternalClose(TWSocket(Sender).Owner as TGpProxyClient)
else begin
DoRemoteDnsLookupDone(TWSocket(Sender).Owner as TGpProxyClient);
with Sender as TWSocket do begin
Addr := DnsResult;
Connect;
end;
end;
end; { TGpGenericProxy.RemoteDnsLookupDone }
{:Handler for the remote socket's OnSessionClosed event. Call OnRemoteDisconnect
handler, then close client socket.
}
procedure TGpGenericProxy.RemoteSessionClosed(sender: TObject; error: word);
var
Client: TGpProxyClient;
begin
if Error <> 0 then
Exit;
Client := TWSocket(Sender).Owner as TGpProxyClient;
DoRemoteDisconnect(Client);
InternalClose(Client);
end; { TGpGenericProxy.RemoteSessionClosed }
{:Send text to the socket but only if socket is alive and connected.
}
procedure TGpGenericProxy.SendText(socket: TWSocket; data: string);
begin
if assigned(socket) and (socket.State = wsConnected) then try
socket.SendStr(data);
except end; // socket may get disconnected during the send - ignore the error in such case
end; { TGpGenericProxy.SendText }
{:Set list of allowed IP addresses.
}
procedure TGpGenericProxy.SetAllowedIP(const Value: TStrings);
begin
FAllowedIP.Assign(Value);
end; { TGpGenericProxy.SetAllowedIP }
{:Set class of the client sockets. If proxy is Active, class won't be modified.
}
procedure TGpGenericProxy.SetClientClass(const Value: TGpProxyClientClass);
begin
if not Active then
FWSocketServer.ClientClass := Value
else
raise Exception.Create('ClientClass property can only be modified when proxy is not active');
end; { TGpGenericProxy.SetClientClass }
{:Set local address. If proxy is Active, local address won't be changed.
}
procedure TGpGenericProxy.SetLocalAddress(const Value: string);
begin
if not Active then
FLocalAddress := Value
else
raise Exception.Create('LocalAddress property can only be modified when proxy is not active');
end; { TGpGenericProxy.SetLocalAddress }
{:Set proxy port. If proxy is Active, port won't be changed.
}
procedure TGpGenericProxy.SetPort(const Value: integer);
begin
if not Active then
FPort := Value
else
raise Exception.Create('Port property can only be modified when proxy is not active');
end; { TGpGenericProxy.SetPort }
{:Handler for the TWSocketServer's OnClientConnect event. Set connected socket's
event handlers, increment socket count, and call OnClientConnect handler.
}
procedure TGpGenericProxy.WSocketServerClientConnect(sender: TObject;
Client: TWSocketClient; error: word);
begin
if Error <> 0 then
Exit;
with Client as TGpProxyClient do begin
Received := '';
OnDataAvailable := ProxyClientDataAvailable;
OnBgException := BgException;
LineMode := false;
LastSendTime := GetTickCount;
FClientCount := TWSocketServer(Server).ClientCount;
end;
DoClientConnect(Client as TGpProxyClient);
end; { TGpGenericProxy.WSocketServerClientConnect }
procedure TGpGenericProxy.WSocketServerClientCreate(sender: TObject;
Client: TWSocketClient);
begin
end; { TGpGenericProxy.WSocketServerClientCreate }
{:Handler for the TWSocketServer's OnClientDisconnect event. Decrement socket
count and call OnClientDisconnect handler.
}
procedure TGpGenericProxy.WSocketServerClientDisconnect(sender: TObject;
Client: TWSocketClient; error: word);
var
_Client: TGpProxyClient;
begin
_Client := Client as TGpProxyClient;
FClientCount := TWSocketServer(_Client.Server).ClientCount-1;
DoClientDisconnect(_Client);
end; { TGpGenericProxy.WSocketServerClientDisconnect }
{:Handler for the TWSocketServer's OnSessionClosed event. Disconnect client
socket and call OnServerClosed handler.
}
procedure TGpGenericProxy.WSocketServerSessionClosed(sender: TObject;
error: word);
begin
if assigned(TWSocket(Sender).Owner) then
with TWSocket(Sender).Owner as TGpProxyClient do
ShutDown(1);
DoServerClosed(error);
end; { TGpGenericProxy.WSocketServerSessionClosed }
{:Handler for the TWSocketServer's OnSessionConnected event. Call
OnServerListening handler.
}
//procedure TGpGenericProxy.WSocketServerSessionConnected(sender: TObject;
// error: word);
//begin
// DoServerListening;
//end; { TGpGenericProxy.WSocketServerSessionConnected }
{ TGpHttpProxy }
{:Create proxy object.
}
constructor TGpHttpProxy.Create(AOwner: TComponent);
var
iProxy: TGpProxyType;
begin
inherited;
FPort := 8080;
FEnabledTypes := [ptHTTP..ptTCPTunnel];
FResponse := TGpProxyStrings.Create;
for iProxy := Low(FNextHopProxy) to High(FNextHopProxy) do
FNextHopProxy[iProxy] := TGpProxyData.Create(8080);
end; { TGpHttpProxy.Create }
{:Destroy proxy object.
}
destructor TGpHttpProxy.Destroy;
var
iProxy: TGpProxyType;
begin
try // raising exception during service destruction is not a good idea
CloseSocketServer;
for iProxy := Low(FNextHopProxy) to High(FNextHopProxy) do
FreeAndNil(FNextHopProxy[iProxy]);
FreeAndNil(FResponse);
inherited;
except end;
end; { TGpHttpProxy.Destroy }
{:OnClientHeaderAvailable forwarder.
}
procedure TGpHttpProxy.DoClientHeaderAvailable(Client: TGpProxyClient;
url: string; var header, proto, user, pass, host, port, path, hdrHost: string;
var ignoreNextHopProxy: boolean; var returnContent: string);
begin
ignoreNextHopProxy := false;
returnContent := '';
if assigned(FOnClientHeaderAvailable) then
FOnClientHeaderAvailable(self,Client,url,header,proto,user,pass,host,port,
path,hdrHost,ignoreNextHopProxy,returnContent);
end; { TGpHttpProxy.DoClientHeaderAvailable }
{:OnTunnelRequest forwarder.
}
procedure TGpHttpProxy.DoTunnelRequest(Client: TGpProxyClient; var ahost,
aport: string; var ignoreNextHopProxy: boolean; var returnContent: string);
begin
if assigned(FOnTunnelRequest) then
FOnTunnelRequest(Self, Client, ahost, aport, ignoreNextHopProxy, returnContent);
end; { TGpHttpProxy.DoTunnelRequest }
{:Extract specified header line.
@param header HTTP response header.
@param headerTag Name of the line to be extracted.
@returns Contents of the specified line without the leading tag or empty
string if the line doesn't exist.
@since 2001-11-07
}
function TGpHttpProxy.ExtractHeader(header, headerTag: string): string;
var
p: integer;
begin
p := Pos(#13#10+UpperCase(headerTag)+':',UpperCase(header));
if p = 0 then
Result := ''
else begin
Delete(header,1,p+Length(headerTag)+2);
header := TrimLeft(header);
p := Pos(#13#10,header);
if p = 0 then
Result := header
else
Result := Copy(header,1,p-1);
end;
end; { TGpHttpProxy.ExtractHeader }
{:Return next-hop proxy.
@param index ptHTTP - return HTTP proxy, ptTCPTunnel - return TCP Tunnel
proxy
}
function TGpHttpProxy.GetNextHopProxy(index: TGpProxyType): TGpProxyData;
begin
Result := FNextHopProxy[index];
end; { TGpHttpProxy.GetNextHopProxy }
{:Process HTTP or TCP Tunnel header.
}
procedure TGpHttpProxy.ProcessHeader(Client: TGpProxyClient);
var
ahost : string;
aport : string;
header : string;
returnContent: string;
begin
returnContent := '';
header := Client.Received;
if SameText(FirstEl(header,' ',-1),'CONNECT') then begin
// TCP Tunnel proxy request
Client.SetProxyType(ptTCPTunnel);
if not FIPSec.IsAllowed(Client.PeerAddr) then
returnContent := Response.sTCPTunnelIPForbidden.Text
else if not (ptTCPTunnel in EnabledTypes) then
returnContent := Response.sTCPTunnelClosed.Text
else if not ProcessTCPTunnelHeader(Client,header,ahost,aport,returnContent) then
returnContent := Response.sTCPTunnelBadRequest.Text;
end
else begin
// HTTP proxy request
Client.SetProxyType(ptHTTP);
if not FIPSec.IsAllowed(Client.PeerAddr) then
returnContent := Response.sHTTPIPForbidden.Text
else if not (ptHTTP in EnabledTypes) then
returnContent := Response.sHTTPClosed.Text
else if not ProcessHTTPHeader(Client,header,ahost,aport,returnContent) then
returnContent := Response.sHTTPBadRequest.Text;
end; //else SameText()
// Header parsed, create remote socket.
if returnContent = '' then begin
with Client do begin
CreateRemoteSocket;
Received := header;
RemoteSocket.Port := aport;
RemoteSocket.LineMode := false;
HookRemoteEvents(RemoteSocket);
RemoteSocket.DnsLookup(ahost);
DoRemoteSocketPrepared(Client);
end; //with
end
else begin
Client.DestroyRemoteSocket;
Client.RemoteContent := returnContent;
end;
Client.GotHeader := true;
end; { TGpHttpProxy.ProcessHeader }
{:Process HTTP header.
@param header (in) Received header.
(out) Modified header, ready to be sent to the remote
socket.
@param ahost (out) Remote socket's IP address.
@param aport (out) Remote socket's port.
@param returnContent (out) Non-static content to be returned. If '',
connection to remote socket will be made instead.
@returns True if header was valid.
}
function TGpHttpProxy.ProcessHTTPHeader(Client: TGpProxyClient;
var header, ahost, aport, returnContent: string): boolean;
function MakeUrl(aproto, auser, apass, ahost, aport, apath: string): string;
begin
Result := aproto;
if Last(Result,1) = ':' then
Result := Result + '//'
else if Last(Result,1) <> '/' then
Result := Result + '://';
if auser <> '' then begin
Result := Result + auser;
if apass <> '' then
Result := Result + ':' + apass;
Result := Result + '@';
end;
Result := Result + ahost;
if (aport <> '') and (aport <> '80') then
Result := Result + ':' + aport;
Result := Result + apath;
end; { MakeUrl }
var
apass : string;
apath : string;
aproto : string;
auser : string;
command : string;
hdrHost : string;
ignoreNextHopProxy: boolean;
p1 : integer;
p2 : integer;
s : string;
url : string;
begin { TGpHttpProxy.ProcessHTTPHeader }
Result := false;
// extract url from GET/POST header
s := header;
p1 := Pos(' ',s);
if p1 > 0 then begin
command := First(s,p1-1);
Delete(s,1,p1);
s := TrimLeft(s);
p2 := Pos(' ',s);
if p2 > 0 then begin
url := Copy(s,1,p2-1);
ParseURL(url,aproto,auser,apass,ahost,aport,apath);
if aport = '' then
aport := '80';
hdrHost := ExtractHeader(header,'Host');
returnContent := '';
ignoreNextHopProxy := false;
DoClientHeaderAvailable(Client,url,header,aproto,auser,apass,ahost,aport,
apath,hdrHost,ignoreNextHopProxy,returnContent);
if (NextHopHTTP.Address <> '') and (not ignoreNextHopProxy) and
(returnContent = '') then //replace host information with proxy
begin
Delete(header,p1+1,p2-1);
Insert(MakeUrl(aproto,auser,apass,ahost,aport,apath),header,p1+1);
if NextHopHTTP.Username <> '' then begin
// Insert 'Proxy-Authorization' header
p1 := Pos(CRLF+CRLF,header);
Insert(CRLF+'Proxy-Authorization: Basic '+
EncodeStr(encBase64, NextHopHTTP.Username+':'+NextHopHTTP.Password),
header,p1);
end;
ReplaceHeader(header,'Host',hdrHost);
aport := IntToStr(FNextHopProxy[ptHTTP].Port);
ahost := FNextHopProxy[ptHTTP].Address;
Client.UsingNextHop := true;
end
else if SameText(command,'OPTIONS') and (ahost = '*') then
Exit
else begin
// Any of the URL parts may have changed in the event handler - modify the header.
Delete(header,p1+1,p2-1);
if SameText(command,'OPTIONS') then
Insert('*',header,p1+1)
else
Insert(apath,header,p1+1);
ReplaceHeader(header,'Host',hdrHost);
if auser <> '' then begin
// Insert 'Authorization' header
p1 := Pos(CRLF+CRLF,header);
Insert(CRLF+'Authorization: Basic '+EncodeStr(encBase64, auser+ ':'+apass),
header,p1);
end;
Client.UsingNextHop := false;
end;
Result := true;
end; //else p2 > 0
end; //else p1 > 0
end; { TGpHttpProxy.ProcessHTTPHeader }
{:Process TCP Tunnel header.
@param header (in) Received header.
(out) Modified header, ready to be sent to the remote
socket.
@param ahost (out) Remote socket's IP address.
@param aport (out) Remote socket's port.
@param returnContent (out) Non-static content to be returned. If '',
connection to remote socket will be made instead.
@returns True if header was valid.
}
function TGpHttpProxy.ProcessTCPTunnelHeader(Client: TGpProxyClient;
var header, ahost, aport, returnContent: string): boolean;
var
apass : string;
apath : string;
aproto : string;
auser : string;
ignoreNextHopProxy: boolean;
p1 : integer;
s : string;
begin
//Handles TCP Tunnel requests of the following form:
// CONNECT 161.69.2.7:21 HTTP/1.1
// User-Agent: WinProxy (Version 4.0 R1b)
// Host: 161.69.2.7
// Pragma: no-cache
Result := false;
s := FirstEl(header,#13,-1);
if NumElements(s,' ',-1) = 3 then begin
s := NthEl(s,2,' ',-1);
if NumElements(s,':',-1) = 2 then begin
aproto := '';
auser := '';
apass := '';
apath := '';
ahost := NthEl(s,1,':',-1);
aport := NthEl(s,2,':',-1);
returnContent := '';
ignoreNextHopProxy := false;
DoTunnelRequest(Client,ahost,aport,ignoreNextHopProxy,
returnContent);
if (NextHopTCPTunnel.Address <> '') and (not ignoreNextHopProxy) and
(returnContent = '') then // replace host information with proxy
begin
// ahost, aport may have changed - modify the header
header := FirstEl(header,' ',-1)+' '+ahost+':'+aport+' '+
ButFirstNEl(header,2,' ',-1);
if NextHopTCPTunnel.Username <> '' then begin
// Insert 'Proxy-Authorization' header
p1 := Pos(CRLF+CRLF,header);
Insert(CRLF+'Proxy-Authorization: Basic '+
EncodeStr(encBase64, NextHopTCPTunnel.Username+':'+NextHopTCPTunnel.Password),
header,p1);
end;
aport := IntToStr(FNextHopProxy[ptTCPTunnel].Port);
ahost := FNextHopProxy[ptTCPTunnel].Address;
Client.UsingNextHop := true;
end
else begin
// strip TCP Tunnel request from the header
p1 := Pos(CRLF+CRLF,header);
header := ButFirst(header,p1+3);
Client.UsingNextHop := false;
end;
Result := true;
end; //if NumElements(s,':',-1)
end; //if NumElements(s,' ',-1)
end; { TGpHttpProxy.ProcessTCPTunnelHeader }
{:Process data received from the client. Accumulate data until full header is
received, then process the header and either forward or reject the connection.
}
procedure TGpHttpProxy.ReceivedFromClient(Client: TGpProxyClient;
clientData: string);
begin
Client.Received := Client.Received + clientData;
if not Client.GotHeader then begin
if Pos(CRLF+CRLF,Client.Received) > 0 then
ProcessHeader(Client) // will set gotHeader
else
Exit;
end;
if Client.GotHeader and (Client.Received <> '') then begin
if not assigned(Client.RemoteSocket) then begin
SendText(Client,Client.RemoteContent);
Self.InternalClose(Client);
Client.Received := '';
end
else if (Client.RemoteSocket.State = wsConnected) then begin
SendText(Client.RemoteSocket,Client.Received);
Client.Received := '';
end;
end;
end; { TGpHttpProxy.ReceivedFromClient }
{:Handler for the remote socket's OnDataAvailable event. Call
OnRemoteDataAvailable handler and forward the received data to the client
socket.
}
procedure TGpHttpProxy.RemoteDataAvailable(sender: TObject; error: word);
var
Client : TGpProxyClient;
fromRemote: string;
p : integer;
begin
if Error <> 0 then
Exit;
Client := TWSocket(Sender).Owner as TGpProxyClient;
fromRemote := Client.RemoteSocket.ReceiveStr;
if fromRemote <> '' then begin
if (Client.ProxyType = ptTCPTunnel) and Client.UsingNextHop and
(not Client.GotResponseHeader) then
begin
if Client.UsingNextHop then begin
Client.RemoteReceived := Client.RemoteReceived + fromRemote;
p := Pos(CRLF+CRLF,Client.RemoteReceived);
if p > 0 then begin
SendText(Client,First(Client.RemoteReceived,p+3));
fromRemote := ButFirst(Client.RemoteReceived,p+3);
Client.GotResponseHeader := true;
end;
if not Client.GotResponseHeader then
Exit;
end;
end;
DoRemoteDataAvailable(Client,fromRemote);
if Client.State = wsConnected then
SendText(Client,fromRemote)
else // should not occur
Client.RemoteSocket.ShutDown(1);
end;
end; { TGpHttpProxy.RemoteDataAvailable }
{:Handler for the remote socket's OnSessionConnected event. Call OnRemoteConnect
handler, then process received data (if any).
}
procedure TGpHttpProxy.RemoteSessionConnected(sender: TObject; error: word);
var
Client: TGpProxyClient;
begin
Client := TWSocket(Sender).Owner as TGpProxyClient;
DoRemoteConnect(Client);
if Error <> 0 then
Exit;
if (Client.ProxyType = ptTCPTunnel) and (not Client.UsingNextHop) then begin
// Send 200 Connection established
SendText(Client,Response.sTCPTunnelEstablished.Text);
Client.GotResponseHeader := true;
end;
ReceivedFromClient(Client,Client.ReceiveStr);
end; { TGpHttpProxy.RemoteSessionConnected }
{:Replace HTTP header.
@param header HTTP header.
@param headerTag Tag of the HTTP line.
@param newValue New value of the header line.
@since 2001-11-07
}
procedure TGpHttpProxy.ReplaceHeader(var header: string; headerTag,
newValue: string);
var
p : integer;
prefix: string;
begin
p := Pos(#13#10+UpperCase(headerTag)+':',UpperCase(header));
if p = 0 then begin
p := Pos(#13#10#13#10,header);
Insert(#13#10+headerTag+': '+newValue,header,p);
end
else begin
prefix := Copy(header,1,p+Length(headerTag)+2);
Delete(header,1,p+Length(headerTag)+2);
header := TrimLeft(header);
p := Pos(#13#10,header);
if p = 0 then
p := Length(header)+1;
Delete(header,1,p-1);
header := prefix + ' ' + newValue + header;
end;
end; { TGpGenericProxy.ReplaceHeader }
{:Set next-hop proxy data.
@param index ptHTTP - return HTTP proxy, ptTCPTunnel - return TCP Tunnel
proxy
}
procedure TGpHttpProxy.SetNextHopProxy(index: TGpProxyType;
const Value: TGpProxyData);
begin
FNextHopProxy[index].Assign(Value);
end; { TGpHttpProxy.SetNextHopProxy }
{:Set response strings.
}
procedure TGpHttpProxy.SetResponse(const Value: TGpProxyStrings);
begin
FResponse.Assign(Value);
end; { TGpHttpProxy.SetResponse }
end.