Componentes.Terceros.RemObjects/internal/5.0.23.613/1/RemObjects SDK for Delphi/Source/uIPAsyncHttpServer.pas

unit uIPAsyncHttpServer;

interface

{$I RemObjects.inc}

uses
  SysUtils, Classes, uIPAsyncSocket, uIPHttpHeaders;

const
  DefaultMaxPostData = 1024 * 1024 * 2; // 2 mb

type
  TIPAsyncHttpServer = class;
  TIPAsyncContext = class;
  IIPAsyncContext = interface
    ['{83983C87-A9ED-47F2-9352-8C61455325A0}']
    function GetOwner: TIPAsyncHttpServer;
    function GetRequest: TIPHttpRequestHeaders;
    function GetResponse: TIPHttpResponseHeaders;
    function GetRequestData: TDynamicByteArray;
    procedure SetRequestData(aData: TDynamicByteArray);
    function GetResponseData: TDynamicByteArray;
    procedure SetResponseData(aData: TDynamicByteArray);
    function GetResponseSent: Boolean;
    function GetUserData: Pointer;
    procedure SetUserData(aData: Pointer);
    function GetDisconnected: Boolean;

    property Owner: TIPAsyncHttpServer read GetOwner;
    property Request: TIPHttpRequestHeaders read GetRequest;
    property Response: TIPHttpResponseHeaders read GetResponse;
    property RequestData: TDynamicByteArray read GetRequestData write SetRequestData;
    property ResponseData: TDynamicByteArray read GetResponseData write SetResponseData;
    property ResponseSent: Boolean read GetResponseSent;
    property UserData: Pointer read GetUserData write SetUserData;
    property Disconnected: Boolean read GetDisconnected;

    procedure SendResponse;
    function GetSelf: TIPAsyncContext;
  end;
  TIPAsyncContext = class(TInterfacedObject, IIPAsyncContext)
  private
    fOwner: TIPAsyncHttpServer;
    fRequest: TIPHttpRequestHeaders;
    fResponse: TIPHttpResponseHeaders;
    fRequestData: TDynamicByteArray;
    fResponseData: TDynamicByteArray;
    fResponseSent: Boolean;
    fConnection: TIPBaseAsyncSocket;
    fUserData: Pointer;
    fTempBuf: TDynamicByteArray;
    fBodyOffset: Integer;
    fDisconnected: Boolean;
    procedure cbDisconnect(sender: TIPBaseAsyncSocket);
    procedure cbFirstLine(sender: TIPBaseAsyncSocket);
    procedure cbHeaderLine(sender: TIPBaseAsyncSocket);
    procedure cbPostData(sender: TIPBaseAsyncSocket);
    procedure cbResponse(sender: TIPBaseAsyncSocket);
    procedure SendInvalidRequest(aMessage: string = '');
    function GetDisconnected: Boolean;
    function GetOwner: TIPAsyncHttpServer;
    function GetRequest: TIPHttpRequestHeaders;
    function GetRequestData: TDynamicByteArray;
    function GetResponse: TIPHttpResponseHeaders;
    function GetResponseData: TDynamicByteArray;
    function GetResponseSent: Boolean;
    function GetUserData: Pointer;
    procedure SetRequestData(aData: TDynamicByteArray);
    procedure SetResponseData(aData: TDynamicByteArray);
    procedure SetUserData(aData: Pointer);
  public
    constructor Create(aOwner: TIPAsyncHttpServer; aConnection: TIPBaseAsyncSocket);
    destructor Destroy; override;

    procedure Clear;

    procedure Disconnect;

    property Owner: TIPAsyncHttpServer read fOwner;
    property Request: TIPHttpRequestHeaders read fRequest;
    property Response: TIPHttpResponseHeaders read fResponse;
    property RequestData: TDynamicByteArray read fRequestData write fRequestData;
    property ResponseData: TDynamicByteArray read fResponseData write fResponseData;
    property ResponseSent: Boolean read fResponseSent;
    property UserData: Pointer read fUserData write fUserData;
    property Disconnected: Boolean read fDisconnected;

    procedure SendResponse;
    function GetSelf: TIPAsyncContext;
  end;
  TIPAsyncHttpRequestHandler = procedure (Sender: TObject; aContext: IIPAsyncContext) of Object;
  TIPAsyncHttpServer = class(TObject)
  private
    fOnManualBind: TNotifyEvent;
    fOnBeforeData,
    fOnBeforeCleanupContext,
    fOnRequest: TIPAsyncHttpRequestHandler;
    fOnResponseSent,
    fOnResponsefailed: TIPAsyncHttpRequestHandler;
    fMaxPostData: Integer;
    fMaxHeaderLines: Integer;
    fActive: Boolean;
    fSocket4,
    fSocket6: TIPBaseAsyncSocket;
    fBindV4,
    fBindV6: Boolean;
    fPort: Integer;
    fClients: TInterfaceList;
    procedure SetActive(aValue: Boolean);
    procedure cbAccept(aSender: TIPBaseAsyncSocket);
    procedure DisconnectClients;
  public
    constructor Create;
    destructor Destroy; override;

    property Socket4: TIPBaseAsyncSocket read fSocket4;
    property Socket6: TIPBaseAsyncSocket read fSocket6;
    property Port: Integer read fPort write fPort default 80;
    property BindV4: Boolean read fBindV4 write fBindV4 default true;
    property BindV6: Boolean read fBindV6 write fBindV6 default false;
    property MaxHeaderLines: Integer read fMaxHeaderLines write fMaxHeaderLines default 64;

    property Active: Boolean read fActive write SetActive;

    property MaxPostData: Integer read fMaxPostData write fMaxPostData default DefaultMaxPostData;

    property OnManualBind: TNotifyEvent read fOnManualBind write fOnManualBind;
    property OnBeforeData: TIPAsyncHttpRequestHandler read fOnBeforeData write fOnBeforeData;
    property OnRequest: TIPAsyncHttpRequestHandler read fOnrequest write fOnrequest;
    property OnBeforeCleanupContext: TIPAsyncHttpRequestHandler read fOnBeforeCleanupContext write fOnBeforeCleanupContext;
    property OnResponseSent: TIPAsyncHttpRequestHandler read fOnResponseSent write fOnResponseSent;
    property OnResponseFailed: TIPAsyncHttpRequestHandler read fOnResponsefailed write fOnResponsefailed;

  end;

