From bb9a1af24849031928f0db2ddfbd1991f91792bc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Micha=C3=ABl=20Van=20Canneyt?= Date: Wed, 18 Aug 2021 22:25:28 +0200 Subject: [PATCH] * Add interceptor (middleware) functionality to router + Demo --- .../examples/intercept/simpleserver.lpi | 70 ++++++ .../examples/intercept/simpleserver.pas | 205 ++++++++++++++++++ packages/fcl-web/src/base/httproute.pp | 134 +++++++++++- 3 files changed, 408 insertions(+), 1 deletion(-) create mode 100644 packages/fcl-web/examples/intercept/simpleserver.lpi create mode 100644 packages/fcl-web/examples/intercept/simpleserver.pas diff --git a/packages/fcl-web/examples/intercept/simpleserver.lpi b/packages/fcl-web/examples/intercept/simpleserver.lpi new file mode 100644 index 0000000000..8fb4288813 --- /dev/null +++ b/packages/fcl-web/examples/intercept/simpleserver.lpi @@ -0,0 +1,70 @@ + + + + + + + + + + + + + + + + + <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> diff --git a/packages/fcl-web/examples/intercept/simpleserver.pas b/packages/fcl-web/examples/intercept/simpleserver.pas new file mode 100644 index 0000000000..89484e0a52 --- /dev/null +++ b/packages/fcl-web/examples/intercept/simpleserver.pas @@ -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. + diff --git a/packages/fcl-web/src/base/httproute.pp b/packages/fcl-web/src/base/httproute.pp index 50961109c6..8812763cf9 100644 --- a/packages/fcl-web/src/base/httproute.pp +++ b/packages/fcl-web/src/base/httproute.pp @@ -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;