* Add interceptor (middleware) functionality to router + Demo

packages/fcl-web/examples/intercept/simpleserver.lpi

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

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

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;