paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-11-04 09:02:22 +01:00
Code Issues Packages Projects Releases Wiki Activity

* Some fixes and additional unit from Darius Blaszijk

Browse Source 
git-svn-id: trunk@18181 -
This commit is contained in:
michael 2011-08-12 19:26:38 +00:00
parent 215852ac85
commit 7dc58d81d9
2 changed files with 202 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -2642,6 +2642,7 @@ packages/fcl-web/src/base/fphttp.pp svneol=native#text/plain
packages/fcl-web/src/base/fphttpapp.pp svneol=native#text/plain
packages/fcl-web/src/base/fphttpclient.pp svneol=native#text/plain
packages/fcl-web/src/base/fphttpserver.pp svneol=native#text/plain
packages/fcl-web/src/base/fphttpstatus.pas svneol=native#text/plain
packages/fcl-web/src/base/fpweb.pp svneol=native#text/plain
packages/fcl-web/src/base/fpwebfile.pp svneol=native#text/plain
packages/fcl-web/src/base/httpdefs.pp svneol=native#text/plain

201
packages/fcl-web/src/base/fphttpstatus.pas Normal file
View File

@ -0,0 +1,201 @@
unit FPHTTPStatus;
{$mode objfpc}{$H+}
interface
uses
SysUtils, fphttpserver, HTTPDefs;
(* construct and return the default error message for a given
* HTTP defined error code
*)
function http_error_response(status: integer; ARequest: TFPHTTPConnectionRequest): string;
implementation
function error_string(status: integer; ARequest: TFPHTTPConnectionRequest): string;
begin
case status of
301: ;
302: ;
307: Result := '<p>The document has moved <a href=\' +
HTTPEncode(ARequest.Location) +
'\>here</a>.</p>';
303: Result := '<p>The answer to your request is located ' +
'<a href=\' +
HTTPEncode(ARequest.Location) +
'\>here</a>.</p>';
305: Result := '<p>This resource is only accessible ' +
'through the proxy' +
HTTPEncode(ARequest.Location) +
'<br />You will need to configure ' +
'your client to use that proxy.</p>';
407: ;
401: Result := '<p>This server could not verify that you' +
'are authorized to access the document' +
'requested. Either you supplied the wrong' +
'credentials (e.g., bad password), or your' +
'browser doesn''t understand how to supply' +
'the credentials required.</p>';
400: Result := '<p>Your browser sent a request that ' +
'this server could not understand.<br />' +
'</p>';
403: Result := '<p>You don''t have permission to access ' +
HTTPEncode(ARequest.URI) +
'on this server.</p>';
404: Result := '<p>The requested URL ' +
HTTPEncode(ARequest.URI) +
' was not found on this server.</p>';
405: Result := '<p>The requested method ' +
HTTPEncode(ARequest.Method) +
' is not allowed for the URL ' +
HTTPEncode(ARequest.URI) +
'.</p>';
406: Result := '<p>An appropriate representation of the ' +
'requested resource ' +
HTTPEncode(ARequest.URI) +
' could not be found on this server.</p>';
300: ;
411: Result := '<p>A request of the requested method ' +
HTTPEncode(ARequest.Method) +
' requires a valid Content-length.<br />';
412: Result := '<p>The precondition on the request ' +
'for the URL ' +
HTTPEncode(ARequest.URI) +
' evaluated to false.</p>';
501: Result := '<p>' +
HTTPEncode(ARequest.Method) + ' to ' +
HTTPEncode(ARequest.URI) +
' not supported.<br />' +
'</p>';
502: Result := '<p>The proxy server received an invalid ' +
'response from an upstream server.<br />' +
'</p>';
506: Result := '<p>A variant for the requested ' +
'resource<pre>' +
HTTPEncode(ARequest.URI) +
'</pre>is itself a negotiable resource. ' +
'This indicates a configuration error.</p>';
408: Result := '<p>Server timeout waiting for the HTTP request from the client.</p>';
410: Result := '<p>The requested resource<br />' +
HTTPEncode(ARequest.URI) +
'<br />is no longer available on this server ' +
'and there is no forwarding address.' +
'Please remove all references to this ' +
'resource.</p>';
413: Result := 'The requested resource<br />' +
HTTPEncode(ARequest.URI) + '<br />' +
'does not allow request data with ' +
HTTPEncode(ARequest.Method) +
' requests, or the amount of data provided in' +
'the request exceeds the capacity limit.';
414: Result := '<p>The requested URL''s length exceeds the capacity' +
'limit for this server.<br />' +
'</p>';
415: Result := '<p>The supplied request data is not in a format ' +
'acceptable for processing by this resource.</p>';
416: Result := '<p>None of the range-specifier values in the Range ' +
'request-header field overlap the current extent ' +
'of the selected resource.</p>';
417:
begin
if pos('Expect', ARequest.HeaderLine) <> 0 then
Result := '<p>The expectation given in the Expect request-header' +
'field could not be met by this server.' +
'The client sent<pre> ' +
HTTPEncode(ARequest.HeaderLine) + '</pre>'
else
Result := '<p>No expectation was seen, the Expect request-header ' +
'field was not presented by the client.';
end;
422: Result := '<p>The server understands the media type of the' +
'request entity, but was unable to process the' +
'contained instructions.</p>';
423: Result := '<p>The requested resource is currently locked.' +
'The lock must be released or proper identification' +
'given before the method can be applied.</p>';
424: Result := '<p>The method could not be performed on the resource' +
'because the requested action depended on another' +
'action and that other action failed.</p>';
426: Result := '<p>The requested resource can only be retrieved' +
'using SSL. The server is willing to upgrade the current' +
'connection to SSL, but your client doesn''t support it.' +
'Either upgrade your client, or try requesting the page' +
'using https://';
507: Result := '<p>The method could not be performed on the resource' +
'because the server is unable to store the' +
'representation needed to successfully complete the' +
'request. There is insufficient free space left in' +
'your storage allocation.</p>';
503: Result := '<p>The server is temporarily unable to service your' +
'request due to maintenance downtime or capacity' +
'problems. Please try again later.</p>';
504: Result := '<p>The gateway did not receive a timely response' +
'from the upstream server or application.</p>';
510: Result := '<p>A mandatory extension policy in the request is not' +
'accepted by the server for this resource.</p>';
else
//HTTP internal server error
Result := '<p>The server encountered an internal ' +
'error or' +
'misconfiguration and was unable to complete ' +
'your request.</p>' +
'<p>Please contact the server ' +
'administrator at ' +
HTTPEncode(ARequest.Connection.Server.AdminMail) +
' to inform them of the time this ' +
'error occurred,' +
' and the actions you performed just before ' +
'this error.</p>' +
'<p>More information about this error ' +
'may be available' +
'in the server error log.</p>';
end;
end;
function signature(const prefix: string; ARequest: TFPHTTPConnectionRequest): string;
var
name: string;
begin
if ARequest.Connection.Server.AdminName <> '' then
name := ARequest.Connection.Server.AdminName
else
name := ARequest.Connection.Server.AdminMail;
if ARequest.Connection.Server.AdminMail <> '' then
Result := prefix + '<address>' +
ARequest.Connection.Server.ServerBanner +
' Server at <a href="' +
'mailto:' +
HTTPEncode(ARequest.Connection.Server.AdminMail) +
'">' +
HTTPEncode(name) +
'</a> Port ' + ARequest.ServerPort +
'</address>'
else
Result := prefix + '<address>' + ARequest.Connection.Server.ServerBanner +
' Server at ' +
ARequest.Connection.Server.AdminMail +
' Port ' + ARequest.ServerPort +
'</address>';
end;
function http_error_response(status: integer; ARequest: TFPHTTPConnectionRequest): string;
var
title: string;
h1: string;
begin
title := Format('%d %s', [status, GetStatusCode(status)]);
h1 := GetStatusCode(status);
Result := '<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML//EN">' +
'<html><head><title>' + title +
'</title></head><body><h1>' + h1 + '</h1>' +
error_string(status, ARequest) +
signature('<hr>', ARequest) +
'</body></html>';
end;
end.