paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-15 14:19:28 +02:00
Code Issues Packages Projects Releases Wiki Activity

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

Browse Source 
git-svn-id: trunk@28196 -
This commit is contained in:
michael 2014-07-11 08:19:23 +00:00
parent 6013e4d8c7
commit c204153604
13 changed files with 119 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
packages/fcl-web/src/base/cgiapp.pp
View File

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

2
packages/fcl-web/src/base/custcgi.pp
View File

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

18
packages/fcl-web/src/base/custfcgi.pp
View File

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

75
packages/fcl-web/src/base/custweb.pp
View File

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

2
packages/fcl-web/src/base/fpapache.pp
View File

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

2
packages/fcl-web/src/base/fpapache24.pp
View File

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

12
packages/fcl-web/src/base/fphtml.pp
View File

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

6
packages/fcl-web/src/base/fphttp.pp
View File

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

3
packages/fcl-web/src/base/fphttpclient.pp
View File

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

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

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

2
packages/fcl-web/src/base/fpweb.pp
View File

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

28
packages/fcl-web/src/base/httpdefs.pp
View File

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

2
packages/fcl-web/src/base/webpage.pp
View File

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