diff --git a/.gitattributes b/.gitattributes index 067c085835..bc3714b67e 100644 --- a/.gitattributes +++ b/.gitattributes @@ -4522,6 +4522,7 @@ packages/fcl-web/src/base/fpoauth2ini.pp svneol=native#text/plain packages/fcl-web/src/base/fpweb.pp svneol=native#text/plain packages/fcl-web/src/base/fpwebclient.pp svneol=native#text/plain packages/fcl-web/src/base/fpwebfile.pp svneol=native#text/plain +packages/fcl-web/src/base/fpwebproxy.pp svneol=native#text/plain packages/fcl-web/src/base/httpdefs.pp svneol=native#text/plain packages/fcl-web/src/base/httpprotocol.pp svneol=native#text/plain packages/fcl-web/src/base/httproute.pp svneol=native#text/plain diff --git a/packages/fcl-web/fpmake.pp b/packages/fcl-web/fpmake.pp index bea1366438..412ab6e1b3 100644 --- a/packages/fcl-web/fpmake.pp +++ b/packages/fcl-web/fpmake.pp @@ -214,6 +214,20 @@ begin // T.ResourceStrings:=true; T:=P.Targets.AddUnit('fphttpapp.pp'); T:=P.Targets.AddUnit('fpwebfile.pp'); + With T.Dependencies do + begin + AddUnit('fphttp'); + AddUnit('httpdefs'); + AddUnit('httproute'); + end; + T:=P.Targets.AddUnit('fpwebproxy.pp'); + With T.Dependencies do + begin + AddUnit('fphttp'); + AddUnit('httpdefs'); + AddUnit('httpprotocol'); + AddUnit('fphttpclient'); + end; T.ResourceStrings:=true; T:=P.Targets.AddUnit('fpwebdata.pp'); T.ResourceStrings:=true; diff --git a/packages/fcl-web/src/base/fpwebfile.pp b/packages/fcl-web/src/base/fpwebfile.pp index 6263f33701..31fbaf1735 100644 --- a/packages/fcl-web/src/base/fpwebfile.pp +++ b/packages/fcl-web/src/base/fpwebfile.pp @@ -1,5 +1,20 @@ +{ + This file is part of the Free Pascal run time library. + Copyright (c) 2019 by the Free Pascal development team + + Classes to implement a file serving mechanism. + + 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+} + unit fpwebfile; interface diff --git a/packages/fcl-web/src/base/fpwebproxy.pp b/packages/fcl-web/src/base/fpwebproxy.pp new file mode 100644 index 0000000000..b7480d42e2 --- /dev/null +++ b/packages/fcl-web/src/base/fpwebproxy.pp @@ -0,0 +1,325 @@ +{ + This file is part of the Free Pascal run time library. + Copyright (c) 2019 by the Free Pascal development team + + Classes to implement a proxy mechanism. + + 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. + + **********************************************************************} +unit fpwebproxy; + +{$mode objfpc}{$H+} + +// Define this to output debug info on console +{ $DEFINE DEBUGPROXY} + +interface + +uses + Classes, SysUtils, fphttp, httpdefs, httpprotocol, fphttpclient; + +Type + TProxyRequestLog = Procedure(Sender : TObject; Const Method,Location,FromURL,ToURL : String) of object; + + { TProxyLocation } + + TProxyLocation = Class(TCollectionItem) + private + FAppendPathInfo: Boolean; + FEnabled: Boolean; + FPath: String; + FRedirect: Boolean; + FURL: String; + Published + Property Path : String Read FPath Write FPath; + Property URL : String Read FURL Write FURL; + Property Enabled : Boolean Read FEnabled Write FEnabled; + Property Redirect : Boolean Read FRedirect Write FRedirect; + Property AppendPathInfo : Boolean Read FAppendPathInfo Write FAppendPathInfo; + end; + + { TProxyLocations } + + TProxyLocations = Class(TCollection) + private + function GetL(AIndex : Integer): TProxyLocation; + procedure SetL(AIndex : Integer; AValue: TProxyLocation); + Public + Function IndexOfLocation(Const APath : String) : Integer; + Function FindLocation(Const APath : String) : TProxyLocation; + Property Locations [AIndex : Integer] : TProxyLocation Read GetL Write SetL; default; + end; + + { TProxyWebModule } + + TProxyWebModule = Class(TCustomHTTPModule) + protected + Procedure DoLog(Const aMethod,aLocation,aFromURL,aToURL : String); + procedure ClientToResponse(T: TFPHTTPClient; aResponse: TResponse); virtual; + procedure RequestToClient(T: TFPHTTPClient; aRequest: TRequest); virtual; + procedure ReRouteRequest(L: TProxyLocation; ARequest: TRequest; AResponse: TResponse);virtual; + Public + Procedure HandleRequest(ARequest : TRequest; AResponse : TResponse); override; + end; + + { TProxyManager } + + TProxyManager = Class(TObject) + private + FLocations : TProxyLocations; + FOnLog: TProxyRequestLog; + function GetLocation(AIndex : Integer): TProxyLocation; + function GetLocationCount: Integer; + Public + Constructor create; + Destructor Destroy; override; + Function RegisterLocation(Const APath,AURL : String) : TProxyLocation; + Function UnRegisterLocation(Const APath : String) : boolean; + Function FindLocation(Const APath : String) : TProxyLocation; + Property LocationCount : Integer Read GetLocationCount; + Property Locations[AIndex : Integer] : TProxyLocation Read GetLocation; + Property OnLog : TProxyRequestLog Read FOnLog Write FOnLog; + end; + + EWAProxy = Class(Exception); + +Function ProxyManager: TProxyManager; + +implementation + +uses StrUtils; + +Resourcestring + SErrDuplicateProxy = 'Duplicate proxy location: "%s"'; + +Var + PM : TProxyManager; + + +Function ProxyManager: TProxyManager; + +begin + If PM=Nil then + PM:=TProxyManager.Create; + Result:=PM; +end; + +{ TProxyManager } + +function TProxyManager.GetLocation(AIndex : Integer): TProxyLocation; +begin + Result:=FLocations[AIndex]; +end; + +function TProxyManager.GetLocationCount: Integer; +begin + Result:=FLocations.Count; +end; + +constructor TProxyManager.create; +begin + inherited create; + FLocations:=TProxyLocations.Create(TProxyLocation); +end; + +destructor TProxyManager.Destroy; +begin + FreeAndNil(FLocations); + inherited Destroy; +end; + +function TProxyManager.RegisterLocation(const APath, AURL: String + ): TProxyLocation; +begin + Result:=FLocations.FindLocation(APAth); + if Result<>Nil then + Raise EWAProxy.CreateFmt(SErrDuplicateProxy,[APath]); + Result:=FLocations.Add as TProxyLocation; + Result.Path:=APath; + Result.URL:=AURL; + Result.Enabled:=True; +end; + +function TProxyManager.UnRegisterLocation(const APath : String): boolean; + +Var + l : TProxyLocation; +begin + L:=FLocations.FindLocation(APath); + Result:=L<>Nil; + If Result then + L.Free; +end; + +function TProxyManager.FindLocation(const APath: String): TProxyLocation; +begin + Result:=FLocations.FindLocation(APath); +end; + +{ TProxyLocations } + +function TProxyLocations.GetL(AIndex : Integer): TProxyLocation; + +begin + Result:=Items[AIndex] as TProxyLocation; +end; + +procedure TProxyLocations.SetL(AIndex : Integer; AValue: TProxyLocation); + +begin + Items[AIndex]:=AValue; +end; + +function TProxyLocations.IndexOfLocation(const APath: String): Integer; +begin + Result:=Count-1; + While (Result>=0) and (CompareText(GetL(Result).Path,APath)<>0) do + Dec(Result); +end; + +function TProxyLocations.FindLocation(const APath: String): TProxyLocation; + +Var + I : Integer; + +begin + I:=IndexOfLocation(APath); + if (I=-1) then + Result:=Nil + else + Result:=GetL(I); +end; + +{ TProxyWebModule } + +procedure TProxyWebModule.RequestToClient(T : TFPHTTPClient; aRequest : TRequest); + +Var + H : THeader; + I : Integer; + N,V : String; + +begin + // Transfer known headers + for H in THeader do + if (hdRequest in HTTPHeaderDirections[H]) then + if aRequest.HeaderIsSet(H) then + if H<>hhHost then + begin + {$ifdef DEBUGPROXY}Writeln('Sending header: ',HTTPHeaderNames[H],': ',aRequest.GetHeader(H));{$ENDIF} + T.AddHeader(HTTPHeaderNames[H],aRequest.GetHeader(H)); + end; + // Transfer custom headers + For I:=0 to aRequest.CustomHeaders.Count-1 do + begin + aRequest.CustomHeaders.GetNameValue(I,N,V); + {$ifdef DEBUGPROXY}Writeln('Sending custom header: ',N,': ',V);{$ENDIF} + T.AddHeader(N,V); + end; + if (Length(ARequest.Content)>0) then + begin + T.RequestBody:=TMemoryStream.Create; + T.RequestBody.WriteBuffer(ARequest.Content[1],Length(ARequest.Content)); + T.RequestBody.Position:=0; + end; +end; + +procedure TProxyWebModule.DoLog(const aMethod,aLocation, aFromURL, aToURL: String); +begin + If Assigned(ProxyManager) and Assigned(ProxyManager.OnLog) then; + ProxyManager.OnLog(Self,aMethod,aLocation,aFromURl,aToURL); +end; + +procedure TProxyWebModule.ClientToResponse(T : TFPHTTPClient; aResponse : TResponse); + +Var + N,H : String; + HT : THeader; + +begin + for N in T.ResponseHeaders do + begin + H:=ExtractWord(1,N,[':']); + HT:=HeaderType(H); + if not (HT in [hhContentLength]) then + begin + {$IFDEF DEBUGPROXY}Writeln('Returning header: ',N);{$ENDIF} + AResponse.CustomHeaders.Add(N); + end; + end; + AResponse.Code:=T.ResponseStatusCode; + AResponse.CodeText:=T.ResponseStatusText; + AResponse.ContentLength:=AResponse.ContentStream.Size; +end; + +procedure TProxyWebModule.ReRouteRequest(L : TProxyLocation; ARequest: TRequest; AResponse: TResponse); + +Var + T : TFPHTTPClient; + P,URL : String; + +begin + URL:=L.URL; + if L.AppendPathInfo then + begin + P:=ARequest.PathInfo; + if (P<>'') then + URL:=IncludeHTTPPathDelimiter(URL)+P; + end; + if (ARequest.QueryString<>'') then + URL:=URL+'?'+ARequest.QueryString; + DoLog(aRequest.Method, L.Path,ARequest.URL, URL); + T:=TFPHTTPClient.Create(Self); + try + RequestToClient(T,aRequest); + aResponse.FreeContentStream:=True; + aResponse.ContentStream:=TMemoryStream.Create; + T.AllowRedirect:=True; + T.HTTPMethod(ARequest.Method,URL,AResponse.ContentStream,[]); + ClientToResponse(T,aResponse); + AResponse.SendContent; + finally + T.RequestBody.Free; + T.Free; + end; +end; + +procedure TProxyWebModule.HandleRequest(ARequest: TRequest; AResponse: TResponse); + +Var + P : String; + L : TProxyLocation; + +begin + P:=ARequest.GetNextPathInfo; + L:=ProxyManager.FindLocation(P); + if (L=Nil) or (Not L.Enabled) then + begin + AResponse.Code:=404; + AResponse.CodeText:='Location not found : '+P; + AResponse.SendContent; + end + else if L.Redirect then + begin + DoLog(L.Path,aRequest.method, ARequest.URL, L.URL); + AResponse.SendRedirect(L.URL); + AResponse.SendContent; + end + else + begin + ReRouteRequest(L,ARequest,AResponse); + if not AResponse.ContentSent then + AResponse.SendContent; + end; +end; + +finalization + FreeAndNil(PM); +end. +