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

git-svn-id: trunk@23238 -

packages/fcl-web/src/base/custhttpapp.pp

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

packages/fcl-web/src/base/fphttpserver.pp

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