* Improved exception handling. Introduced StatusCode/Text in EHTTPError, is used to set HTTP status code/text when sending the response.

git-svn-id: trunk@28196 -

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

@@ -21,7 +21,7 @@ unit cgiapp;
 Interface
 
 uses
-  CustApp,Classes,SysUtils;
+  CustApp,Classes, SysUtils, httpdefs;
 
 Const
   CGIVarCount = 23 deprecated;
@@ -128,6 +128,8 @@ Type
     Property Response : TStream Read FResponse; deprecated;
   end;
 
+  ECGI = Class(Exception);
+
 ResourceString
   SWebMaster = 'webmaster' deprecated;
   SCGIError  = 'CGI Error' deprecated;
@@ -428,13 +430,13 @@ var
 begin
   R:=RequestMethod;
   if (R='') then
-    Raise Exception.Create(SErrNoRequestMethod);
+    Raise ECGI.Create(SErrNoRequestMethod);
   if CompareText(R,'POST')=0 then
     InitPostVars
   else if CompareText(R,'GET')=0 then
     InitGetVars
   else
-    Raise Exception.CreateFmt(SErrInvalidRequestMethod,[R]);
+    Raise ECGI.CreateFmt(SErrInvalidRequestMethod,[R]);
 end;
 
 Procedure TCgiApplication.ProcessURLEncoded(M : TMemoryStream);
@@ -622,7 +624,7 @@ begin
       FI:=TFormItem(L[i]);
       FI.Process;
       If (FI.Name='') then
-        Raise Exception.CreateFmt('Invalid multipart encoding: %s',[FI.Data]);
+        Raise ECGI.CreateFmt('Invalid multipart encoding: %s',[FI.Data]);
       Key:=FI.Name;
       If Not FI.IsFile Then
         begin
@@ -691,7 +693,7 @@ begin
     else if CompareText(ContentType,'APPLICATION/X-WWW-FORM-URLENCODED')=0 then
       ProcessUrlEncoded(M)
     else
-      Raise Exception.CreateFmt(SErrUnsupportedContentType,[ContentType]);
+      Raise ECGI.CreateFmt(SErrUnsupportedContentType,[ContentType]);
   finally
     M.Free;
   end;

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

@@ -118,6 +118,8 @@ Type
     Property RequestVariableCount : Integer Read GetRequestVariableCount;
   end;
 
+  ECGI = Class(EFPWebError);
+
 Var
   CGIRequestClass : TCGIRequestClass = TCGIRequest;
   CGIResponseClass : TCGIResponseClass = TCGIResponse;

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

@@ -293,7 +293,7 @@ begin
       FUR(Self,AFCGIRecord)
     else
       if poFailonUnknownRecord in FPO then
-        Raise EFPWebError.CreateFmt('Unknown FASTCGI record type: %s',[AFCGIRecord^.reqtype]);
+        TFCgiHandler.DoError('Unknown FASTCGI record type: %s',[AFCGIRecord^.reqtype]);
   end;
 end;
 
@@ -429,7 +429,7 @@ var ErrorCode,
     
 begin
   if Not (Request is TFCGIRequest) then
-    Raise Exception.Create(SErrNorequest);
+    TFCgiHandler.DoError(SErrNorequest);
   R:=TFCGIRequest(Request);
   BytesToWrite := BEtoN(ARecord^.contentLength) + ARecord^.paddingLength+sizeof(FCGI_Header);
   P:=PByte(Arecord);
@@ -439,7 +439,7 @@ begin
       begin
       // TODO : Better checking on ErrorCode
       R.FKeepConnectionAfterRequest:=False;
-      Raise HTTPError.CreateFmt(SErrWritingSocket,[ErrorCode]);
+      TFCgiHandler.DoError(SErrWritingSocket,[ErrorCode]);
       end;
     Inc(P,BytesWritten);
     Dec(BytesToWrite,BytesWritten);