implementation

uses Math;

{ TIPAsyncContext }

procedure TIPAsyncContext.cbDisconnect(sender: TIPBaseAsyncSocket);
var
  lConn: TIPBaseAsyncSocket;
begin
  fDisconnected := true;
  if assigned(fOwner) and assigned(fOwner.fOnBeforeCleanupContext) then
    fOwner.fOnBeforeCleanupContext(fOwner, Self);
  lConn := fConnection;
  fConnection := nil;
  if lConn <> nil then begin
    lConn.EndDisconnect;
    lConn.Free;
  end;
  if assigned(fOwner) then begin
    fOwner.fClients.Remove(IIPAsyncContext(self));
  end;
end;

procedure TIPAsyncContext.cbFirstLine(sender: TIPBaseAsyncSocket);
var
  lLine: string;
  lIdx: Integer;
begin
  if not sender.EndReadLine(lLine) then begin
    cbDisconnect(sender);
    exit;
  end;
  lIdx := pos(' ', lLine);
  if lIdx = 0 then begin
    SendInvalidRequest;
    exit;
  end;
  fRequest.Method := copy(lLine, 1, lIdx-1);
  Delete(lLine, 1, lIdx);
  lIdx := pos(' ', lLine);
  if lIdx = 0 then begin
    SendInvalidRequest;
    exit;
  end;
  fRequest.Path := copy(lLine, 1, lIdx -1);
  fRequest.Version := UpperCase(copy(lLine, lIdx+1, MaxInt));
  if (fRequest.Method <> 'GET') and (fRequest.Method <> 'POST') then begin
    SendInvalidRequest;
    exit;
  end;

  sender.BeginReadLine(cbHeaderLine);
end;

procedure TIPAsyncContext.cbHeaderLine(sender: TIPBaseAsyncSocket);
var
  lLine: string;
  i: Integer;
  lName, lVal: string;
begin
  if not Sender.EndReadLine(lLine) then begin
    cbDisconnect(sender);
    exit;
  end;
  if lLine <> '' then begin
    if assigned(fOwner) and (fRequest.Headers.Count > fOwner.MaxHeaderLines) then begin
      SendInvalidRequest;
      exit;
    end;
    i := Pos(':', lLine);
    if i = 0 then begin
      SendInvalidRequest;
      exit;
    end;
    lName := Trim(copy(lLine, 1, i-1));
    lVal := trim(Copy(lLine, i+1, MaxInt));
    fRequest.Headers.Add(lName+'='+lVal);
    sender.BeginReadLine(cbHeaderLine);
  end else begin
    if fRequest.Method = 'POST' then begin
      try
        if assigned(fOwner) and assigned(fowner.fOnBeforeData) then fOwner.fOnBeforeData(fOwner, Self);
      except
        SendInvalidRequest; // we cannot let exceptions escape to the caller thread.
        exit;
      end;
      if fRequest.ContentLength > fOwner.fMaxPostData then begin
        SendInvalidRequest('Content-Length too large');
        exit;
      end;
      SetLength(fRequestData, fRequest.ContentLength);
      sender.BeginReceive(@fRequestData[0], 0, Length(fRequestData), cbPostData);
    end else begin
      try
        if assigned(fOwner) and assigned(fOwner.fOnRequest) then begin
          fOwner.fOnRequest(fOwner, Self);
        end else begin
          SendInvalidRequest('Request handler not assigned');
          exit;
        end;
      except
        SendInvalidRequest;
        exit;
      end;
    end;
  end;
