paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-09-14 12:30:24 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Better error handling, continue to serve requests (bug ID 22260)

Browse Source 
git-svn-id: trunk@23238 -
This commit is contained in:
michael 2012-12-28 11:38:46 +00:00
parent 764b132645
commit 91c8177890
2 changed files with 127 additions and 42 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
packages/fcl-web/src/base/custhttpapp.pp
View File

@ -48,6 +48,7 @@ Type
var ARequest: TFPHTTPConnectionRequest;
var AResponse: TFPHTTPConnectionResponse);
Private
FOnRequestError: TRequestErrorHandler;
FServer: TEmbeddedHTTPServer;
function GetAllowConnect: TConnectQuery;
function GetPort: Word;
@ -58,6 +59,7 @@ Type
procedure SetQueueSize(const AValue: Word);
procedure SetThreaded(const AValue: Boolean);
protected
procedure HandleRequestError(Sender: TObject; E: Exception); virtual;
Procedure InitRequest(ARequest : TRequest); override;
Procedure InitResponse(AResponse : TResponse); override;
function WaitForRequest(out ARequest : TRequest; out AResponse : TResponse) : boolean; override;
@ -75,6 +77,8 @@ Type
Property OnAllowConnect : TConnectQuery Read GetAllowConnect Write SetOnAllowConnect;
// Use a thread to handle a connection ?
property Threaded : Boolean read GetThreaded Write SetThreaded;
// Handle On Request error. If not set, error is logged.
Property OnRequestError : TRequestErrorHandler Read FOnRequestError Write FOnRequestError;
end;
{ TCustomHTTPApplication }
@ -102,14 +106,6 @@ Type
property Threaded : Boolean read GetThreaded Write SetThreaded;
end;
ResourceString
SNoInputHandle = 'Failed to open input-handle passed from server. Socket Error: %d';
SNoSocket = 'Failed to open socket. Socket Error: %d';
SBindFailed = 'Failed to bind to port %d. Socket Error: %d';
SListenFailed = 'Failed to listen to port %d. Socket Error: %d';
SErrReadingSocket = 'Failed to read data from socket. Error: %d';
SErrReadingHeader = 'Failed to read FastCGI header. Read only %d bytes';
SErrWritingSocket = 'Failed to write data to socket. Error: %d';
Implementation
@ -185,6 +181,19 @@ end;
{ TFPHTTPServerHandler }
procedure TFPHTTPServerHandler.HandleRequestError(Sender: TObject; E: Exception
);
begin
Try
If Assigned(FOnRequestError) then
FOnRequestError(Sender,E)
else
Log(etError,Format('Error (%s) handling request : %s',[E.ClassName,E.Message]));
except
// Do not let errors escape
end;
end;
procedure TFPHTTPServerHandler.HTTPHandleRequest(Sender: TObject;
var ARequest: TFPHTTPConnectionRequest;
var AResponse: TFPHTTPConnectionResponse);
@ -273,6 +282,7 @@ begin
FServer:=CreateServer;
FServer.FWebHandler:=Self;
FServer.OnRequest:=@HTTPHandleRequest;
Fserver.OnRequestError:=@HandleRequestError;
end;
destructor TFPHTTPServerHandler.Destroy;

143
packages/fcl-web/src/base/fphttpserver.pp
View File