@@ -697,7 +697,7 @@ function TFCgiHandler.Read_FCGIRecord : PFCGI_Header;
         Inc(Result,Count);
         end
       else if (Count<0) then
-        Raise HTTPError.CreateFmt(SErrReadingSocket,[Count]);
+        DoError(SErrReadingSocket,[Count]);
     until (ByteAmount=0) or (Count=0);
   end;
 
@@ -719,7 +719,7 @@ begin
     // TODO : if connection closed gracefully, the request should no longer be handled.
     // Need to discard request/response
   else If (BytesRead<>Sizeof(Header)) then
-    Raise HTTPError.CreateFmt(SErrReadingHeader,[BytesRead]);
+    DoError(SErrReadingHeader,[BytesRead]);
   ContentLength:=BetoN(Header.contentLength);
   PaddingLength:=Header.paddingLength;
   Getmem(ResRecord,BytesRead+ContentLength+PaddingLength);
@@ -758,7 +758,7 @@ begin
   AddressLength:=Sizeof(IAddress);
   Socket := fpsocket(AF_INET,SOCK_STREAM,0);
   if Socket=-1 then
-    raise EFPWebError.CreateFmt(SNoSocket,[socketerror]);
+    DoError(SNoSocket,[socketerror]);
   IAddress.sin_family:=AF_INET;
   IAddress.sin_port:=htons(Port);
   if FAddress<>'' then
@@ -775,7 +775,7 @@ begin
     CloseSocket(socket);
     Socket:=0;
     Terminate;
-    raise Exception.CreateFmt(SBindFailed,[port,socketerror]);
+    DoError(SBindFailed,[port,socketerror]);
     end;
   if (FLingerTimeout>0) then
     begin
@@ -798,7 +798,7 @@ begin
     CloseSocket(socket);
     Socket:=0;
     Terminate;
-    raise Exception.CreateFmt(SListenFailed,[port,socketerror]);
+    DoError(SListenFailed,[port,socketerror]);
     end;
 end;
 
@@ -994,7 +994,7 @@ begin
       if not terminated then
         begin
         Terminate;
-        raise Exception.CreateFmt(SNoInputHandle,[socketerror]);
+        DoError(SNoInputHandle,[socketerror]);
         end
       end;
     repeat

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

@@ -106,6 +106,8 @@ Type
     FOnLog : TLogEvent;
     FPreferModuleName : Boolean;
   protected
+    Class Procedure DoError(Msg : String; AStatusCode : Integer = 0; AStatusText : String = '');
+    Class Procedure DoError(Fmt : String; Const Args : Array of const;AStatusCode : Integer = 0; AStatusText : String = '');
     procedure Terminate; virtual;
     Function GetModuleName(Arequest : TRequest) : string;
     function WaitForRequest(out ARequest : TRequest; out AResponse : TResponse) : boolean; virtual; abstract;
@@ -205,7 +207,7 @@ Type
     Property PreferModuleName : Boolean Read GetPreferModuleName Write SetPreferModuleName;
   end;
 
-  EFPWebError = Class(Exception);
+  EFPWebError = Class(EFPHTTPError);
 
 procedure ExceptionToHTML(S: TStrings; const E: Exception; const Title, Email, Administrator: string);
 
@@ -254,7 +256,7 @@ begin
     end;
 end;
 
-procedure TWebHandler.Run;
+Procedure TWebHandler.Run;
 var ARequest : TRequest;
     AResponse : TResponse;
 begin
@@ -267,16 +269,29 @@ begin
     end;
 end;
 
-procedure TWebHandler.Log(EventType: TEventType; const Msg: String);
+Procedure TWebHandler.Log(EventType: TEventType; Const Msg: String);
 begin
   If Assigned(FOnLog) then
     FOnLog(EventType,Msg);
 end;
 
 procedure TWebHandler.ShowRequestException(R: TResponse; E: Exception);
