paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-16 23:21:57 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Splittet old HTTP unit into httpbase and httpclient

Browse Source 
* Many improvements in fpSock (e.g. better disconnection detection)
This commit is contained in:
sg 2004-01-31 19:13:14 +00:00
parent 6ef9a2e850
commit a5665b2039
7 changed files with 764 additions and 414 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
fcl/net/Makefile
View File

@ -1,5 +1,5 @@
#
# Don't edit, this file is generated by FPCMake Version 1.1 [2004/01/05]
# Don't edit, this file is generated by FPCMake Version 1.1 [2004/01/26]
#
default: all
MAKEFILETARGETS=linux go32v2 win32 os2 freebsd beos netbsd amiga atari sunos qnx netware openbsd wdosx palmos macos darwin emx watcom
@ -222,19 +222,16 @@ override TARGET_PROGRAMS+=mkxmlrpc
endif
override TARGET_UNITS+=servlets
ifeq ($(OS_TARGET),linux)
override TARGET_UNITS+=fpsock http httpsvlt xmlrpc
override TARGET_UNITS+=fpsock httpbase httpsvlt xmlrpc
endif
ifeq ($(OS_TARGET),freebsd)
override TARGET_UNITS+=fpsock http httpsvlt xmlrpc
override TARGET_UNITS+=fpsock httpbase httpsvlt xmlrpc
endif
ifeq ($(OS_TARGET),netbsd)
override TARGET_UNITS+=fpsock http httpsvlt xmlrpc
override TARGET_UNITS+=fpsock httpbase httpsvlt xmlrpc
endif
ifeq ($(OS_TARGET),openbsd)
override TARGET_UNITS+=fpsock http httpsvlt xmlrpc
endif
ifeq ($(OS_TARGET),darwin)
override TARGET_UNITS+=fpsock http httpsvlt xmlrpc
override TARGET_UNITS+=fpsock httpbase httpsvlt xmlrpc
endif
ifeq ($(OS_TARGET),linux)
override TARGET_RSTS+=fpsock httpsvlt mkxmlrpc
@ -1045,20 +1042,6 @@ REQUIRE_PACKAGES_NETDB=1
REQUIRE_PACKAGES_LIBASYNC=1
endif
endif
ifeq ($(OS_TARGET),netbsd)
ifeq ($(CPU_TARGET),powerpc)
REQUIRE_PACKAGES_RTL=1
REQUIRE_PACKAGES_NETDB=1
REQUIRE_PACKAGES_LIBASYNC=1
endif
endif
ifeq ($(OS_TARGET),netbsd)
ifeq ($(CPU_TARGET),sparc)
REQUIRE_PACKAGES_RTL=1
REQUIRE_PACKAGES_NETDB=1
REQUIRE_PACKAGES_LIBASYNC=1
endif
endif
ifeq ($(OS_TARGET),amiga)
ifeq ($(CPU_TARGET),m68k)
REQUIRE_PACKAGES_RTL=1

9
fcl/net/Makefile.fpc
View File

@ -7,11 +7,10 @@ main=fcl
[target]
units=servlets
units_linux=fpsock http httpsvlt xmlrpc
units_freebsd=fpsock http httpsvlt xmlrpc
units_darwin=fpsock http httpsvlt xmlrpc
units_netbsd=fpsock http httpsvlt xmlrpc
units_openbsd=fpsock http httpsvlt xmlrpc
units_linux=fpsock httpbase httpsvlt xmlrpc
units_freebsd=fpsock httpbase httpsvlt xmlrpc
units_netbsd=fpsock httpbase httpsvlt xmlrpc
units_openbsd=fpsock httpbase httpsvlt xmlrpc
programs_linux=mkxmlrpc
programs_freebsd=mkxmlrpc
programs_darwin=mkxmlrpc

506
fcl/net/fpsock.pp
View File

