paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-16 08:59:26 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Add interceptor (middleware) functionality to router + Demo

Browse Source
This commit is contained in:
Michaël Van Canneyt 2021-08-18 22:25:28 +02:00
parent 5a6bea6180
commit bb9a1af248
3 changed files with 408 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

70
packages/fcl-web/examples/intercept/simpleserver.lpi Normal file
View File

@ -0,0 +1,70 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="12"/>
<General>
<Flags>
<SaveClosedFiles Value="False"/>
<SaveOnlyProjectUnits Value="True"/>
<MainUnitHasCreateFormStatements Value="False"/>
<MainUnitHasTitleStatement Value="False"/>
<SaveJumpHistory Value="False"/>
<SaveFoldState Value="False"/>
<CompatibilityMode Value="True"/>
</Flags>
<SessionStorage Value="InProjectDir"/>
<Title Value="simpleserver"/>
<UseAppBundle Value="False"/>
<ResourceType Value="res"/>
</General>
<BuildModes Count="1">
<Item1 Name="Default" Default="True"/>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
</PublishOptions>
<RunParams>
<local>
<CommandLineParams Value="-p 8080 -d /home/michael/public_html"/>
</local>
<FormatVersion Value="2"/>
<Modes Count="1">
<Mode0 Name="default">
<local>
<CommandLineParams Value="-p 8080 -d /home/michael/public_html"/>
</local>
</Mode0>
</Modes>
</RunParams>
<Units Count="1">
<Unit0>
<Filename Value="simpleserver.pas"/>
<IsPartOfProject Value="True"/>
</Unit0>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<Target>
<Filename Value="simpleserver"/>
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
<OtherUnitFiles Value="../../src/base"/>
<UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
</CompilerOptions>
<Debugging>
<Exceptions Count="3">
<Item1>
<Name Value="EAbort"/>
</Item1>
<Item2>
<Name Value="ECodetoolError"/>
</Item2>
<Item3>
<Name Value="EFOpenError"/>
</Item3>
</Exceptions>
</Debugging>
</CONFIG>

205
packages/fcl-web/examples/intercept/simpleserver.pas Normal file
View File