+
+  Function GetStatusCode : integer;
+
+  begin
+    if (E is EHTTP) then
+      Result:=EHTTP(E).StatusCode
+    else
+      Result:=E.HelpContext;
+    if (Result=0) then
+      Result:=500;
+  end;
+
 Var
- S : TStrings;
- handled: boolean;
+  S : TStrings;
+  handled: boolean;
+  CT : String;
 
 begin
   if R.ContentSent then exit;
@@ -294,8 +309,14 @@ begin
     end;
   If (not R.HeadersSent) then
     begin
-    R.Code:=500;
-    R.CodeText:='Application error '+E.ClassName;
+    R.Code:=GetStatusCode;
+    if (E is EHTTP) Then
+      CT:=EHTTP(E).StatusText
+    else
+      CT:='';
+    if (CT='') then
+      CT:='Application error '+E.ClassName;;
+    R.CodeText:=CT;
     R.ContentType:='text/html';
     end;
   If (R.ContentType='text/html') then
@@ -311,27 +332,27 @@ begin
     end;
 end;
 
-procedure TWebHandler.InitRequest(ARequest: TRequest);
+Procedure TWebHandler.InitRequest(ARequest: TRequest);
 begin
   ARequest.OnUnknownEncoding:=Self.OnUnknownRequestEncoding;
 end;
 
-procedure TWebHandler.InitResponse(AResponse: TResponse);
+Procedure TWebHandler.InitResponse(AResponse: TResponse);
 begin
   // Do nothing
 end;
 
-function TWebHandler.GetEmail: String;
+Function TWebHandler.GetEmail: String;
 begin
   Result := FEmail;
 end;
 
-function TWebHandler.GetAdministrator: String;
+Function TWebHandler.GetAdministrator: String;
 begin
   Result := FAdministrator;
 end;
 
-procedure TWebHandler.HandleRequest(ARequest: TRequest; AResponse: TResponse);
+Procedure TWebHandler.HandleRequest(ARequest: TRequest; AResponse: TResponse);
 Var
   MC : TCustomHTTPModuleClass;
   M  : TCustomHTTPModule;
@@ -350,7 +371,7 @@ begin
       MN:=GetModuleName(ARequest);
       MI:=ModuleFactory.FindModule(MN);
       if (MI=Nil) then
-        Raise EFPWebError.CreateFmt(SErrNoModuleForRequest,[MN]);
+        DoError(SErrNoModuleForRequest,[MN],400,'Not found');
       MC:=MI.ModuleClass;
       end;
     M:=FindModule(MC); // Check if a module exists already
@@ -386,6 +407,24 @@ begin
     Result:=ARequest.ScriptName;
 end;
 
+Class Procedure TWebHandler.DoError(Msg : String;AStatusCode : Integer = 0; AStatusText : String = '');
+
+Var
+  E : EFPWebError;
+
+begin
+  E:=EFPWebError.Create(Msg);
+  E.StatusCode:=AStatusCode;
+  E.StatusText:=AStatusText;
+  Raise E;
+end;
+
+Class Procedure TWebHandler.DoError(Fmt: String; Const Args: Array of const;
+  AStatusCode: Integer = 0; AStatusText: String = '');
+begin
+  DoError(Format(Fmt,Args),AStatusCode,AStatusText);
+end;
+
 procedure TWebHandler.Terminate;
 begin
   FTerminated := true;
@@ -393,7 +432,7 @@ begin
     FOnTerminate(Self);
 end;
 
-function TWebHandler.GetModuleName(Arequest: TRequest): string;
+Function TWebHandler.GetModuleName(Arequest: TRequest): string;
 
    Function GetDefaultModuleName : String;
 
@@ -426,7 +465,7 @@ begin
   If (Result='') then
     begin
     if Not AllowDefaultModule then
-      Raise EFPWebError.Create(SErrNoModuleNameForRequest);
+      DoError(SErrNoModuleNameForRequest,400,'Not found');
     Result:=GetDefaultModuleName
     end;
 end;