@ -1,7 +1,7 @@
{
$Id$
Socket components
Socket communication components
Copyright (c) 2003 by
Areca Systems GmbH / Sebastian Guenther, sg@freepascal.org
@ -17,7 +17,7 @@ unit fpSock;
interface
uses SysUtils, Sockets, Classes, fpAsync;
uses Errors, SysUtils, Sockets, Classes, fpAsync, Resolve;
type
@ -27,10 +27,7 @@ type
TSocketComponent = class(TComponent)
private
FEventLoop: TEventLoop;
protected
DataAvailableNotifyHandle: Pointer;
public
destructor Destroy; override;
property EventLoop: TEventLoop read FEventLoop write FEventLoop;
end;
@ -39,6 +36,8 @@ type
FOnDisconnect: TNotifyEvent;
function GetLocalAddress: TSockAddr;
function GetPeerAddress: TSockAddr;
protected
procedure Disconnected; virtual;
public
destructor Destroy; override;
function Read(var Buffer; Count: LongInt): LongInt; override;
@ -49,46 +48,134 @@ type
property OnDisconnect: TNotifyEvent read FOnDisconnect write FOnDisconnect;
end;
// TCP/IP components
TTCPConnection = class(TSocketComponent)
// Connection-based sockets
TConnectionBasedSocket = class(TSocketComponent)
protected
FStream: TSocketStream;
FActive: Boolean;
procedure SetActive(Value: Boolean); virtual; abstract;
property Active: Boolean read FActive write SetActive;
property Stream: TSocketStream read FStream;
public
destructor Destroy; override;
end;
TTCPClient = class(TTCPConnection)
TConnectionState = (
connDisconnected,
connResolving,
connConnecting,
connConnected);
TClientConnectionSocket = class;
TConnectionStateChangeEvent = procedure(Sender: TClientConnectionSocket;
OldState, NewState: TConnectionState) of object;
TClientConnectionSocket = class(TConnectionBasedSocket)
private
FOnStateChange: TConnectionStateChangeEvent;
FRetries: Integer;
FRetryDelay: Integer; // Delay between retries in ms
RetryCounter: Integer;
RetryTimerNotifyHandle: Pointer;
CanWriteNotifyHandle: Pointer;
procedure RetryTimerNotify(Sender: TObject);
procedure SocketCanWrite(Sender: TObject);
protected
FConnectionState: TConnectionState;
procedure CreateSocket; virtual; abstract;
procedure DoResolve; virtual;
procedure DoConnect; virtual;
function GetPeerName: String; virtual; abstract;
procedure SetActive(Value: Boolean); override;
procedure SetConnectionState(NewState: TConnectionState);
property ConnectionState: TConnectionState read FConnectionState;
property Retries: Integer read FRetries write FRetries default 0;
property RetryDelay: Integer read FRetryDelay write FRetryDelay default 500;
property OnConnectionStateChange: TConnectionStateChangeEvent
read FOnStateChange write FOnStateChange;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
end;
TCustomTCPServer = class;
TQueryConnectEvent = procedure(Sender: TCustomTCPServer; Socket: Integer;
TQueryConnectEvent = procedure(Sender: TConnectionBasedSocket; Socket: Integer;
var DoConnect: Boolean) of object;
TConnectEvent = procedure(Sender: TCustomTCPServer;
TConnectEvent = procedure(Sender: TConnectionBasedSocket;
Stream: TSocketStream) of object;
TCustomTCPServer = class(TTCPConnection)
TSocketConnectionServer = class(TConnectionBasedSocket)
private
FActive: Boolean;
FPort: Word;
FOnQueryConnect: TQueryConnectEvent;
FOnConnect: TConnectEvent;
procedure SetActive(Value: Boolean);
procedure ListenerDataAvailable(Sender: TObject);
protected
FSocket: Integer;
function DoQueryConnect(ASocket: Integer): Boolean; virtual;
DataAvailableNotifyHandle: Pointer;
procedure ListenerDataAvailable(Sender: TObject);
function DoQueryConnect(ASocket: Integer): Boolean;
procedure DoConnect(AStream: TSocketStream); virtual;
//!!!: Interface/bindings list?
property Active: Boolean read FActive write SetActive;
property Port: Word read FPort write FPort;
property OnQueryConnect: TQueryConnectEvent read FOnQueryConnect
write FOnQueryConnect;
property OnConnect: TConnectEvent read FOnConnect write FOnConnect;
end;
// TCP/IP components
TCustomTCPClient = class(TClientConnectionSocket)
private
FHost: String;
FPort: Word;
HostAddr: THostAddr;
procedure SetHost(const Value: String);
procedure SetPort(Value: Word);
protected
procedure CreateSocket; override;
procedure DoResolve; override;
procedure DoConnect; override;
function GetPeerName: String; override;
property Host: String read FHost write SetHost;
property Port: Word read FPort write SetPort;
public
destructor Destroy; override;
end;
TTCPClient = class(TCustomTCPClient)
public
property ConnectionState;
property Stream;
published
property Active;
property Host;
property Port;
property Retries;
property RetryDelay;
property OnConnectionStateChange;
end;
TCustomTCPServer = class;
TCustomTCPServer = class(TSocketConnectionServer)
private
FPort: Word;
procedure SetActive(Value: Boolean); override;
protected
//!!!: Interface/bindings list?
property Port: Word read FPort write FPort;
public
destructor Destroy; override;
end;
TTCPServer = class(TCustomTCPServer)
public
property Socket: Integer read FSocket;
property Stream;
published
property Active;
property Port;
@ -97,39 +184,29 @@ type
end;
// UDP/IP components
TUDPBase = class(TSocketComponent)
end;
TUDPClient = class(TUDPBase)
end;
TUDPServer = class(TUDPBase)
end;
implementation
uses Resolve;
uses
{$IFDEF VER1_0}
Linux;
{$ELSE}
Unix;
{$ENDIF}
resourcestring
SSocketCreationError = 'Could not create socket';
SSocketBindingError = 'Could not bind socket to port %d';
SSocketAcceptError = 'Connection accept failed';
SSocketNoEventLoopAssigned = 'No event loop assigned';
SSocketCreationError = 'Could not create socket: %s';
SHostNotFound = 'Host "%s" not found';
SSocketConnectFailed = 'Could not connect to %s: %s';
SSocketBindingError = 'Could not bind socket to port %d: %s';
SSocketAcceptError = 'Connection accept failed: %s';
SSocketIsActive = 'Cannot change parameters while active';
destructor TSocketComponent.Destroy;
begin
if Assigned(DataAvailableNotifyHandle) then
begin
EventLoop.ClearDataAvailableNotify(DataAvailableNotifyHandle);
// Set to nil to be sure that descendant classes don't do something stupid
DataAvailableNotifyHandle := nil;
end;
inherited Destroy;
end;
// TSocketStream
destructor TSocketStream.Destroy;
begin
FileClose(Handle);
@ -142,8 +219,8 @@ begin
if Result = -1 then
begin
Result := 0;
if Assigned(OnDisconnect) then
OnDisconnect(Self);
if SocketError <> Sys_EAGAIN then
Disconnected;
end;
end;
@ -153,11 +230,17 @@ begin
if Result = -1 then
begin
Result := 0;
if Assigned(OnDisconnect) then
OnDisconnect(Self);
if SocketError <> Sys_EAGAIN then
Disconnected;
end;
end;
procedure TSocketStream.Disconnected;
begin
if Assigned(OnDisconnect) then
OnDisconnect(Self);
end;
function TSocketStream.GetLocalAddress: TSockAddr;
var
len: LongInt;
@ -177,21 +260,289 @@ begin
end;
function TCustomTCPServer.DoQueryConnect(ASocket: Integer): Boolean;
// TConnectionBasedSocket
destructor TConnectionBasedSocket.Destroy;
begin
FreeAndNil(FStream);
inherited Destroy;
end;
// TClientConnectionSocket
constructor TClientConnectionSocket.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FRetryDelay := 500;
end;
destructor TClientConnectionSocket.Destroy;
begin
if Assigned(RetryTimerNotifyHandle) then
EventLoop.RemoveTimerNotify(RetryTimerNotifyHandle);
inherited Destroy;
end;
procedure TClientConnectionSocket.DoResolve;
begin
// By default, no resolving is done, so continue directly with connecting
DoConnect;
end;
procedure TClientConnectionSocket.DoConnect;
begin
SetConnectionState(connConnecting);
try
if not Assigned(EventLoop) then
raise ESocketError.Create(SSocketNoEventLoopAssigned);
CanWriteNotifyHandle := EventLoop.SetCanWriteNotify(Stream.Handle,
@SocketCanWrite, nil);
except
SetConnectionState(connDisconnected);
raise;
end;
end;
procedure TClientConnectionSocket.SetActive(Value: Boolean);
begin
if Value <> Active then
begin
if Value then
begin
// Activate the connection
FActive := True;
RetryCounter := 0;
CreateSocket;
DoResolve;
end else
begin
// Close the connection
FActive := False;
try
FreeAndNil(FStream);
if Assigned(CanWriteNotifyHandle) then
begin
EventLoop.ClearCanWriteNotify(CanWriteNotifyHandle);
CanWriteNotifyHandle := nil;
end;
if Assigned(RetryTimerNotifyHandle) then
begin
EventLoop.RemoveTimerNotify(RetryTimerNotifyHandle);
RetryTimerNotifyHandle := nil;
end;
finally
SetConnectionState(connDisconnected);
end;
end;
end;
end;
procedure TClientConnectionSocket.SetConnectionState(NewState:
TConnectionState);
var
OldState: TConnectionState;
begin
if NewState <> ConnectionState then
begin
OldState := ConnectionState;
FConnectionState := NewState;
if Assigned(OnConnectionStateChange) then
OnConnectionStateChange(Self, OldState, NewState);
end;
end;
procedure TClientConnectionSocket.RetryTimerNotify(Sender: TObject);
begin
RetryTimerNotifyHandle := nil;
Active := True;
end;
procedure TClientConnectionSocket.SocketCanWrite(Sender: TObject);
var
Error: Integer;
ErrorLen, GetResult: LongInt;
begin
if ConnectionState = connConnecting then
begin
EventLoop.ClearCanWriteNotify(CanWriteNotifyHandle);
CanWriteNotifyHandle := nil;
ErrorLen := SizeOf(Error);
GetResult := Sockets.GetSocketOptions(Stream.Handle, SOL_SOCKET, SO_ERROR,
Error, ErrorLen);
if GetResult <> 0 then
raise ESocketError.CreateFmt(SSocketConnectFailed,
[GetPeerName, StrError(GetResult)]);
if Error <> 0 then
if (RetryCounter >= Retries) and (Retries >= 0) then
raise ESocketError.CreateFmt(SSocketConnectFailed,
[GetPeerName, StrError(Error)])
else begin
Active := False;
RetryTimerNotifyHandle := EventLoop.AddTimerNotify(RetryDelay, False,
@RetryTimerNotify, Self);
Inc(RetryCounter);
end
else
begin
RetryCounter := 0;
SetConnectionState(connConnected);
end;
end;
end;
// TSocketConnectionServer
procedure TSocketConnectionServer.ListenerDataAvailable(Sender: TObject);
var
ClientSocket: Integer;
Addr: TInetSockAddr;
AddrSize: Integer;
begin
AddrSize := SizeOf(Addr);
ClientSocket := Accept(Stream.Handle, Addr, AddrSize);
if ClientSocket = -1 then
raise ESocketError.CreateFmt(SSocketAcceptError, [StrError(SocketError)]);
if DoQueryConnect(ClientSocket) then
DoConnect(TSocketStream.Create(ClientSocket));
end;
function TSocketConnectionServer.DoQueryConnect(ASocket: Integer): Boolean;
begin
Result := True;
if Assigned(OnQueryConnect) then
OnQueryConnect(Self, ASocket, Result);
end;
procedure TCustomTCPServer.DoConnect(AStream: TSocketStream);
procedure TSocketConnectionServer.DoConnect(AStream: TSocketStream);
begin
if Assigned(OnConnect) then
OnConnect(Self, AStream);
end;
// TCustomTCPClient
type
TClientSocketStream = class(TSocketStream)
protected
Client: TCustomTCPClient;
procedure Disconnected; override;
end;
procedure TClientSocketStream.Disconnected;
begin
inherited Disconnected;
Client.Active := False;
end;
destructor TCustomTCPClient.Destroy;
begin
if Assigned(CanWriteNotifyHandle) then
begin
EventLoop.ClearCanWriteNotify(CanWriteNotifyHandle);
// Set to nil to be sure that descendant classes don't do something stupid
CanWriteNotifyHandle := nil;
end;
inherited Destroy;
end;
procedure TCustomTCPClient.SetHost(const Value: String);
begin
if Value <> Host then
begin
if Active then
raise ESocketError.Create(SSocketIsActive);
FHost := Value;
end;
end;
procedure TCustomTCPClient.SetPort(Value: Word);
begin
if Value <> Port then
begin
if Active then
raise ESocketError.Create(SSocketIsActive);
FPort := Value;
end;
end;
procedure TCustomTCPClient.DoResolve;
var
HostResolver: THostResolver;
begin
HostAddr := StrToHostAddr(Host);
if HostAddr[1] = 0 then
begin
HostResolver := THostResolver.Create(nil);
try
SetConnectionState(connResolving);
if not HostResolver.NameLookup(FHost) then
raise ESocketError.CreateFmt(SHostNotFound, [Host]);
HostAddr := HostResolver.HostAddress;
finally
HostResolver.Free;
end;
end;
DoConnect;
end;
procedure TCustomTCPClient.CreateSocket;
var
Socket: Integer;
begin
Socket := Sockets.Socket(AF_INET, SOCK_STREAM, 0);
if Socket = -1 then
raise ESocketError.CreateFmt(SSocketCreationError,
[StrError(SocketError)]);
FStream := TClientSocketStream.Create(Socket);
TClientSocketStream(FStream).Client := Self;
end;
procedure TCustomTCPClient.DoConnect;
var
SockAddr: TInetSockAddr;
begin
inherited DoConnect;
SockAddr.Family := AF_INET;
SockAddr.Port := ShortHostToNet(Port);
SockAddr.Addr := Cardinal(HostAddr);
Sockets.Connect(Stream.Handle, SockAddr, SizeOf(SockAddr));
if (SocketError <> sys_EINPROGRESS) and (SocketError <> 0) then
raise ESocketError.CreateFmt(SSocketConnectFailed,
[GetPeerName, StrError(SocketError)]);
end;
function TCustomTCPClient.GetPeerName: String;
begin
Result := Format('%s:%d', [Host, Port]);
end;
// TCustomTCPServer
destructor TCustomTCPServer.Destroy;
begin
if Assigned(DataAvailableNotifyHandle) then
begin
EventLoop.ClearDataAvailableNotify(DataAvailableNotifyHandle);
// Set to nil to be sure that descendant classes don't do something stupid
DataAvailableNotifyHandle := nil;
end;
inherited Destroy;
end;
procedure TCustomTCPServer.SetActive(Value: Boolean);
var
Socket: Integer;
Addr: TInetSockAddr;
begin
if Active <> Value then
@ -199,47 +550,42 @@ begin
FActive := False;
if Value then
begin
FSocket := Sockets.Socket(AF_INET, SOCK_STREAM, 0);
if FSocket = -1 then
raise ESocketError.Create(SSocketCreationError);
Socket := Sockets.Socket(AF_INET, SOCK_STREAM, 0);
if Socket = -1 then
raise ESocketError.CreateFmt(SSocketCreationError,
[StrError(SocketError)]);
FStream := TSocketStream.Create(Socket);
Addr.Family := AF_INET;
Addr.Port := ShortHostToNet(Port);
Addr.Addr := 0;
if not Bind(FSocket, Addr, SizeOf(Addr)) then
raise ESocketError.CreateFmt(SSocketBindingError, [Port]);
Listen(FSocket, 5);
DataAvailableNotifyHandle := EventLoop.SetDataAvailableNotify(FSocket,
if not Bind(Socket, Addr, SizeOf(Addr)) then
raise ESocketError.CreateFmt(SSocketBindingError,
[Port, StrError(SocketError)]);
Listen(Socket, 5);
if not Assigned(EventLoop) then
raise ESocketError.Create(SSocketNoEventLoopAssigned);
DataAvailableNotifyHandle := EventLoop.SetDataAvailableNotify(Socket,
@ListenerDataAvailable, nil);
FActive := True;
end else
begin
FileClose(FSocket);
FreeAndNil(FStream);
EventLoop.ClearDataAvailableNotify(DataAvailableNotifyHandle);
DataAvailableNotifyHandle := nil;
end;
end;
end;
procedure TCustomTCPServer.ListenerDataAvailable(Sender: TObject);
var
ClientSocket: Integer;
Addr: TInetSockAddr;
AddrSize: Integer;
begin
AddrSize := SizeOf(Addr);
ClientSocket := Accept(FSocket, Addr, AddrSize);
if ClientSocket = -1 then
raise ESocketError.Create(SSocketAcceptError);
if DoQueryConnect(ClientSocket) then
DoConnect(TSocketStream.Create(ClientSocket));
end;
end.
{
$Log$
Revision 1.1 2003-11-22 11:55:28 sg
Revision 1.2 2004-01-31 19:13:14 sg
* Splittet old HTTP unit into httpbase and httpclient
* Many improvements in fpSock (e.g. better disconnection detection)
Revision 1.1 2003/11/22 11:55:28 sg
* First version, a simple starting point for further development
}

311
fcl/net/http.pp → fcl/net/httpbase.pp
View File

@ -1,7 +1,7 @@
{
$Id$
HTTP: Classes for dealing with HTTP requests
HTTPBase: Common HTTP utility declarations and classes
Copyright (C) 2000-2003 by Sebastian Guenther (sg@freepascal.org)
See the file COPYING.FPC, included in this distribution,
@ -13,11 +13,11 @@
}
unit HTTP;
unit HTTPBase;
interface
uses Classes, SSockets, fpAsync;
uses Classes, fpAsync;
const
@ -197,117 +197,12 @@ type
end;
TCustomHttpConnection = class
protected
FManager: TEventLoop;
FSocket: TInetSocket;
SendBuffer: TAsyncWriteStream;
FOnPrepareSending: TNotifyEvent;
FOnHeaderSent: TNotifyEvent;
FOnStreamSent: TNotifyEvent;
FOnPrepareReceiving: TNotifyEvent;
FOnHeaderReceived: TNotifyEvent;
FOnStreamReceived: TNotifyEvent;
FOnDestroy: TNotifyEvent;
RecvSize: Integer; // How many bytes are still to be read. -1 if unknown.
DataAvailableNotifyHandle: Pointer;
ReceivedHTTPVersion: String;
procedure HeaderToSendCompleted(Sender: TObject);
procedure StreamToSendCompleted(Sender: TObject);
procedure ReceivedHeaderCompleted(Sender: TObject);
procedure ReceivedHeaderEOF(Sender: TObject);
procedure DataAvailable(Sender: TObject);
procedure ReceivedStreamCompleted(Sender: TObject);
property OnPrepareSending: TNotifyEvent read FOnPrepareSending write FOnPrepareSending;
property OnHeaderSent: TNotifyEvent read FOnHeaderSent write FOnHeaderSent;
property OnStreamSent: TNotifyEvent read FOnStreamSent write FOnStreamSent;
property OnPrepareReceiving: TNotifyEvent read FOnPrepareReceiving write FOnPrepareReceiving;
property OnHeaderReceived: TNotifyEvent read FOnHeaderReceived write FOnHeaderReceived;
property OnStreamReceived: TNotifyEvent read FOnStreamReceived write FOnStreamReceived;
property OnDestroy: TNotifyEvent read FOnDestroy write FOnDestroy;
public
HeaderToSend: THttpHeader;
StreamToSend: TStream;
ReceivedHeader: THttpHeader;
ReceivedStream: TStream;
DoDestroy: Boolean;
constructor Create(AManager: TEventLoop; ASocket: TInetSocket);
destructor Destroy; override;
procedure Receive;
procedure Send;
end;
THttpConnection = class(TCustomHttpConnection)
public
property OnPrepareSending;
property OnHeaderSent;
property OnStreamSent;
property OnPrepareReceiving;
property OnHeaderReceived;
property OnStreamReceived;
property OnDestroy;
end;
{TCustomHTTPClient = class
protected
FEventLoop: TEventLoop;
FSocket: TInetSocket;
SendBuffer: TAsyncWriteStream;
FOnPrepareSending: TNotifyEvent;
FOnHeaderSent: TNotifyEvent;
FOnStreamSent: TNotifyEvent;
FOnPrepareReceiving: TNotifyEvent;
FOnHeaderReceived: TNotifyEvent;
FOnStreamReceived: TNotifyEvent;
FOnDestroy: TNotifyEvent;
RecvSize: Integer; // How many bytes are still to be read. -1 if unknown.
DataAvailableNotifyHandle: Pointer;
ReceivedHTTPVersion: String;
procedure HeaderToSendCompleted(Sender: TObject);
procedure StreamToSendCompleted(Sender: TObject);
procedure ReceivedHeaderCompleted(Sender: TObject);
procedure ReceivedHeaderEOF(Sender: TObject);
procedure DataAvailable(Sender: TObject);
procedure ReceivedStreamCompleted(Sender: TObject);
property OnPrepareSending: TNotifyEvent read FOnPrepareSending write FOnPrepareSending;
property OnHeaderSent: TNotifyEvent read FOnHeaderSent write FOnHeaderSent;
property OnStreamSent: TNotifyEvent read FOnStreamSent write FOnStreamSent;
property OnPrepareReceiving: TNotifyEvent read FOnPrepareReceiving write FOnPrepareReceiving;
property OnHeaderReceived: TNotifyEvent read FOnHeaderReceived write FOnHeaderReceived;
property OnStreamReceived: TNotifyEvent read FOnStreamReceived write FOnStreamReceived;
property OnDestroy: TNotifyEvent read FOnDestroy write FOnDestroy;
public
HeaderToSend: THttpHeader;
StreamToSend: TStream;
ReceivedHeader: THttpHeader;
ReceivedStream: TStream;
DoDestroy: Boolean;
constructor Create(AEventLoop: TEventLoop; ASocket: TInetSocket);
destructor Destroy; override;
procedure Receive;
procedure Send;
end;}
// ===================================================================
// ===================================================================
implementation
uses SysUtils;
// -------------------------------------------------------------------
// THttpHeader
// -------------------------------------------------------------------
// THttpHeader
procedure THttpHeader.LineReceived(const ALine: String);
var
@ -587,206 +482,14 @@ begin
CodeText := 'OK';
end;
// -------------------------------------------------------------------
// TCustomHttpConnection
// -------------------------------------------------------------------
procedure TCustomHttpConnection.HeaderToSendCompleted(Sender: TObject);
begin
// WriteLn('TCustomHttpConnection.HeaderToSendCompleted');
if Assigned(FOnHeaderSent) then
FOnHeaderSent(Self);
if Assigned(StreamToSend) then
begin
SendBuffer := TAsyncWriteStream.Create(FManager, FSocket);
SendBuffer.CopyFrom(StreamToSend, StreamToSend.Size);
SendBuffer.OnBufferSent := @StreamToSendCompleted;
end else
begin
StreamToSendCompleted(nil);
if DoDestroy then
Self.Free;
end;
end;
procedure TCustomHttpConnection.StreamToSendCompleted(Sender: TObject);
begin
// WriteLn('TCustomHttpConnection.StreamToSendCompleted');
if Assigned(FOnStreamSent) then
FOnStreamSent(Self);
FreeAndNil(SendBuffer);
if DoDestroy then
Self.Free
else
Receive;
end;
procedure TCustomHttpConnection.ReceivedHeaderCompleted(Sender: TObject);
var
BytesInBuffer: Integer;
NeedMoreData: Boolean;
begin
// WriteLn('TCustomHttpConnection.ReceivedHeaderCompleted');
ReceivedHeader.DataReceived := False;
ReceivedHTTPVersion := ReceivedHeader.HttpVersion;
BytesInBuffer := ReceivedHeader.Reader.BytesInBuffer;
//WriteLn('BytesInBuffer: ', BytesInBuffer, ', Content length: ', ReceivedHeader.ContentLength);
if Assigned(FOnHeaderReceived) then
FOnHeaderReceived(Self);
RecvSize := ReceivedHeader.ContentLength;
if Assigned(ReceivedStream) then
begin
if BytesInBuffer = 0 then
NeedMoreData := True
else
begin
ReceivedStream.Write(ReceivedHeader.Reader.Buffer^, BytesInBuffer);
if RecvSize > 0 then
Dec(RecvSize, BytesInBuffer);
if BytesInBuffer = ReceivedHeader.ContentLength then
NeedMoreData := False
else
NeedMoreData := (not ReceivedHeader.InheritsFrom(THttpRequestHeader)) or
(THttpRequestHeader(ReceivedHeader).Command <> 'GET');
end;
end else
NeedMoreData := False;
if NeedMoreData then
DataAvailableNotifyHandle :=
FManager.SetDataAvailableNotify(FSocket.Handle, @DataAvailable, FSocket)
else
ReceivedStreamCompleted(nil);
if DoDestroy then
Self.Free;
end;
procedure TCustomHttpConnection.ReceivedHeaderEOF(Sender: TObject);
begin
Self.Free;
end;
procedure TCustomHttpConnection.DataAvailable(Sender: TObject);
var
FirstRun: Boolean;
ReadNow, BytesRead: Integer;
buf: array[0..1023] of Byte;
begin
FirstRun := True;
while True do
begin
if RecvSize >= 0 then
begin
ReadNow := RecvSize;
if ReadNow > 1024 then
ReadNow := 1024;
end else
ReadNow := 1024;
BytesRead := FSocket.Read(buf, ReadNow);
// WriteLn('TCustomHttpConnection.DataAvailable: Read ', BytesRead, ' bytes; RecvSize=', RecvSize);
if BytesRead <= 0 then
begin
if FirstRun then
ReceivedStreamCompleted(nil);
break;
end;
FirstRun := False;
ReceivedStream.Write(buf, BytesRead);
if RecvSize > 0 then
Dec(RecvSize, BytesRead);
if RecvSize = 0 then
begin
ReceivedStreamCompleted(nil);
break;
end;
end;
if DoDestroy then
Self.Free;
end;
procedure TCustomHttpConnection.ReceivedStreamCompleted(Sender: TObject);
begin
// WriteLn('TCustomHttpConnection.ReceivedStreamCompleted');
if Assigned(DataAvailableNotifyHandle) then
begin
FManager.ClearDataAvailableNotify(DataAvailableNotifyHandle);
DataAvailableNotifyHandle := nil;
end;
if Assigned(FOnStreamReceived) then
FOnStreamReceived(Self);
if DoDestroy then
Self.Free
else
Send;
end;
constructor TCustomHttpConnection.Create(AManager: TEventLoop; ASocket: TInetSocket);
begin
inherited Create;
FManager := AManager;
FSocket := ASocket;
end;
destructor TCustomHttpConnection.Destroy;
begin
if Assigned(DataAvailableNotifyHandle) then
FManager.ClearDataAvailableNotify(DataAvailableNotifyHandle);
if Assigned(OnDestroy) then
OnDestroy(Self);
FreeAndNil(SendBuffer);
inherited Destroy;
end;
procedure TCustomHttpConnection.Receive;
begin
// Start receiver
ReceivedHttpVersion := '';
if Assigned(OnPrepareReceiving) then
OnPrepareReceiving(Self);
if Assigned(ReceivedHeader) then
begin
ReceivedHeader.OnCompleted := @ReceivedHeaderCompleted;
ReceivedHeader.OnEOF := @ReceivedHeaderEOF;
ReceivedHeader.AsyncReceive(FManager, FSocket);
end;
end;
procedure TCustomHttpConnection.Send;
begin
// Start sender
if Assigned(OnPrepareSending) then
OnPrepareSending(Self);
if Assigned(HeaderToSend) then
begin
if ReceivedHttpVersion <> '' then
begin
HeaderToSend.HttpVersion := ReceivedHttpVersion;
ReceivedHttpVersion := '';
end;
HeaderToSend.OnCompleted := @HeaderToSendCompleted;
HeaderToSend.AsyncSend(FManager, FSocket);
end;
end;
end.
{
$Log$
Revision 1.3 2003-11-22 11:59:19 sg
* Many many changes to prepare a shift to using the servlet classes for
HTTP servers; this unit will then contain basic HTTP definitions and a
client-only class
Revision 1.1 2004-01-31 19:13:14 sg
* Splittet old HTTP unit into httpbase and httpclient
* Many improvements in fpSock (e.g. better disconnection detection)
Revision 1.2 2003/06/18 19:13:04 sg
* Fixed silly typo in THttpHeader.SetHeaderValues
Revision 1.1 2002/04/25 19:30:29 sg
* First version (with exception of the HTTP unit: This is an improved version
of the old asyncio HTTP unit, now adapted to fpAsync)
}

314
fcl/net/httpclient.pp Normal file
View File

@ -0,0 +1,314 @@
{
$Id$
HTTPClient: HTTP client component
Copyright (C) 2000-2003 by Sebastian Guenther (sg@freepascal.org)
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
}
unit HTTPClient;
interface
uses Classes, HTTPBase, fpSock, fpAsync;
type
TCustomHTTPClient = class(TCustomTCPClient)
protected
SendBuffer: TAsyncWriteStream;
FOnPrepareSending: TNotifyEvent;
FOnHeaderSent: TNotifyEvent;
FOnStreamSent: TNotifyEvent;
FOnPrepareReceiving: TNotifyEvent;
FOnHeaderReceived: TNotifyEvent;
FOnStreamReceived: TNotifyEvent;
FOnDestroy: TNotifyEvent;
RecvSize: Integer; // How many bytes are still to be read. -1 if unknown.
DataAvailableNotifyHandle: Pointer;
ReceivedHTTPVersion: String;
procedure HeaderToSendCompleted(Sender: TObject);
procedure StreamToSendCompleted(Sender: TObject);
procedure ReceivedHeaderCompleted(Sender: TObject);
procedure ReceivedHeaderEOF(Sender: TObject);
procedure DataAvailable(Sender: TObject);
procedure ReceivedStreamCompleted(Sender: TObject);
property OnPrepareSending: TNotifyEvent read FOnPrepareSending write FOnPrepareSending;
property OnHeaderSent: TNotifyEvent read FOnHeaderSent write FOnHeaderSent;
property OnStreamSent: TNotifyEvent read FOnStreamSent write FOnStreamSent;
property OnPrepareReceiving: TNotifyEvent read FOnPrepareReceiving write FOnPrepareReceiving;
property OnHeaderReceived: TNotifyEvent read FOnHeaderReceived write FOnHeaderReceived;
property OnStreamReceived: TNotifyEvent read FOnStreamReceived write FOnStreamReceived;
property OnDestroy: TNotifyEvent read FOnDestroy write FOnDestroy;
public
HeaderToSend: THttpHeader;
StreamToSend: TStream;
ReceivedHeader: THttpHeader;
ReceivedStream: TStream;
DoDestroy: Boolean;
destructor Destroy; override;
// procedure Receive;
// procedure Send;
end;
THttpClient = class(TCustomHttpClient)
public
property OnPrepareSending;
property OnHeaderSent;
property OnStreamSent;
property OnPrepareReceiving;
property OnHeaderReceived;
property OnStreamReceived;
property OnDestroy;
end;
{TCustomHTTPClient = class
protected
FEventLoop: TEventLoop;
FSocket: TInetSocket;
SendBuffer: TAsyncWriteStream;
FOnPrepareSending: TNotifyEvent;
FOnHeaderSent: TNotifyEvent;
FOnStreamSent: TNotifyEvent;
FOnPrepareReceiving: TNotifyEvent;
FOnHeaderReceived: TNotifyEvent;
FOnStreamReceived: TNotifyEvent;
FOnDestroy: TNotifyEvent;
RecvSize: Integer; // How many bytes are still to be read. -1 if unknown.
DataAvailableNotifyHandle: Pointer;
ReceivedHTTPVersion: String;
procedure HeaderToSendCompleted(Sender: TObject);
procedure StreamToSendCompleted(Sender: TObject);
procedure ReceivedHeaderCompleted(Sender: TObject);
procedure ReceivedHeaderEOF(Sender: TObject);
procedure DataAvailable(Sender: TObject);
procedure ReceivedStreamCompleted(Sender: TObject);
property OnPrepareSending: TNotifyEvent read FOnPrepareSending write FOnPrepareSending;
property OnHeaderSent: TNotifyEvent read FOnHeaderSent write FOnHeaderSent;
property OnStreamSent: TNotifyEvent read FOnStreamSent write FOnStreamSent;
property OnPrepareReceiving: TNotifyEvent read FOnPrepareReceiving write FOnPrepareReceiving;
property OnHeaderReceived: TNotifyEvent read FOnHeaderReceived write FOnHeaderReceived;
property OnStreamReceived: TNotifyEvent read FOnStreamReceived write FOnStreamReceived;
property OnDestroy: TNotifyEvent read FOnDestroy write FOnDestroy;
public
HeaderToSend: THttpHeader;
StreamToSend: TStream;
ReceivedHeader: THttpHeader;
ReceivedStream: TStream;
DoDestroy: Boolean;
constructor Create(AEventLoop: TEventLoop; ASocket: TInetSocket);
destructor Destroy; override;
procedure Receive;
procedure Send;
end;}
implementation
uses SysUtils;
procedure TCustomHttpClient.HeaderToSendCompleted(Sender: TObject);
begin
// WriteLn('TCustomHttpClient.HeaderToSendCompleted');
if Assigned(FOnHeaderSent) then
FOnHeaderSent(Self);
if Assigned(StreamToSend) then
begin
SendBuffer := TAsyncWriteStream.Create(EventLoop, FSocket);
SendBuffer.CopyFrom(StreamToSend, StreamToSend.Size);
SendBuffer.OnBufferSent := @StreamToSendCompleted;
end else
begin
StreamToSendCompleted(nil);
if DoDestroy then
Self.Free;
end;
end;
procedure TCustomHttpClient.StreamToSendCompleted(Sender: TObject);
begin
// WriteLn('TCustomHttpClient.StreamToSendCompleted');
if Assigned(FOnStreamSent) then
FOnStreamSent(Self);
FreeAndNil(SendBuffer);
if DoDestroy then
Self.Free
else
Receive;
end;
procedure TCustomHttpClient.ReceivedHeaderCompleted(Sender: TObject);
var
BytesInBuffer: Integer;
NeedMoreData: Boolean;
begin
// WriteLn('TCustomHttpClient.ReceivedHeaderCompleted');
ReceivedHeader.DataReceived := False;
ReceivedHTTPVersion := ReceivedHeader.HttpVersion;
BytesInBuffer := ReceivedHeader.Reader.BytesInBuffer;
//WriteLn('BytesInBuffer: ', BytesInBuffer, ', Content length: ', ReceivedHeader.ContentLength);
if Assigned(FOnHeaderReceived) then
FOnHeaderReceived(Self);
RecvSize := ReceivedHeader.ContentLength;
if Assigned(ReceivedStream) then
begin
if BytesInBuffer = 0 then
NeedMoreData := True
else
begin
ReceivedStream.Write(ReceivedHeader.Reader.Buffer^, BytesInBuffer);
if RecvSize > 0 then
Dec(RecvSize, BytesInBuffer);
if BytesInBuffer = ReceivedHeader.ContentLength then
NeedMoreData := False
else
NeedMoreData := (not ReceivedHeader.InheritsFrom(THttpRequestHeader)) or
(THttpRequestHeader(ReceivedHeader).Command <> 'GET');
end;
end else
NeedMoreData := False;
if NeedMoreData then
DataAvailableNotifyHandle :=
EventLoop.SetDataAvailableNotify(FSocket.Handle, @DataAvailable, FSocket)
else
ReceivedStreamCompleted(nil);
if DoDestroy then
Self.Free;
end;
procedure TCustomHttpClient.ReceivedHeaderEOF(Sender: TObject);
begin
Self.Free;
end;
procedure TCustomHttpClient.DataAvailable(Sender: TObject);
var
FirstRun: Boolean;
ReadNow, BytesRead: Integer;
buf: array[0..1023] of Byte;
begin
FirstRun := True;
while True do
begin
if RecvSize >= 0 then
begin
ReadNow := RecvSize;
if ReadNow > 1024 then
ReadNow := 1024;
end else
ReadNow := 1024;
BytesRead := FSocket.Read(buf, ReadNow);
// WriteLn('TCustomHttpClient.DataAvailable: Read ', BytesRead, ' bytes; RecvSize=', RecvSize);
if BytesRead <= 0 then
begin
if FirstRun then
ReceivedStreamCompleted(nil);
break;
end;
FirstRun := False;
ReceivedStream.Write(buf, BytesRead);
if RecvSize > 0 then
Dec(RecvSize, BytesRead);
if RecvSize = 0 then
begin
ReceivedStreamCompleted(nil);
break;
end;
end;
if DoDestroy then
Self.Free;
end;
procedure TCustomHttpClient.ReceivedStreamCompleted(Sender: TObject);
begin
// WriteLn('TCustomHttpClient.ReceivedStreamCompleted');
if Assigned(DataAvailableNotifyHandle) then
begin
EventLoop.ClearDataAvailableNotify(DataAvailableNotifyHandle);
DataAvailableNotifyHandle := nil;
end;
if Assigned(FOnStreamReceived) then
FOnStreamReceived(Self);
if DoDestroy then
Self.Free
else
Send;
end;
constructor TCustomHttpClient.Create(AManager: TEventLoop; ASocket: TInetSocket);
begin
inherited Create;
EventLoop := AManager;
FSocket := ASocket;
end;
destructor TCustomHttpClient.Destroy;
begin
if Assigned(DataAvailableNotifyHandle) then
EventLoop.ClearDataAvailableNotify(DataAvailableNotifyHandle);
if Assigned(OnDestroy) then
OnDestroy(Self);
FreeAndNil(SendBuffer);
inherited Destroy;
end;
procedure TCustomHttpClient.Receive;
begin
// Start receiver
ReceivedHttpVersion := '';
if Assigned(OnPrepareReceiving) then
OnPrepareReceiving(Self);
if Assigned(ReceivedHeader) then
begin
ReceivedHeader.OnCompleted := @ReceivedHeaderCompleted;
ReceivedHeader.OnEOF := @ReceivedHeaderEOF;
ReceivedHeader.AsyncReceive(EventLoop, FSocket);
end;
end;
procedure TCustomHttpClient.Send;
begin
// Start sender
if Assigned(OnPrepareSending) then
OnPrepareSending(Self);
if Assigned(HeaderToSend) then
begin
if ReceivedHttpVersion <> '' then
begin
HeaderToSend.HttpVersion := ReceivedHttpVersion;
ReceivedHttpVersion := '';
end;
HeaderToSend.OnCompleted := @HeaderToSendCompleted;
HeaderToSend.AsyncSend(EventLoop, FSocket);
end;
end;
end.
{
$Log$
Revision 1.1 2004-01-31 19:13:14 sg
* Splittet old HTTP unit into httpbase and httpclient
* Many improvements in fpSock (e.g. better disconnection detection)
}

8
fcl/net/httpsvlt.pp
View File

@ -17,7 +17,7 @@ unit HTTPSvlt;
interface
uses SysUtils, Classes, fpAsync, fpSock, HTTP, Servlets;
uses SysUtils, Classes, fpAsync, fpSock, HTTPBase, Servlets;
resourcestring
SErrUnknownMethod = 'Unknown HTTP method "%s" used';
@ -633,7 +633,11 @@ end.
{
$Log$
Revision 1.3 2003-11-22 12:01:18 sg
Revision 1.4 2004-01-31 19:13:14 sg
* Splittet old HTTP unit into httpbase and httpclient
* Many improvements in fpSock (e.g. better disconnection detection)
Revision 1.3 2003/11/22 12:01:18 sg
* Adaptions to new version of HTTP unit: All server functionality now is
in this unit, and not http.pp anymore

3
fcl/net/tests/rpcserv.pp
View File

@ -30,6 +30,7 @@ begin
XMLRPCServlet.ServerClass := ServerClass;
HttpServer := THttpServer.Create(Self);
HttpServer.EventLoop := EventLoop;
if ParamCount = 2 then
HttpServer.Port := StrToInt(ParamStr(1))
else
@ -51,7 +52,7 @@ end;
procedure TServerApplication.Run;
begin
EventLoop.SetDataAvailableNotify(StdInputHandle, @OnKeyboardData, nil);
HttpServer.Start(EventLoop);
HttpServer.Active := True;
EventLoop.Run;
end;