end;

procedure TIPAsyncContext.cbPostData(sender: TIPBaseAsyncSocket);
begin
  if sender.EndReceive < Length(fRequestData) then begin
    cbDisconnect(sender); // we got disconnected when there's less data. When buffered is true it won't return until all data is there.
    exit;
  end;
  try
    if assigned(fOwner) and assigned(fOwner.fOnRequest) then begin
      fOwner.fOnRequest(fOwner, Self);
    end else begin
      SendInvalidRequest('Request handler not assigned');
      exit;
    end;
  except
    SendInvalidRequest;
    exit;
  end;
end;

procedure TIPAsyncContext.Clear;
begin
  if assigned(fOwner) and assigned(fOwner.fOnBeforeCleanupContext) then
    fOwner.fOnBeforeCleanupContext(fOwner, Self);
  fRequest.Clear;
  fResponse.Clear;
  fRequestData := nil;
  fResponseData := nil;
  fResponseSent := false;
end;

constructor TIPAsyncContext.Create(aOwner: TIPAsyncHttpServer;
  aConnection: TIPBaseAsyncSocket);
begin
  fOwner := aOwner;
  fConnection := aConnection;
  fConnection.MaxLineLength := 8096;
  fConnection.OnDisconnected := cbDisconnect;
  fRequest := TIPHttpRequestHeaders.Create;
  fResponse := TIPHttpResponseHeaders.Create;
  fconnection.Buffered := true;
  fConnection.IdleTimeout := 180; // 3min
  fConnection.OnTimeout := cbDisconnect;
  fConnection.BeginReadLine(cbFirstLine);
end;

destructor TIPAsyncContext.Destroy;
begin
  inc(FRefCount);
  Clear;
  Dec(FRefCount);
  fRequest.Free;
  fResponse.Free;
  inherited Destroy;
end;

procedure TIPAsyncContext.Disconnect;
begin
  fDisconnected := true;
  if fResponseSent then begin
    if assigned(fOwner) and assigned(fOwner.fOnResponsefailed) then fOwner.fOnResponsefailed(fOwner, Self);
  end;

  if assigned(fConnection) then
    fConnection.BeginDisconnect(cbDisconnect);
end;

procedure TIPAsyncContext.SendInvalidRequest(aMessage: string = '');
begin
  fResponse.Code := 500;
  fResponse.Reason := 'Internal Server Error';
  fResponse.Headers.VAlues['Content-Type'] := 'text/html';
  aMessage := '<html><head><title>Invalid Request</title></head><body><h1>Invalid Request</h1>'+aMessage+'</body></html>';
  SetLength(fResponseData, Length(aMessage));
  Move(aMessage[1], fResponseData[0], Length(aMessage));
  SendResponse;
end;

procedure TIPAsyncContext.SendResponse;
var
  lHeaderData: string;
begin
  if fResponseSent then raise EIPSocketError.Create('Response already sent');
  fResponseSent := true;
  if fDisconnected then begin
    if assigned(fOwner)  and assigned(fOwner.fOnResponsefailed) then begin
      fOwner.fOnResponsefailed(fOwner, self);
    end;
    exit;
  end;
  fResponse.Headers.Values['Content-Length'] := IntToStr(Length(fResponseData));
  lHeaderData := fResponse.ToString;
  if (Length(lHeaderData) > 4096) or (Length(fResponseData) = 0) then begin
    if Length(fTempBuf) < Length(lHeaderData) then begin
      if Length(lHeaderData) > 4096 then
        SetLength(fTempBuf, Length(lHeaderData))
      else
        SetLength(fTempBuf, 4096);
    end;
    Move(lHeaderdata[1], fTempBuf[0], Length(lHeaderData));
    fBodyOffset := 0;
    fConnection.BeginSend(@ftempBuf[0], 0, Length(lHeaderData), cbResponse);
  end else begin
    if Length(fTempBuf) < 4096 then SetLength(fTempBuf, 4096);
    Move(lHeaderdata[1], fTempBuf[0], Length(lHeaderData));
    fBodyOffset := 4096 - Length(lHeaderData);
    if fBodyOffset > Length(fResponseData) then fBodyOffset := Length(fResponseData);
    Move(fResponseData[0], fTempBuf[Length(lHeaderData)], fBodyOffset);
    fconnection.BeginSend(@fTempBuf[0], 0, fBodyOffset + Length(lHeaderData), cbResponse);
  end;
end;


procedure TIPAsyncContext.cbResponse(sender: TIPBaseAsyncSocket);
var
  lLen: Integer;
