paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-17 12:39:25 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Request ID and connection ID for logging purposes

Browse Source
This commit is contained in:
Michaël Van Canneyt 2021-08-18 16:37:09 +02:00
parent 4ac009846c
commit a68a6415f2
3 changed files with 53 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
packages/fcl-web/examples/httpserver/testhttpserver.pas
View File

@ -77,7 +77,7 @@ begin
try
CheckMimeLoaded;
AResponse.ContentType:=MimeTypes.GetMimeType(ExtractFileExt(FN));
WriteInfo('Serving file: "'+Fn+'". Reported Mime type: '+AResponse.ContentType);
WriteInfo('Connection ('+aRequest.Connection.ConnectionID+') - Request ['+aRequest.RequestID+']: Serving file: "'+Fn+'". Reported Mime type: '+AResponse.ContentType);
AResponse.ContentLength:=F.Size;
AResponse.ContentStream:=F;
AResponse.SendContent;

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

@ -61,8 +61,11 @@ Type
{ TFPHTTPConnection }
TFPHTTPConnection = Class(TObject)
private
Class var _ConnectionCount : Int64;
private
FBusy: Boolean;
FConnectionID: String;
FOnError: TRequestErrorHandler;
FServer: TFPCustomHTTPServer;
FSocket: TSocketStream;
@ -75,12 +78,21 @@ Type
function ReadString: String;
Function GetLookupHostNames : Boolean;
Protected
// Allocate the ID for this connection.
Procedure AllocateConnectionID;
// Read the request content
procedure ReadRequestContent(ARequest: TFPHTTPConnectionRequest); virtual;
// Allow descendents to handle unknown headers
procedure UnknownHeader(ARequest: TFPHTTPConnectionRequest; const AHeader: String); virtual;
// Handle request error, calls OnRequestError
procedure HandleRequestError(E : Exception); virtual;
// Setup socket
Procedure SetupSocket; virtual;
// Mark connection as busy with request
Procedure SetBusy;
// Actually handle request
procedure DoHandleRequest; virtual;
// Read request headers
Function ReadRequestHeaders : TFPHTTPConnectionRequest;
// Check if we have keep-alive and no errors occured
Function AllowNewRequest : Boolean;
@ -88,15 +100,25 @@ Type
Function RequestPending : Boolean;
// True if we're handling a request. Needed to be able to schedule properly.
Property Busy : Boolean Read FBusy;
Public
Type
TConnectionIDAllocator = Procedure(out aID : String) of object;
class var IDAllocator : TConnectionIDAllocator;
Public
Constructor Create(AServer : TFPCustomHTTPServer; ASocket : TSocketStream);
Destructor Destroy; override;
// Handle 1 request: Set up socket if needed, Read request, dispatch, return response.
Procedure HandleRequest;
// Unique ID per new connection
Property ConnectionID : String Read FConnectionID;
// The socket used by this connection
Property Socket : TSocketStream Read FSocket;
// The server that created this connection
Property Server : TFPCustomHTTPServer Read FServer;
// Handler to call when an error occurs.
Property OnRequestError : TRequestErrorHandler Read FOnError Write FOnError;
// Look up host names to map IP -> hostname ?
Property LookupHostNames : Boolean Read GetLookupHostNames;
// Set to true if you want to support HTTP 1.1 connection: keep-alive - only available for threaded server
Property KeepAliveEnabled : Boolean read FKeepAliveEnabled write FKeepAliveEnabled;
// time-out for keep-alive: how many ms should the server keep the connection alive after a request has been handled
@ -929,6 +951,7 @@ begin
FSocket:=ASocket;
FServer:=AServer;
KeepAliveTimeout:=DefaultKeepaliveTimeout;
AllocateConnectionID;
end;
destructor TFPHTTPConnection.Destroy;
@ -946,6 +969,15 @@ begin
Result:=False;
end;
procedure TFPHTTPConnection.AllocateConnectionID;
begin
if Assigned(IDAllocator) then
IDAllocator(FConnectionID);
if FConnectionID='' then
FConnectionID:=IntToStr(InterlockedIncrement64(_ConnectionCount))
end;
procedure TFPHTTPConnection.DoHandleRequest;
Var

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

@ -444,17 +444,19 @@ type
{ TRequest }
TRequest = class(THttpHeader)
Private
class var _RequestCount : Int64;
private
FCommand: String;
FCommandLine: String;
FHandleGetOnPost: Boolean;
FOnUnknownEncoding: TOnUnknownEncodingEvent;
FFiles : TUploadedFiles;
FRequestID: String;
FReturnedPathInfo : String;
FLocalPathPrefix : string;
FContentRead : Boolean;
FRouteParams : TStrings;
FStreamingContentType: TStreamingContentType;
FMimeItems: TMimeItems;
FKeepFullContents: Boolean;
@ -466,6 +468,7 @@ type
function GetRP(AParam : String): String;
procedure SetRP(AParam : String; AValue: String);
Protected
procedure AllocateRequestID; virtual;
Function AllowReadContent : Boolean; virtual;
Function CreateUploadedFiles : TUploadedFiles; virtual;
Function CreateMimeItems : TMimeItems; virtual;
@ -497,11 +500,16 @@ type
procedure ProcessStreamingSetContent(const State: TContentStreamingState; const Buf; const Size: Integer); virtual;
procedure HandleStreamingUnknownEncoding(const State: TContentStreamingState; const Buf; const Size: Integer);
Property ContentRead : Boolean Read FContentRead Write FContentRead;
Public
Type
TConnectionIDAllocator = Procedure(out aID : String) of object;
class var IDAllocator : TConnectionIDAllocator;
public
Class Var DefaultRequestUploadDir : String;
constructor Create; override;
destructor destroy; override;
Function GetNextPathInfo : String;
Property RequestID : String Read FRequestID;
Property RouteParams[AParam : String] : String Read GetRP Write SetRP;
Property ReturnedPathInfo : String Read FReturnedPathInfo Write FReturnedPathInfo;
Property LocalPathPrefix : string Read GetLocalPathPrefix;
@ -2059,6 +2067,7 @@ begin
FFiles:=CreateUploadedFiles;
FFiles.FRequest:=Self;
FLocalPathPrefix:='-';
AllocateRequestID;
end;
function TRequest.CreateUploadedFiles: TUploadedFiles;
@ -2195,6 +2204,15 @@ begin
FRouteParams.Values[AParam]:=AValue;
end;
procedure TRequest.AllocateRequestID;
begin
if Assigned(IDAllocator) then
IDAllocator(FRequestID);
if FRequestID='' then
FRequestID:=IntToStr(InterlockedIncrement64(_RequestCount))
end;
function TRequest.AllowReadContent: Boolean;
begin
Result:=True;