@@ -450,8 +489,8 @@ begin
     Result:=Nil;
 end;
 
-procedure TWebHandler.SetBaseURL(AModule: TCustomHTTPModule;
-  Const AModuleName : String; ARequest: TRequest);
+Procedure TWebHandler.SetBaseURL(AModule: TCustomHTTPModule;
+  Const AModuleName: String; ARequest: TRequest);
 
 Var
   S,P : String;
@@ -469,7 +508,7 @@ begin
   AModule.BaseURL:=S+P;
 end;
 
-procedure TWebHandler.DoHandleRequest(ARequest: TRequest; AResponse: TResponse);
+Procedure TWebHandler.DoHandleRequest(ARequest: TRequest; AResponse: TResponse);
 begin
   Try
     HandleRequest(ARequest,AResponse);

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

@@ -157,7 +157,7 @@ Type
   end;
   
 
-  EFPApacheError = Class(Exception);
+  EFPApacheError = Class(EHTTP);
   
 Var
   Application : TCustomApacheApplication = Nil;

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

@@ -157,7 +157,7 @@ Type
   end;
   
 
-  EFPApacheError = Class(Exception);
+  EFPApacheError = Class(EHTTP);
   
 Var
   Application : TCustomApacheApplication = Nil;

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

@@ -516,7 +516,7 @@ type
     Property OnCreateWriter;
   end;
   
-  EHTMLError = Class(Exception);
+  EHTMLError = Class(EHTTP);
 
 const SimpleOkButton: array[0..0] of TWebButton = ((buttontype: btok;caption: 'Ok';onclick: ''));
 
@@ -603,12 +603,12 @@ end;
 
 procedure TJavaScriptStack.RedrawContentProducer(AContentProducer: THTMLContentProducer);
 begin
-  raise exception.Create('RedrawContentProducer not supported by current WebController');
+  raise EHTMLError.Create('RedrawContentProducer not supported by current WebController');
 end;
 
 procedure TJavaScriptStack.CallServerEvent(AHTMLContentProducer: THTMLContentProducer; AEvent: Integer; APostVariable: string = '');
 begin
-  raise exception.Create('SendServerEvent not supported by current WebController');
+  raise EHTMLError.Create('SendServerEvent not supported by current WebController');
 end;
 
 procedure TJavaScriptStack.Clear;
@@ -786,7 +786,7 @@ begin
     else
       begin
       for i := 0 to high(Events) do if assigned(events[i].csCallback) or assigned(events[i].ServerEvent) then
-        raise exception.Create('There is no webcontroller available, which is necessary to use events.');
+        raise EHTMLError.Create('There is no webcontroller available, which is necessary to use events.');
       end;
     end;
 end;
@@ -832,7 +832,7 @@ begin
       end;
     end;
   if ExceptIfNotAvailable then
-    raise Exception.Create('No webcontroller available');
+    raise EHTMLError.Create('No webcontroller available');
 end;
 
 procedure THTMLContentProducer.BeforeGenerateContent;
@@ -1478,7 +1478,7 @@ var
 begin
   i := length(FIterationIDs);
   if i=0 then
-    raise Exception.Create('DecrementIterationLevel can not be called more times then IncrementIterationLevel');
+    raise EHTMLError.Create('DecrementIterationLevel can not be called more times then IncrementIterationLevel');
   SetLength(FIterationIDs,i-1);
 end;
 

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

@@ -207,7 +207,9 @@ Type
     Property Modules [Index : Integer]: TModuleItem Read GetModule Write SetModule;default;
   end;
 
-  EFPHTTPError = Class(Exception);
+  { EFPHTTPError }
+
+  EFPHTTPError = Class(EHTTP);
 
 Procedure RegisterHTTPModule(ModuleClass : TCustomHTTPModuleClass; SkipStreaming : Boolean = False);
 Procedure RegisterHTTPModule(Const ModuleName : String; ModuleClass : TCustomHTTPModuleClass; SkipStreaming : Boolean = False);