@ -29,6 +29,7 @@ Type
TFPHTTPConnection = Class;
TFPHTTPConnectionThread = Class;
TFPCustomHttpServer = Class;
TRequestErrorHandler = Procedure (Sender : TObject; E : Exception) of object;
{ TFPHTTPConnectionRequest }
@ -61,6 +62,7 @@ Type
TFPHTTPConnection = Class(TObject)
private
FOnError: TRequestErrorHandler;
FServer: TFPCustomHTTPServer;
FSocket: TSocketStream;
FBuffer : Ansistring;
@ -69,6 +71,8 @@ Type
Protected
procedure ReadRequestContent(ARequest: TFPHTTPConnectionRequest); virtual;
procedure UnknownHeader(ARequest: TFPHTTPConnectionRequest; const AHeader: String); virtual;
procedure HandleRequestError(E : Exception); virtual;
Procedure SetupSocket; virtual;
Function ReadRequestHeaders : TFPHTTPConnectionRequest;
Public
Constructor Create(AServer : TFPCustomHTTPServer; ASocket : TSocketStream);
@ -76,6 +80,7 @@ Type
Procedure HandleRequest; virtual;
Property Socket : TSocketStream Read FSocket;
Property Server : TFPCustomHTTPServer Read FServer;
Property OnRequestError : TRequestErrorHandler Read FOnError Write FOnError;
end;
{ TFPHTTPConnectionThread }
@ -102,6 +107,7 @@ Type
FAdminName: string;
FOnAllowConnect: TConnectQuery;
FOnRequest: THTTPServerRequestHandler;
FOnRequestError: TRequestErrorHandler;
FPort: Word;
FQueueSize: Word;
FServer : TInetServer;
@ -114,6 +120,8 @@ Type
procedure SetPort(const AValue: Word);
procedure SetQueueSize(const AValue: Word);
procedure SetThreaded(const AValue: Boolean);
procedure SetupSocket;
procedure StartServerSocket;
Protected
// Override these to create descendents of the request/response instead.
Function CreateRequest : TFPHTTPConnectionRequest; virtual;
@ -135,6 +143,8 @@ Type
// Handle request. This calls OnRequest. It can be overridden by descendants to provide standard handling.
procedure HandleRequest(Var ARequest: TFPHTTPConnectionRequest;
Var AResponse : TFPHTTPConnectionResponse); virtual;
// Called when a connection encounters an unexpected error. Will call OnRequestError when set.
procedure HandleRequestError(Sender: TObject; E: Exception); virtual;
public
Constructor Create(AOwner : TComponent); override;
Destructor Destroy; override;
@ -151,7 +161,8 @@ Type
property Threaded : Boolean read FThreaded Write SetThreaded;
// Called to handle the request. If Threaded=True, it is called in a the connection thread.
Property OnRequest : THTTPServerRequestHandler Read FOnRequest Write FOnRequest;
// Called when an unexpected error occurs during handling of the request. Sender is the TFPHTTPConnection.
Property OnRequestError : TRequestErrorHandler Read FOnRequestError Write FOnRequestError;
published
//aditional server information
property AdminMail: string read FAdminMail write FAdminMail;
@ -167,6 +178,7 @@ Type
Property OnAllowConnect;
property Threaded;
Property OnRequest;
Property OnRequestError;
end;
EHTTPServer = Class(Exception);
@ -175,6 +187,8 @@ Type
implementation
uses sockets;
resourcestring
SErrSocketActive = 'Operation not allowed while server is active';
SErrReadingSocket = 'Error reading data from the socket';
@ -230,6 +244,11 @@ begin
end;
end;
procedure HandleRequestError(Sender: TObject; E: Exception);
begin
end;
procedure TFPHTTPConnectionRequest.InitRequestVars;
Var
P : Integer;
@ -357,6 +376,24 @@ begin
// Do nothing
end;
procedure TFPHTTPConnection.HandleRequestError(E: Exception);
begin
If Assigned(FOnError) then
try
FOnError(Self,E);
except
// We really cannot handle this...
end;
end;
procedure TFPHTTPConnection.SetupSocket;
begin
{$ifdef unix}
FSocket.ReadFlags:=MSG_NOSIGNAL;
FSocket.WriteFlags:=MSG_NOSIGNAL;
{$endif}
end;
Procedure TFPHTTPConnection.InterPretHeader(ARequest : TFPHTTPConnectionRequest; Const AHeader : String);
Var
@ -446,15 +483,20 @@ Var
StartLine,S : String;
begin
Result:=Server.CreateRequest;
Server.InitRequest(Result);
Result.FConnection:=Self;
StartLine:=ReadString;
ParseStartLine(Result,StartLine);
Repeat
S:=ReadString;
if (S<>'') then
InterPretHeader(Result,S);
Until (S='');
try
Server.InitRequest(Result);
Result.FConnection:=Self;
StartLine:=ReadString;
ParseStartLine(Result,StartLine);
Repeat
S:=ReadString;
if (S<>'') then
InterPretHeader(Result,S);
Until (S='');
except
FreeAndNil(Result);
Raise;
end;
end;
constructor TFPHTTPConnection.Create(AServer: TFPCustomHttpServer; ASocket: TSocketStream);
@ -476,30 +518,36 @@ Var
Resp : TFPHTTPConnectionResponse;
begin
// Read headers.
Req:=ReadRequestHeaders;
//set port
Req.ServerPort := Server.Port;
try
// Read content, if any
If Req.ContentLength>0 then
ReadRequestContent(Req);
Req.InitRequestVars;
// Create Response
Resp:= Server.CreateResponse(Req);
Try
SetupSocket;
// Read headers.
Req:=ReadRequestHeaders;
try
Server.InitResponse(Resp);
Resp.FConnection:=Self;
// And dispatch
if Server.Active then
Server.HandleRequest(Req,Resp);
if Assigned(Resp) and (not Resp.ContentSent) then
Resp.SendContent;
finally
FreeAndNil(Resp);
//set port
Req.ServerPort := Server.Port;
// Read content, if any
If Req.ContentLength>0 then
ReadRequestContent(Req);
Req.InitRequestVars;
// Create Response
Resp:= Server.CreateResponse(Req);
try
Server.InitResponse(Resp);
Resp.FConnection:=Self;
// And dispatch
if Server.Active then
Server.HandleRequest(Req,Resp);
if Assigned(Resp) and (not Resp.ContentSent) then
Resp.SendContent;
finally
FreeAndNil(Resp);
end;
Finally
FreeAndNil(Req);
end;
Finally
FreeAndNil(Req);
Except
On E : Exception do
HandleRequestError(E);
end;
end;
@ -528,6 +576,18 @@ end;
{ TFPCustomHttpServer }
procedure TFPCustomHttpServer.HandleRequestError(Sender: TObject; E: Exception);
begin
If Assigned(FOnRequestError) then
try
FOnRequestError(Sender,E);
except
// Do not let errors in user code escape.
end
else
Writeln('Unhandled exception : ',E.ClassName,' : ',E.Message);
end;
function TFPCustomHttpServer.GetActive: Boolean;
begin
if (csDesigning in ComponentState) then
@ -542,7 +602,11 @@ begin
FLoadActivate:=AValue;
if not (csDesigning in Componentstate) then
if AValue then
CreateServerSocket
begin
CreateServerSocket;
SetupSocket;
StartServerSocket;
end
else
FreeServerSocket;
end;
@ -622,6 +686,7 @@ begin
Con:=CreateConnection(Data);
try
Con.FServer:=Self;
Con.OnRequestError:=@HandleRequestError;
if Threaded then
CreateConnectionThread(Con)
else
@ -634,13 +699,23 @@ begin
end;
end;
procedure TFPCustomHttpServer.SetupSocket;
begin
FServer.QueueSize:=Self.QueueSize;
FServer.ReuseAddress:=true;
end;
procedure TFPCustomHttpServer.CreateServerSocket;
begin
FServer:=TInetServer.Create(FPort);
FServer.MaxConnections:=-1;
FServer.OnConnectQuery:=OnAllowConnect;
FServer.OnConnect:=@DOConnect;
FServer.QueueSize:=Self.QueueSize;
end;
procedure TFPCustomHttpServer.StartServerSocket;
begin
FServer.Bind;
FServer.Listen;
FServer.StartAccepting;