begin
  if fConnection.EndSend <= 0 then begin
    cbDisconnect(sender);
    exit;
  end;
  lLen := 4096;
  if fBodyOffset+ lLen > Length(fResponseData) then
    lLen := Length(fResponseData) - fBodyOffset;
  if lLen <= 0 then begin
    if assigned(fOwner) and assigned(fOwner.fOnResponseSent) then fOwner.fOnResponseSent(fOwner, Self);
    Clear; // we're done
    fConnection.BeginReadLine(cbFirstLine);
  end else begin
    move(fResponseData[fBodyOffset], fTempBuf[0], lLen);
    fBodyOffset := fBodyOffset + lLen;
    fcOnnection.BeginSend(@fTempBuf[0], 0, lLen, cbResponse);
  end;
end;


function TIPAsyncContext.GetDisconnected: Boolean;
begin
  result := fDisconnected;
end;

function TIPAsyncContext.GetOwner: TIPAsyncHttpServer;
begin
  result := fOwner;
end;

function TIPAsyncContext.GetRequest: TIPHttpRequestHeaders;
begin
  result := fRequest;
end;

function TIPAsyncContext.GetRequestData: TDynamicByteArray;
begin
  result := fRequestData;
end;

function TIPAsyncContext.GetResponse: TIPHttpResponseHeaders;
begin
  result := fREsponse;
end;

function TIPAsyncContext.GetResponseData: TDynamicByteArray;
begin
  result := fResponseData;
end;

function TIPAsyncContext.GetResponseSent: Boolean;
begin
  result := fResponseSent;
end;

function TIPAsyncContext.GetUserData: Pointer;
begin
  result := fUserData;
end;

procedure TIPAsyncContext.SetRequestData(aData: TDynamicByteArray);
begin
  fRequestData := aData;
end;

procedure TIPAsyncContext.SetResponseData(aData: TDynamicByteArray);
begin
  fResponseData := aData;
end;

procedure TIPAsyncContext.SetUserData(aData: Pointer);
begin
  fUserData := aDAta;
end;

function TIPAsyncContext.GetSelf: TIPAsyncContext;
begin
  result := self;
end;

{ TIPAsyncHttpServer }

procedure TIPAsyncHttpServer.cbAccept(aSender: TIPBaseAsyncSocket);
var
  lSock: TIPBaseAsyncSocket;
  lContext: IIPAsyncContext;
begin
  try
    lSock := aSender.EndAccept;
  except
    on e: EIPSocketError do
      exit;
      // We're shutting down, exit now.
  end;
  lContext := TIPAsyncContext.Create(self, lSock);
  fClients.Add(lContext);
  aSender.BeginAccept(cbAccept);
end;

constructor TIPAsyncHttpServer.Create;
begin
  inherited Create;
  fMaxPostData := DefaultMaxPostData;
  fMaxHeaderLines := 64;
  fBindV6 := false;
  fBindV4 := true;
  fPort := 80;
  fClients := TInterfaceList.Create;
end;

destructor TIPAsyncHttpServer.Destroy;
begin
  Active := False;
  DisconnectClients;
  fClients.Free;
  inherited Destroy;
end;

procedure TIPAsyncHttpServer.DisconnectClients;
var
  i: integer;
  ctx: IIPAsyncContext;
begin
  fClients.Lock;
  try
    for i := 0 to fClients.Count -1 do begin
      ctx := IIPAsyncContext(fClients[i]);
      ctx.GetSelf.fOwner := nil;
      ctx.GetSelf.Disconnect;
    end;
  finally
    fClients.Unlock;
  end;
  fClients.Clear;
end;

procedure TIPAsyncHttpServer.SetActive(aValue: Boolean);
begin
  if fActive = aValue then exit;
  fActive := aValue;
  if aValue then begin
    if fBindV4 then begin
      fSocket4 := TIPAsyncSocket.Create(rsmTCPIP4);
      if not assigned(fOnManualBind) then
        fSocket4.Bind('0.0.0.0', fPort);
    end;
    if fBindV6 then begin
      fSocket6 := TIPAsyncSocket.Create(rsmTCPIP6);
      if not assigned(fOnManualBind) then
        fSocket6.Bind('0.0.0.0', fPort);
    end;
    if assigned(fOnManualBind) then fOnManualBind(self);
    if assigned(fSocket4) then begin
      fSocket4.Listen(10);
      fSocket4.BeginAccept(cbAccept);
    end;
    if assigned(fSocket6) then begin
      fSocket6.Listen(10);
      fSocket6.BeginAccept(cbAccept);
    end;
  end else begin
    DisconnectClients;
    fSocket4.Free;
    fSocket6.Free;
    fSocket4 := nil;
    fSocket6 := nil;
  end;
end;

end.