@@ -227,6 +229,7 @@ Resourcestring
   SErrRequestNotHandled = 'Web request was not handled by actions.';
   SErrNoSessionFactoryClass = 'No session manager class available. Include iniwebsession unit and recompile.';
   SErrNoSessionOutsideRequest = 'Default session not available outside handlerequest';
+
 Implementation
 
 {$ifdef cgidebug}
@@ -248,6 +251,7 @@ begin
   Result:=GSM;
 end;
 
+
 { TCustomHTTPModule }
 
 procedure TCustomHTTPModule.DoAfterInitModule(ARequest: TRequest);

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

@@ -268,7 +268,8 @@ Type
     Property OnHeaders;
     Property OnGetSocketHandler;
   end;
-  EHTTPClient = Class(Exception);
+
+  EHTTPClient = Class(EHTTP);
 
 Function EncodeURLElement(S : String) : String;
 Function DecodeURLElement(Const S : String) : String;

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

@@ -195,7 +195,7 @@ Type
     Property OnRequestError;
   end;
 
-  EHTTPServer = Class(Exception);
+  EHTTPServer = Class(EHTTP);
 
   Function GetStatusCode (ACode: Integer) : String;
 
@@ -475,7 +475,7 @@ begin
   Request.PathInfo:=Request.URL;
   S:=GetNextWord(AStartLine);
   If (Pos('HTTP/',S)<>1) then
-    Raise Exception.Create(SErrMissingProtocol);
+    Raise EHTTPServer.CreateHelp(SErrMissingProtocol,400);
   Delete(S,1,5);
   Request.ProtocolVersion:=trim(S);
 end;

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

@@ -155,7 +155,7 @@ Type
     Property AfterInitModule;
   end;
 
-  EFPWebError = Class(HTTPError);
+  EFPWebError = Class(EHTTP);
 
 resourcestring
   SErrInvalidVar        = 'Invalid template variable name : "%s"';

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

@@ -494,8 +494,21 @@ type
 
   TRequestEvent = Procedure (Sender: TObject; ARequest : TRequest) of object;
   TResponseEvent = Procedure (Sender: TObject; AResponse : TResponse) of object;
-  
-  HTTPError = Class(Exception);
+
+  { EHTTP }
+
+  EHTTP = Class(Exception)
+  private
+    FStatusCode: Integer;
+    FStatusText: String;
+    function GetStatusCode: Integer;virtual;
+  Public
+    // These are transformed to the HTTP status code and text. Helpcontext is taken as the default for statuscode.
+    Property StatusCode : Integer Read GetStatusCode Write FStatusCode;
+    Property StatusText : String Read FStatusText Write FStatusText;
+  end;
+
+  HTTPError = EHTTP;
 
 Function HTTPDecode(const AStr: String): String;
 Function HTTPEncode(const AStr: String): String;
@@ -668,6 +681,15 @@ Type
     Procedure Process(Stream : TStream); override;
   end;
 
+{ EHTTP }
+
+function EHTTP.GetStatusCode: Integer;
+begin
+  Result:=FStatusCode;
+  if Result=0 then
+    Result:=HelpContext;
+end;
+
 
 procedure THTTPMimeItem.SetHeader(AIndex: Integer; const AValue: String);
 begin
@@ -1521,7 +1543,7 @@ begin
 {$endif}
   R:=Method;
   if (R='') then
-    Raise Exception.Create(SErrNoRequestMethod);
+    Raise EHTTP.CreateHelp(SErrNoRequestMethod,400);
   // Always process QUERYSTRING.
   InitGetVars;
   // POST and PUT, force post var treatment.

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

@@ -375,7 +375,7 @@ end;
 function TWebPage.GetWebController: TWebController;
 begin
   if not assigned(FWebController) then
-    raise exception.create('No webcontroller available');
+    raise EHTTP.create('No webcontroller available');
   result := FWebController;
 end;