@ -0,0 +1,205 @@
{
This file is part of the Free Pascal run time library.
Copyright (c) 2019 by the Free Pascal development team
Sample HTTP server application with 2 interceptors
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
{$mode objfpc}
{$h+}
program simpleserver;
{$IFDEF USEMICROHTTP}
{$UNDEF USEGNUTLS}
{$ENDIF}
uses
{$ifdef unix}
cthreads,
{$endif}
sysutils, strutils, custapp, custhttpapp, Classes, httproute, httpdefs, fpmimetypes, fpwebfile, fpwebproxy, webutil, base64;
Type
{ THTTPApplication }
THTTPApplication = Class(TCustomHTTPApplication)
private
FBaseDir: string;
FIndexPageName: String;
FMimeFile: String;
FNoIndexPage: Boolean;
FQuiet: Boolean;
FPassword : string;
FAuth : String;
procedure DoAuthorization(ARequest: TRequest; AResponse: TResponse; var aContinue: Boolean);
procedure DoRequestEnd(ARequest: TRequest; AResponse: TResponse; var aContinue: Boolean);
procedure DoRequestStart(ARequest: TRequest; AResponse: TResponse; var aContinue: Boolean);
procedure ProcessOptions;
procedure Usage(Msg: String);
procedure Writeinfo;
published
procedure DoLog(EventType: TEventType; const Msg: String); override;
Procedure DoRun; override;
property Quiet : Boolean read FQuiet Write FQuiet;
Property MimeFile : String Read FMimeFile Write FMimeFile;
Property BaseDir : string Read FBaseDir Write FBaseDir;
Property NoIndexPage : Boolean Read FNoIndexPage Write FNoIndexPage;
Property IndexPageName : String Read FIndexPageName Write FIndexPageName;
end;
Var
Application : THTTPApplication;
{ THTTPApplication }
procedure THTTPApplication.DoLog(EventType: TEventType; const Msg: String);
begin
if IsConsole then
Writeln(FormatDateTime('yyyy-mm-dd hh:nn:ss.zzz',Now),' [',EventType,'] ',Msg)
else
inherited DoLog(EventType, Msg);
end;
procedure THTTPApplication.Usage(Msg : String);
begin
if (Msg<>'') then
Writeln('Error: ',Msg);
Writeln('Usage ',ExtractFileName(ParamStr(0)),' [options] ');
Writeln('Where options is one or more of : ');
Writeln('-d --directory=dir Base directory from which to serve files.');
Writeln(' Default is current working directory: ',GetCurrentDir);
Writeln('-h --help This help text');
Writeln('-i --indexpage=name Directory index page to use (default: index.html)');
Writeln('-n --noindexpage Do not allow index page.');
Writeln('-p --port=NNNN TCP/IP port to listen on (default is 3000)');
Writeln('-q --quiet Do not register log intercepts');
Writeln('-a --authenticate=PWD Register authentication intercept - authenticate with PWD');
Halt(Ord(Msg<>''));
end;
procedure THTTPApplication.ProcessOptions;
Var
S : String;
begin
Quiet:=HasOption('q','quiet');
FAuth:=GetoptionValue('a','authenticate');
Port:=StrToIntDef(GetOptionValue('p','port'),Port);
if HasOption('d','directory') then
BaseDir:=GetOptionValue('d','directory');
if HasOption('H','hostname') then
HostName:=GetOptionValue('H','hostname');
if HasOption('n','noindexpage') then
NoIndexPage:=True
else
IndexPageName:=GetOptionValue('i','indexpage');
end;
procedure THTTPApplication.DoRequestStart(ARequest: TRequest; AResponse: TResponse; var aContinue: Boolean);
begin
DoLog(etInfo,Format('Request %s: %s',[aRequest.RequestID,aRequest.URL]));
end;
procedure THTTPApplication.DoRequestEnd(ARequest: TRequest; AResponse: TResponse; var aContinue: Boolean);
begin
DoLog(etInfo,Format('Request %s: %s : %d (%d bytes)',[aRequest.RequestID,aRequest.URL,aResponse.Code, aResponse.ContentLength]));
end;
procedure THTTPApplication.DoAuthorization(ARequest: TRequest; AResponse: TResponse; var aContinue: Boolean);
Var
S : String;
begin
S:=Trim(aRequest.Authorization);
aContinue:=SameText(ExtractWord(1,S,[' ']),'Basic');
if aContinue then
begin
S:=ExtractWord(2,S,[' ']); // Username:Password in base64
S:=DecodeStringBase64(S); // Decode
S:=ExtractWord(2,S,[':']); // extract password
aContinue:=SameText(S,Fauth); // Check
if not aContinue then
DoLog(etInfo,'Invalid password provided: '+S);
end
else
if S='' then
DoLog(etInfo,'Missing authorization header')
else
DoLog(etInfo,'Invalid authorization header: '+S);
if not aContinue then
begin
aResponse.Code:=401;
aResponse.CodeText:='Unauthorized';
aResponse.WWWAuthenticate:='Basic Realm="This site needs a password"';
aResponse.SendContent;
end;
end;
procedure THTTPApplication.Writeinfo;
Var
I : Integer;
begin
Log(etInfo,'Listening on port %d, serving files from directory: %s (using SSL: %s)',[Port,BaseDir,BoolToStr(UseSSL,'true','false')]);
if not NoIndexPage then
Log(etInfo,'Using index page %s',[IndexPageName]);
end;
procedure THTTPApplication.DoRun;
Var
S : String;
begin
S:=Checkoptions('hqnd:p:i:a:',['help','quiet','noindexpage','directory:','port:','indexpage:','authenticate:']);
if (S<>'') or HasOption('h','help') then
usage(S);
ProcessOptions;
if BaseDir='' then
BaseDir:=GetCurrentDir;
if (BaseDir<>'') then
BaseDir:=IncludeTrailingPathDelimiter(BaseDir);
MimeTypes.LoadKnownTypes;
if Fauth<>'' then
HTTPRouter.RegisterInterceptor('auth',@DoAuthorization);
if not FQuiet then
begin
HTTPRouter.RegisterInterceptor('logstart',@DoRequestStart);
HTTPRouter.RegisterInterceptor('logend',@DoRequestEnd,iaAfter);
end;
TSimpleFileModule.RegisterDefaultRoute;
TSimpleFileModule.BaseDir:=BaseDir;
TSimpleFileModule.OnLog:=@Log;
If not NoIndexPage then
begin
if (IndexPageName='') then
IndexPageName:='index.html';
TSimpleFileModule.IndexPageName:=IndexPageName;
end;
inherited;
end;
begin
Application:=THTTPApplication.Create(Nil);
Application.Initialize;
Application.Run;
Application.Free;
end.

134
packages/fcl-web/src/base/httproute.pp
View File

@ -152,6 +152,42 @@ Type
THTTPRouteRequestEvent = Procedure (Sender : TObject; ARequest : TRequest; AResponse : TResponse) of object;
{ TRequestInterceptor }
TRequestInterceptEvent = Procedure (ARequest : TRequest; AResponse : TResponse; var aContinue : Boolean) of object;
TInterceptAt = (iaBefore,iaAfter);
{ TRequestInterceptorItem }
TRequestInterceptorItem = Class(TCollectionItem)
private
FDisabled: Boolean;
FEvent: TRequestInterceptEvent;
FInterceptAt: TInterceptAt;
FName: String;
Protected
Function RunIntercept(ARequest: TRequest; AResponse: TResponse): Boolean;
Public
Property Disabled : Boolean Read FDisabled Write FDisabled;
Property Name : String Read FName;
Property Event : TRequestInterceptEvent Read FEvent Write FEvent;
Property InterceptAt : TInterceptAt Read FInterceptAt Write FInterceptAt;
end;
{ TRequestInterceptorList }
TRequestInterceptorList = Class(TCollection)
private
function GetR(aIndex : Integer): TRequestInterceptorItem;
Public
Function addInterCeptor(Const aName : String) : TRequestInterceptorItem;
Function RunIntercepts(RunAt : TInterceptAt; ARequest : TRequest; AResponse : TResponse) : Boolean; virtual;
Function IndexOfInterceptor(const aName : String) : integer;
Function FindInterceptor(const aName : String) : TRequestInterceptorItem;
Property Interceptors[aIndex : Integer] : TRequestInterceptorItem Read GetR; default;
end;
{ THTTPRouter }
THTTPRouter = Class(TComponent)
@ -160,6 +196,7 @@ Type
FBeforeRequest: THTTPRouteRequestEvent;
FRouteOptions: TRouteOptions;
FRoutes : THTTPRouteList;
FIntercepts : TRequestInterceptorList;
function GetR(AIndex : Integer): THTTPRoute;
Class Procedure DoneService;
Class
@ -171,6 +208,7 @@ Type
function CreateHTTPRoute(AClass: THTTPRouteClass; const APattern: String; AMethod: TRouteMethod; IsDefault: Boolean ): THTTPRoute; virtual;
// Override this if you want to use another collection class.
Function CreateRouteList : THTTPRouteList; virtual;
Function CreateInterceptorList : TRequestInterceptorList; virtual;
Procedure CheckDuplicate(APattern : String; AMethod : TRouteMethod; isDefault : Boolean);
// Actually route request. Override this for customized behaviour.
Procedure DoRouteRequest(ARequest : TRequest; AResponse : TResponse); virtual;
@ -195,6 +233,9 @@ Type
Class Procedure SetServiceClass(AClass : THTTPRouterClass);
// Convert string to HTTP Route method
Class Function StringToRouteMethod(Const S : String) : TRouteMethod;
// Interceptor
Procedure RegisterInterceptor(const aName : String; aEvent : TRequestInterceptEvent; aAt : TInterceptAt = iaBefore);
Procedure UnRegisterInterceptor(const aName : String);
// Register event based route
Function RegisterRoute(Const APattern : String; AEvent: TRouteEvent; IsDefault : Boolean = False) : THTTPRoute;overload;
Function RegisterRoute(Const APattern : String; AMethod : TRouteMethod; AEvent: TRouteEvent; IsDefault : Boolean = False): THTTPRoute;overload;
@ -228,6 +269,7 @@ Type
Property RouteOptions : TRouteOptions Read FRouteOptions Write FRouteOptions;
end;
Function RouteMethodToString (R : TRouteMethod) : String;
// Shortcut for THTTPRouter.Service;
Function HTTPRouter : THTTPRouter;
@ -242,6 +284,7 @@ uses strutils, typinfo;
Resourcestring
EDuplicateRoute = 'Duplicate route pattern: %s and method: %s';
EDuplicateDefaultRoute = 'Duplicate default route registered with pattern: %s and method: %s';
SErrDuplicateInterceptor = 'Duplicate interceptor name: %s';
function RouteMethodToString(R: TRouteMethod): String;
@ -259,6 +302,68 @@ begin
Result:=THTTPRouter.Service;
end;
{ TRequestInterceptorItem }
function TRequestInterceptorItem.RunIntercept(ARequest: TRequest; AResponse: TResponse): Boolean;
begin
Result:=True;
If Assigned(Event) then
Event(aRequest,aResponse,Result);
end;
{ TRequestInterceptorList }
function TRequestInterceptorList.GetR(aIndex : Integer): TRequestInterceptorItem;
begin
Result:=TRequestInterceptorItem(Items[aIndex]);
end;
function TRequestInterceptorList.addInterCeptor(const aName: String): TRequestInterceptorItem;
begin
If IndexOfInterceptor(aName)<>-1 then
Raise EHTTPRoute.CreateFmt(SErrDuplicateInterceptor,[aName]);
Result:=Add as TRequestInterceptorItem;
Result.FName:=aName;
end;
function TRequestInterceptorList.RunIntercepts(RunAt: TInterceptAt; ARequest: TRequest; AResponse: TResponse): Boolean;
Var
I : Integer;
begin
Result:=True;
I:=0;
While Result and (I<Count) do
begin
With GetR(i) do
if (RunAt=InterceptAt) and not Disabled then
Result:=RunIntercept(aRequest,aResponse);
Inc(I)
end;
end;
function TRequestInterceptorList.IndexOfInterceptor(const aName: String): integer;
begin
Result:=Count-1;
While (Result>=0) and not SameText(aName,GetR(Result).Name) do
Dec(Result);
end;
function TRequestInterceptorList.FindInterceptor(const aName: String): TRequestInterceptorItem;
Var
Idx : Integer;
begin
Idx:=IndexOfInterceptor(aName);
if Idx=-1 then
Result:=Nil
else
Result:=GetR(Idx);
end;
{ THTTPRouteCallback }
procedure THTTPRouteCallback.DoHandleRequest(ARequest: TRequest; AResponse: TResponse);
@ -312,6 +417,11 @@ begin
Result:=THTTPRouteList.Create(THTTPRoute);
end;
function THTTPRouter.CreateInterceptorList: TRequestInterceptorList;
begin
Result:=TRequestInterceptorList.Create(TRequestInterceptorItem);
end;
procedure THTTPRouter.CheckDuplicate(APattern: String; AMethod: TRouteMethod;
isDefault: Boolean);
Var
@ -369,6 +479,7 @@ constructor THTTPRouter.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
froutes:=CreateRouteList;
FIntercepts:=CreateInterceptorList;
end;
destructor THTTPRouter.Destroy;
@ -427,6 +538,23 @@ begin
if Result=rmAll then Result:=rmUnknown;
end;
procedure THTTPRouter.RegisterInterceptor(const aName: String; aEvent: TRequestInterceptEvent; aAt: TInterceptAt);
Var
Intr : TRequestInterceptorItem;
begin
Intr:=FIntercepts.AddInterceptor(aName);
Intr.Event:=aEvent;
Intr.InterceptAt:=aAt;
end;
procedure THTTPRouter.UnRegisterInterceptor(const aName: String);
begin
FIntercepts.FindInterceptor(aName).Free;
end;
function THTTPRouter.RegisterRoute(const APattern: String;AData : Pointer;
ACallBack: TRouteCallBackEx; IsDefault: Boolean): THTTPRoute;
begin
@ -582,7 +710,11 @@ procedure THTTPRouter.RouteRequest(ARequest: TRequest; AResponse: TResponse);
begin
If Assigned(FBeforeRequest) then
FBeforeRequest(Self,ARequest,AResponse);
DoRouteRequest(ARequest,AResponse);
if FIntercepts.RunIntercepts(iaBefore,ARequest,aResponse) then
// Safety
if not aResponse.ContentSent then
DoRouteRequest(ARequest,AResponse);
FIntercepts.RunIntercepts(iaAfter,ARequest,aResponse);
If Assigned(FAfterRequest) then
FAfterRequest(Self,ARequest,AResponse);
end;