{
    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,V : 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
      V:=Trim(ExtractWord(2,N,[':']));
      {$IFDEF DEBUGPROXY}Writeln('Returning header: ',N);{$ENDIF}
      AResponse.SetCustomHeader(H,V);
      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.GetNextPathInfo;
    While P<>'' do
      begin
      URL:=IncludeHTTPPathDelimiter(URL)+P;
      P:=ARequest.GetNextPathInfo;
      end;
    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.