FastReport_2022_VCL/LibD28x64/frxTransportHTTP.pas

{******************************************}
{                                          }
{             FastReport VCL               }
{          HTTP connection client          }
{                                          }
{         Copyright (c) 1998-2021          }
{            Fast Reports Inc.             }
{                                          }
{******************************************}

unit frxTransportHTTP;

{$I frx.inc}
interface

uses
  Windows, Messages, SysUtils, Classes, ScktComp, frxServerUtils, frxNetUtils, Math,
  frxGzip, frxMD5, WinSock, frxBaseTransportConnection, frxBaseSocketIOHandler;

const
  HTTP_POST = 'POST';
  HTTP_GET = 'GET';
  HTTP_DELETE = 'DELETE';
  HTTP_PUT = 'PUT';
  HTTP_VER1 = 'HTTP/1.0';
  HTTP_LINK_PREFIX: AnsiString = 'http://';
  HTTPS_LINK_PREFIX: AnsiString = 'https://';

type
  TfrxRequestType = (xrtPost, xrtGet, xrtDelete, xrtPut);
  TfrxHTTPContentType = (htcNone, hctDefaultHTML, htcDefaultXML, htcDefaultApp);

type
  TfrxHTTPRequest = class (TPersistent)
  private
    FURL: AnsiString;
    FContentType: AnsiString;
    FAuthorization: AnsiString;
    FReqType: TfrxRequestType;
    FSourceStream: TStream;
    FAcceptTypes: AnsiString;
    FDefAcceptTypes: TfrxHTTPContentType;
    FEncoding: AnsiString;
    FUserAgent: AnsiString;
    FPort: Integer;
    function GetText: AnsiString;
    procedure SetText(const Value: AnsiString);
  protected
    FRequest: TStringList;
    FCustomHeader: TStrings;
    procedure SureEmptyLineAtEnd;
  public
    constructor Create;
    destructor Destroy; override;
    procedure BuildRequest; virtual;
    procedure Redirect(const NewAddress: AnsiString);
    function IsValidAddress: Boolean;
    function Host(bTruncPort: Boolean = True): AnsiString;
    function GetPort: AnsiString;
    property Authorization: AnsiString read FAuthorization write FAuthorization;
    property ReqType: TfrxRequestType read FReqType write FReqType;
    property Port: Integer read FPort write FPort;
    property SourceStream: TStream read FSourceStream write FSourceStream;
    property AcceptTypes: AnsiString read FAcceptTypes write FAcceptTypes;
    property ContentType: AnsiString read FContentType write FContentType;
    property DefAcceptTypes: TfrxHTTPContentType read FDefAcceptTypes write FDefAcceptTypes;
    property CustomHeader: TStrings read FCustomHeader;
    property Encoding: AnsiString read FEncoding write FEncoding;
    property UserAgent: AnsiString read FUserAgent write FUserAgent;

    property URL: AnsiString read FURL write FURL;
    property Text: AnsiString read GetText write SetText;
  end;

  TfrxHTTPServerFields = class;

{$IFDEF DELPHI16}
[ComponentPlatformsAttribute(pidWin32 or pidWin64)]
{$ENDIF}
  TfrxTransportHTTP = class(TfrxBaseTransportConnection)
  private
    FActive: Boolean;
    FConnected: Boolean;
    FRequestString: AnsiString;
    FAnswer: TStrings;
    FBreaked: Boolean;
    FErrors: TStrings;
    FMIC: Boolean;
    FProxyHost: String;
    FProxyPort: Integer;
    FRetryCount: Integer;
    FRetryTimeOut: Integer;
    FServerFields: TfrxHTTPServerFields;
    FRequestStream: TMemoryStream;
    FRawDataStream: TMemoryStream;
    FTimeOut: Integer;
    FProxyLogin: String;
    FProxyPassword: String;
    FPort: Integer;
    FConnectDelay: Cardinal;
    FAnswerDelay: Cardinal;
    FIOHandler: TfrxCustomIOHandler;
    FHandleOnlySocketMessages: Boolean;
//    FSocketType: TfrxSocketType;
    procedure ParseAnswer(aToDataStream: TStream);
//    procedure DoConnect(Sender: TObject; Socket: TCustomWinSocket);
//    procedure DoLookup(Sender: TObject; Socket: TCustomWinSocket);
    procedure DoDisconnect(Sender: TObject; Socket: TCustomWinSocket);
    procedure DoError(Sender: TObject; Socket: TCustomWinSocket;
      ErrorEvent: TErrorEvent; var ErrorCode: Integer);

    procedure SetActive(const Value: Boolean);
    procedure SetServerFields(const Value: TfrxHTTPServerFields);
    procedure SetIOHandler(const Value: TfrxCustomIOHandler);
  protected
    FHTTPRequest: TfrxHTTPRequest;
    FClientSocket: TClientSocket;
    StreamSize: Cardinal;
    procedure SetSocketDestination;
    function IsAnswerCodeIn(Answers: array of Integer): boolean;
    function GetProxyHost: String; override;
    function GetProxyLogin: String; override;
    function GetProxyPassword: String; override;
    function GetProxyPort: Integer; override;
    procedure SetProxyHost(const Value: String); override;
    procedure SetProxyLogin(const Value: String); override;
    procedure SetProxyPassword(const Value: String); override;
    procedure SetProxyPort(const Value: Integer); override;
    function GetSocketType: TfrxSocketType; override;
    procedure SetSocketType(const Value: TfrxSocketType); override;
    procedure DoMessages;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Connect; override;
    procedure StartListening;
    procedure Disconnect; override;
    procedure Open;
    procedure Close;
    procedure DoWrite(Sender: TObject; Socket: TCustomWinSocket);
    procedure DoRead(Sender: TObject; Socket: TCustomWinSocket);
    procedure Send(aSource: TStream); // sync method does not return untill finish
    procedure SetDefaultParametersWithToken(AToken: String); override;
    procedure Receive(aSource: TStream); // sync method does not return untill finish
    function Post(aURL: AnsiString; aSource: TStream = nil): AnsiString; overload; // sync method does not return untill finish
    function Get(aURL: AnsiString; aSource: TStream = nil): AnsiString; overload; // sync method does not return untill finish
    function Put(aURL: AnsiString; aSource: TStream = nil): AnsiString; overload; // sync method does not return untill finish
    function Post(aURL: WideString; aSource: TStream = nil): WideString; overload; // sync method does not return untill finish
    function Get(aURL: WideString; aSource: TStream = nil): WideString; overload; // sync method does not return untill finish
    function Put(aURL: WideString; aSource: TStream = nil): WideString; overload; // sync method does not return untill finish
    function Delete(aURL: AnsiString): AnsiString; overload; // sync method does not return untill finish
    function Delete(aURL: WideString): WideString; overload; // sync method does not return untill finish
    property Answer: TStrings read FAnswer write FAnswer;
    property Errors: TStrings read FErrors write Ferrors;
    property RequestStream: TMemoryStream read FRequestStream;
    property IOHandler: TfrxCustomIOHandler read FIOHandler write SetIOHandler;
    property HandleOnlySocketMessages: Boolean read FHandleOnlySocketMessages write FHandleOnlySocketMessages;
  published
    property Active: Boolean read FActive write SetActive;
    property RequestString: AnsiString read FRequestString write FRequestString;
    property HTTPRequest: TfrxHTTPRequest read FHTTPRequest;
    property ClientSocket: TClientSocket read FClientSocket;
    property MIC: Boolean read FMIC write FMIC;
    property Port: Integer read FPort write FPort;
    property ProxyHost;
    property ProxyPort;
    property ProxyLogin;
    property ProxyPassword;
    property RetryCount: Integer read FRetryCount write FRetryCount;
    property RetryTimeOut: Integer read FRetryTimeOut write FRetryTimeOut;
    property ServerFields: TfrxHTTPServerFields read FServerFields write SetServerFields;
    property TimeOut: Integer read FTimeOut write FTimeOut;
    property ConnectDelay: Cardinal read FConnectDelay;
    property AnswerDelay: Cardinal read FAnswerDelay;
    property OnWork;
    property OnWorkBegin;
    property OnWorkEnd;
  end;

  TfrxHTTPServerFields = class (TPersistent)
  private
    FAnswerCode: Integer;
    FContentEncoding: String;
    FContentMD5: String;
    FContentLength: Integer;
    FLocation: String;
    FSessionId: String;
    FCookie: String;
  public
    constructor Create;
    procedure Assign(Source: TPersistent); override;
    procedure ParseAnswer(st: AnsiString);
  published
    property AnswerCode: Integer read FAnswerCode write FAnswerCode;
    property ContentEncoding: String read FContentEncoding write FContentEncoding;
    property ContentMD5: String read FContentMD5 write FContentMD5;
    property ContentLength: Integer read FContentLength write FContentLength;
    property Location: String read FLocation write FLocation;
    property SessionId: String read FSessionId write FSessionId;
    property Cookie: String read FCookie write FCookie;
  end;

  procedure frxTestToken(const URL: String; var sToken: String; bUsePOST: Boolean = False; PrefixAut: String = 'Bearer ');

  var
    msc: TFPUExceptionMask;

implementation

uses
  StrUtils,
  frxFileUtils, frxUtils, frxOpenSSL, frxHTTPProtocol, frxHTTPSProtocol
{$IFDEF DELPHI12}
  ,AnsiStrings
{$ENDIF};

procedure frxTestToken(const URL: String; var sToken: String; bUsePOST: Boolean = False; PrefixAut: String = 'Bearer ');
var
  tHttp: TfrxTransportHTTP;
  Res: AnsiString;
  MemTmp: TMemoryStream;
begin
  if sToken = '' then Exit;

  tHttp := TfrxTransportHTTP.Create(nil);
  MemTmp := TMemoryStream.Create;
  try
    tHttp.HTTPRequest.DefAcceptTypes := htcDefaultXML;
    tHttp.HTTPRequest.ContentType := '';
    tHttp.SocketType := fstBlocking;
    tHttp.HTTPRequest.Authorization := AnsiString(PrefixAut + sToken);
    try
      if bUsePOST then
        Res := tHttp.Post(AnsiString(URL), MemTmp)
      else
        Res := tHttp.Get(AnsiString(URL));
    except
      sToken := '';
    end;
    if tHttp.Errors.Count > 0 then
      sToken := '';
  finally
    tHttp.Free;
    MemTmp.Free;
  end;
end;

{ TfrxHTTPServerFields }

constructor TfrxHTTPServerFields.Create;
begin
  FAnswerCode := 0;
  FLocation := '';
  FContentEncoding := '';
  FContentMD5 := '';
  FContentLength := 0;
end;

procedure TfrxHTTPServerFields.ParseAnswer(st: AnsiString);

  function IsDigit(const c: AnsiChar): Boolean;
  begin
    Result := {$IFDEF Delphi12} CharInSet(c, ['0'..'9']);
              {$ELSE}           c in ['0'..'9'];
              {$ENDIF}
  end;

var
  i, j: Integer;
  s1, s2: AnsiString;
begin
  FAnswerCode := 0;
  i := Pos(AnsiString(#13#10), st);
  s1 := Copy(st, 1, i - 1);
  j := 0;
  s2 := '';
  for i := 1 to Length(s1) do
  begin
    if IsDigit(s1[i]) then
    begin
      s2 := s2 + s1[i];
      Inc(j);
    end else
    if j = 3 then
      break
    else
    begin
      j := 0;
      s2 := '';
    end;
  end;
  s1 := s2;
  if Length(s1) = 3 then
    FAnswerCode := StrToInt(String(s1));


  s1 := ParseHeaderField('location: ', st);
  if s1 = '' then
    s1 := ParseHeaderField('Location: ', st);
  if (Length(s1) > 0) and (s1[1] = '/') then
    Delete(s1, 1, 1);
  Location := String(s1);

  ContentEncoding := LowerCase(String(ParseHeaderField('Content-Encoding: ', st)));

  ContentMD5 := String(ParseHeaderField('Content-MD5: ', st));

  Cookie := UpdateCookies(String(st), Cookie);

  s1 := ParseHeaderField('SessionId: ', st);
  SessionId := IfStr(s1 <> '', String(s1));

  s1 := ParseHeaderField('Content-length: ', st);
  if s1 <> '' then
    ContentLength := StrToInt(String(s1));
end;

procedure TfrxHTTPServerFields.Assign(Source: TPersistent);
begin
  if Source is TfrxHTTPServerFields then
  begin
    FAnswerCode := TfrxHTTPServerFields(Source).AnswerCode;
    FLocation := TfrxHTTPServerFields(Source).Location;
    FContentEncoding := TfrxHTTPServerFields(Source).ContentEncoding;
    FContentMD5 := TfrxHTTPServerFields(Source).ContentMD5;
    FContentLength := TfrxHTTPServerFields(Source).ContentLength;
  end;
end;

{ TfrxHTTP }

constructor TfrxTransportHTTP.Create(AOwner: TComponent);
begin
  inherited;
  FConnectDelay := 0;
  FAnswerDelay := 0;
  FAnswer := TStringList.Create;
  FRequestStream := TMemoryStream.Create;
  FRawDataStream := TMemoryStream.Create;
  FErrors := TStringList.Create;
  FProxyHost := '';
  FProxyPort := 80;
  FPort := 80;
  FActive := False;
  FServerFields := TfrxHTTPServerFields.Create;
  FRetryTimeOut := 5;
  FRetryCount := 3;
  FTimeOut := 20;
  FBreaked := False;
  FMIC := True;
  FClientSocket := TClientSocket.Create(nil);
  //FClientSocket.OnLookup := DoLookup;
  //FClientSocket.OnConnect := DoConnect;
  //FClientSocket.OnWrite := DoWrite;
  //FClientSocket.OnRead := DoRead;
  FClientSocket.OnDisconnect := DoDisconnect;
  FClientSocket.OnError := DoError;
  SocketType := fstNonBlocking;
//  FClientSocket.ClientType := ctNonBlocking;
  FHTTPRequest := TfrxHTTPRequest.Create;
  FIOHandler := frxDefaultSocketIOHandlerClass.Create;
end;

procedure TfrxTransportHTTP.Close;
begin
  FBreaked := True;
  Active := False;
  FClientSocket.Close;
//  DoDisconnect(nil, nil);
end;

procedure TfrxTransportHTTP.Connect;
var
  ticks: Cardinal;
  i: Integer;
  bHandleInit, bSockBinded: Boolean;
begin
  i := FRetryCount;
  FBreaked := False;
  bHandleInit := False;
  if not FHTTPRequest.IsValidAddress then
    Errors.Add('There is no "http://" or "https://" in the request.')
  else
  begin
    SetSocketDestination;
    repeat
      FErrors.Clear;
      FRawDataStream.Clear;
      FConnectDelay := GetTickCount;
      FAnswerDelay := GetTickCount;
      FConnected := False;
      bSockBinded := False;
      try
        if not bHandleInit then
        begin
          bHandleInit := FIOHandler.InitializeHandler;
          if not bHandleInit then
            raise Exception.Create('Could not initialize IO Handler.');
        end;
        FClientSocket.Close;
        DoMessages;
        FClientSocket.Open;
        DoMessages;

        FActive := True;

        //if FClientSocket.Active then

        ticks := GetTickCount;
        while FActive and not FBreaked and not FConnected do
        begin
          if FClientSocket.Socket.Connected then
          begin
           if not bSockBinded then
           begin
             FIOHandler.BindSocket(FClientSocket.Socket, AnsiString(FClientSocket.Address));
             bSockBinded := True;
           end;
           DoMessages;
           FConnected := FIOHandler.TryConnect;
          end;
          DoMessages;
          if ((GetTickCount - ticks) > Cardinal(FTimeOut * 1000)) and not FClientSocket.Active then
          begin
            Errors.Add('Timeout expired (' + IntToStr(FTimeOut) + ')');
            Break;
          end;
        end;
      except
        on E:Exception do
          Errors.Add(E.Message);
      end;
        if not FConnected then
          Dec(i);
    until (i = 0) or FBreaked or FConnected;
  end;
end;

function TfrxTransportHTTP.Delete(aURL: AnsiString): AnsiString;
var
  ReqStream, AnswerStream: TMemoryStream;
begin
  Result := '';
  FHTTPRequest.ReqType := xrtDelete;
  FHTTPRequest.URL := aURL;
  FHTTPRequest.Port := FPort;
  FHTTPRequest.SourceStream := nil;
  FHTTPRequest.BuildRequest;
  ReqStream := TMemoryStream.Create;
  AnswerStream := TMemoryStream.Create;
  try
    Open;
    if not FConnected and (Errors.Count > 0) then
      raise Exception.Create(Errors[Errors.Count - 1]);
    if not FConnected then Exit;
    FHTTPRequest.FRequest.SaveToStream(ReqStream);
    Send(ReqStream);
    FRawDataStream.Clear;
    repeat
      Receive(FRawDataStream);
      ParseAnswer(AnswerStream);
    until (Errors.Count = 0) or (FServerFields.AnswerCode <> 100);
    Close;
    if AnswerStream.Size > 0 then
    begin
      AnswerStream.Position := 0;
      SetLength(Result, AnswerStream.Size);
      AnswerStream.Read(Result[1], AnswerStream.Size)
    end;
  finally
    AnswerStream.Free;
    ReqStream.Free;
  end;
end;

function TfrxTransportHTTP.Delete(aURL: WideString): WideString;
begin
  Result := WideString(Delete(AnsiString(aURL)));
end;

destructor TfrxTransportHTTP.Destroy;
begin
  Close;
  DoMessages;
  while FActive do
    DoMessages;
  FClientSocket.Close;

  FreeAndNil(FClientSocket);
  FreeAndNil(FHTTPRequest);
  FreeAndNil(FServerFields);
  FreeAndNil(FAnswer);
  FreeAndNil(FRequestStream);
  FreeAndNil(FRawDataStream);
  FreeAndNil(FIOHandler);
  FreeAndNil(FErrors);
  inherited;
end;

procedure TfrxTransportHTTP.Disconnect;
begin
  FIOHandler.Disconnect;
  FClientSocket.Close;
  FActive := False;
end;

//procedure TfrxTransportHTTP.DoConnect(Sender: TObject; Socket: TCustomWinSocket);
//begin
//  // not implimented
//  FConnectDelay := GetTickCount - FConnectDelay;
//  try
//    FRequestStream.Clear;
//
//  except
//    Errors.Add('Data send error');
//  end;
//end;

procedure TfrxTransportHTTP.DoDisconnect(Sender: TObject; Socket: TCustomWinSocket);
begin
  FActive := False;
  FConnected := False;
end;

procedure TfrxTransportHTTP.DoError(Sender: TObject; Socket: TCustomWinSocket;
  ErrorEvent: TErrorEvent; var ErrorCode: Integer);
begin
  Errors.Add(GetSocketErrorText(ErrorCode));
  FActive := False;
  ErrorCode := 0;
end;

procedure TfrxTransportHTTP.DoMessages;
var
  msg: Tmsg;
begin
  if SocketType = fstBlocking then Exit;
  if FHandleOnlySocketMessages then
  begin
    while PeekMessage(Msg, 0, 0, 0, PM_REMOVE) do begin
    if Msg.Message = WM_QUIT then exit;
    {$IFNDEF Linux} //TODO?
      if (Msg.Message = CM_SOCKETMESSAGE) or (Msg.Message = CM_DEFERFREE) or (Msg.Message = CM_LOOKUPCOMPLETE) then
      begin
        TranslateMessage(Msg);
        DispatchMessage(Msg);
      end
      else if Msg.message = WM_PAINT then
        ValidateRect(Msg.hwnd, nil);
    {$ENDIF}
    end;
  end
  else
    PMessages;
end;

//procedure TfrxTransportHTTP.DoLookup(Sender: TObject; Socket: TCustomWinSocket);
//begin
//
//end;

procedure TfrxTransportHTTP.DoRead(Sender: TObject; Socket: TCustomWinSocket);
begin
// TODO
end;

procedure TfrxTransportHTTP.DoWrite(Sender: TObject; Socket: TCustomWinSocket);
begin
// TODO
end;

function TfrxTransportHTTP.Get(aURL: WideString; aSource: TStream): WideString;
begin
  Result := WideString(Get(AnsiString(aURL), aSource));
end;

function TfrxTransportHTTP.Put(aURL: WideString; aSource: TStream = nil): WideString;
begin
  Result := WideString(Put(AnsiString(aURL), aSource));
end;

function TfrxTransportHTTP.GetProxyHost: String;
begin
  Result := FProxyHost;
end;

function TfrxTransportHTTP.GetProxyLogin: String;
begin
  Result := FProxyLogin;
end;

function TfrxTransportHTTP.GetProxyPassword: String;
begin
  Result := FProxyPassword;
end;

function TfrxTransportHTTP.GetProxyPort: Integer;
begin
  Result := FProxyPort;
end;

function TfrxTransportHTTP.GetSocketType: TfrxSocketType;
begin
  Result := fstNonBlocking;
  if Assigned(FClientSocket) then
    case FClientSocket.ClientType of
      ctNonBlocking: Result := fstNonBlocking;
      ctBlocking: Result := fstBlocking;
    end;
end;

function TfrxTransportHTTP.Get(aURL: AnsiString; aSource: TStream): AnsiString;
var
  ReqStream, AnswerStream: TMemoryStream;
begin
  Result := '';
  FHTTPRequest.URL := aURL;
  FHTTPRequest.SourceStream := aSource;
  FHTTPRequest.ReqType := xrtGet;
  FHTTPRequest.Port := FPort;
  FHTTPRequest.BuildRequest;
  AnswerStream := nil;
  ReqStream := TMemoryStream.Create;
  if not Assigned(aSource) then
  begin
    AnswerStream := TMemoryStream.Create;
    aSource := AnswerStream;
  end;
  try
    Open;
    if not FConnected and (Errors.Count > 0) then
      raise Exception.Create(Errors[Errors.Count - 1]);
    if not FConnected then Exit;
    FHTTPRequest.FRequest.SaveToStream(ReqStream);
    Send(ReqStream);
    FRawDataStream.Clear;
    repeat
      Receive(FRawDataStream);
      ParseAnswer(aSource);
    until (Errors.Count = 0) or (FServerFields.AnswerCode <> 100);
    Close;
    if Assigned(AnswerStream) and (AnswerStream.Size > 0) then
    begin
      AnswerStream.Position := 0;
      SetLength(Result, AnswerStream.Size);
      AnswerStream.Read(Result[1], AnswerStream.Size)
    end;
  finally
    if Assigned(AnswerStream) then
      AnswerStream.Free;
    ReqStream.Free;
  end;
end;

function TfrxTransportHTTP.Put(aURL: AnsiString; aSource: TStream = nil): AnsiString;
var
  ReqStream, AnswerStream: TMemoryStream;
begin
  Result := '';
  FHTTPRequest.ReqType := xrtPut;
  FHTTPRequest.URL := aURL;
  FHTTPRequest.Port := FPort;
  FHTTPRequest.SourceStream := aSource;
  FHTTPRequest.BuildRequest;
  ReqStream := TMemoryStream.Create;
  AnswerStream := TMemoryStream.Create;
  try
    Open;
    if not FConnected and (Errors.Count > 0) then
      raise Exception.Create(Errors[Errors.Count - 1]);
    if not FConnected then Exit;
    FHTTPRequest.FRequest.SaveToStream(ReqStream);
    Send(ReqStream);
    if Assigned(aSource) then
      Send(aSource);
    FRawDataStream.Clear;
    if not FConnected then Exit;
    repeat
      Receive(FRawDataStream);
      ParseAnswer(AnswerStream);
    until (Errors.Count = 0) or (FServerFields.AnswerCode <> 100);
    Close;
    if AnswerStream.Size > 0 then
    begin
      AnswerStream.Position := 0;
      SetLength(Result, AnswerStream.Size);
      AnswerStream.Read(Result[1], AnswerStream.Size)
    end;
  finally
    AnswerStream.Free;
    ReqStream.Free;
  end;
end;

function TfrxTransportHTTP.IsAnswerCodeIn(Answers: array of Integer): boolean;
var
  i: Integer;
begin
  Result := True;
  for i := 0 to High(Answers) do
    if FServerFields.AnswerCode = Answers[i] then
      Exit;
  Result := False;
end;

procedure TfrxTransportHTTP.Open;
begin
  Active := True;
end;

procedure TfrxTransportHTTP.ParseAnswer(aToDataStream: TStream);
var
  i, Len: Integer;
  s, s1: AnsiString;
  MICStream: TMemoryStream;
begin
  FAnswer.Clear;
  if FRawDataStream.Size > 0 then
  begin
    FRawDataStream.Position := 0;
    i := StreamSearch(FRawDataStream, 0, #13#10#13#10);
    if i <> 0 then
    begin
      Len := i + 4;
      StreamSize := FRawDataStream.Size - Len;
      SetLength(s, Len);
      FRawDataStream.Position := 0;
      FRawDataStream.ReadBuffer(s[1], Len);
      FAnswer.Text := String(s);

      FServerFields.ParseAnswer(s);

      s1 := AnsiString(GetHTTPErrorText(FServerFields.AnswerCode));
      if s1 <> '' then
        Errors.Add(String(s1));

      if Errors.Count = 0 then
      begin
        if FServerFields.ContentLength > 0 then
          if ((FRawDataStream.Size - Len) <> FServerFields.ContentLength) and
                 IsAnswerCodeIn([200, 206]) then
            Errors.Add('Received data size mismatch');
        if (Length(FServerFields.ContentMD5) > 0) and FMIC and (Errors.Count = 0) then
        begin
          MICStream := TMemoryStream.Create;
          try
            MICStream.CopyFrom(FRawDataStream, FRawDataStream.Size - Len);
            if MD5Stream(MICStream) <> AnsiString(FServerFields.ContentMD5) then
              Errors.Add('Message integrity checksum (MIC) error');
          finally
            FRawDataStream.Position := Len;
            MICStream.Free;
          end;
        end;
        if Assigned(aToDataStream) and (Errors.Count = 0) then
          if Pos('gzip', FServerFields.ContentEncoding) > 0 then
          try
            frxDecompressStream(FRawDataStream, aToDataStream)
          except
            Errors.Add('Unpack data error')
          end
          else
            aToDataStream.CopyFrom(FRawDataStream, FRawDataStream.Size - Len);
      end
      else if Assigned(aToDataStream) then
        aToDataStream.CopyFrom(FRawDataStream, FRawDataStream.Size - Len);
    end
    else
      Errors.Add('Bad header');
    FRawDataStream.Clear;
  end
  else if Errors.Count = 0 then
    Errors.Add('Zero bytes received');
end;

function TfrxTransportHTTP.Post(aURL: WideString; aSource: TStream): WideString;
begin
  Result := WideString(Post(AnsiString(aURL), aSource));
end;

function TfrxTransportHTTP.Post(aURL: AnsiString; aSource: TStream): AnsiString;
var
  ReqStream, AnswerStream: TMemoryStream;
begin
  Result := '';
  FHTTPRequest.ReqType := xrtPost;
  FHTTPRequest.URL := aURL;
  FHTTPRequest.Port := FPort;
  FHTTPRequest.SourceStream := aSource;
  FHTTPRequest.BuildRequest;
  ReqStream := TMemoryStream.Create;
  AnswerStream := TMemoryStream.Create;
  try
    Open;
    if not FConnected and (Errors.Count > 0) then
      raise Exception.Create(Errors[Errors.Count - 1]);
    if not FConnected then Exit;    
    FHTTPRequest.FRequest.SaveToStream(ReqStream);
    Send(ReqStream);
    if Assigned(aSource) then
      Send(aSource);
    FRawDataStream.Clear;
    if not FConnected then Exit;
    repeat
      Receive(FRawDataStream);
      ParseAnswer(AnswerStream);
    until (Errors.Count = 0) or (FServerFields.AnswerCode <> 100);
    Close;
    if AnswerStream.Size > 0 then
    begin
      AnswerStream.Position := 0;
      SetLength(Result, AnswerStream.Size);
      AnswerStream.Read(Result[1], AnswerStream.Size)
    end;
  finally
    AnswerStream.Free;
    ReqStream.Free;
  end;
end;

procedure TfrxTransportHTTP.Receive(aSource: TStream);
var
  bTryRead: Boolean;
  s: String;
  OldSz: Int64;
begin
  if not FConnected then Exit;
  bTryRead := True;
  OldSz := 0;
  if Assigned(OnWorkBegin) then
    OnWorkBegin(Self, hwmRead, 0);
  while bTryRead and FConnected do
  begin
    bTryRead := FIOHandler.Read(aSource);
    if bTryRead and Assigned(OnWork) then
    begin      
      OnWork(Self, hwmRead, aSource.Size - OldSz);
      OldSz := aSource.Size;  
    end;
  end;
  if Assigned(OnWorkEnd) then
    OnWorkEnd(Self, hwmRead, 0);
  s := FIOHandler.GetLastError;
  if s <> '' then
    Errors.Add(s);
end;

procedure TfrxTransportHTTP.Send(aSource: TStream);
var
  bTryWrite: Boolean;
  s: String;
  sPos: Integer;
begin
  if not FConnected then Exit;
  aSource.Position := 0;
  bTryWrite := True;
  if Assigned(OnWorkBegin) then
    OnWorkBegin(Self, hwmWrite, 0);
///  FClientSocket.Socket.Disconnect(FClientSocket.Socket.SocketHandle);
  while (aSource.Position < aSource.Size) and bTryWrite and FConnected do
  begin
    sPos := aSource.Position;
    bTryWrite := FIOHandler.Write(aSource);
    if bTryWrite and Assigned(OnWork) then
      OnWork(Self, hwmWrite, aSource.Size - sPos);
  end;
  s := FIOHandler.GetLastError;
  if Assigned(OnWorkEnd) then
    OnWorkEnd(Self, hwmWrite, 0);
  if s <> '' then
    Errors.Add(s);
end;

procedure TfrxTransportHTTP.SetActive(const Value: Boolean);
begin
  if Value then
    Connect
  else
    Disconnect;
end;

procedure TfrxTransportHTTP.SetDefaultParametersWithToken(AToken: String);
begin
  HTTPRequest.DefAcceptTypes := htcDefaultXML;
  HTTPRequest.ContentType := '';
  HTTPRequest.Authorization := 'Bearer ' + AnsiString(AToken);
end;

procedure TfrxTransportHTTP.SetIOHandler(const Value: TfrxCustomIOHandler);
begin
  if Assigned(FIOHandler) then
    FIOHandler.Free;
  FIOHandler := Value;
end;

procedure TfrxTransportHTTP.SetProxyHost(const Value: String);
begin
  FProxyHost := Value;
end;

procedure TfrxTransportHTTP.SetProxyLogin(const Value: String);
begin
  FProxyLogin := Value;
end;

procedure TfrxTransportHTTP.SetProxyPassword(const Value: String);
begin
  FProxyPassword := Value;
end;

procedure TfrxTransportHTTP.SetProxyPort(const Value: Integer);
begin
  FProxyPort := Value;
end;

procedure TfrxTransportHTTP.SetServerFields(const Value: TfrxHTTPServerFields);
begin
  FServerFields.Assign(Value);
end;

procedure TfrxTransportHTTP.SetSocketDestination;
var
  sPort: AnsiString;
  iPort: integer;
begin
  if FProxyHost <> '' then
  begin
    FClientSocket.Host := FProxyHost;
    FClientSocket.Port := FProxyPort;
  end else
  begin
    FClientSocket.Host := String(FHTTPRequest.Host);
    sPort := FHTTPRequest.GetPort;
    iPort := -1;
    if (sPort <> '') then
      TryStrToInt(String(sPort), iPort);
    if iPort >= 0 then
      FClientSocket.Port := iPort
    else
      FClientSocket.Port := FPort;
  end;
  FClientSocket.Address := FClientSocket.Host;
end;

procedure TfrxTransportHTTP.SetSocketType(const Value: TfrxSocketType);
begin
  if Assigned(FClientSocket) then
    case Value of
      fstNonBlocking: FClientSocket.ClientType := ctNonBlocking;
      fstBlocking: FClientSocket.ClientType := ctBlocking;
    end;
end;

procedure TfrxTransportHTTP.StartListening;
begin
  // TODO: Listening mode
end;


{ TfrxHTTPRequest }

constructor TfrxHTTPRequest.Create;
begin
  inherited;
  FRequest := TStringList.Create;
  FCustomHeader := TStringList.Create;
  FSourceStream := nil;
  FUserAgent := 'Mozilla/3.0 (compatible; FastReport-Transport)';
  FEncoding := 'identity';
end;

destructor TfrxHTTPRequest.Destroy;
begin
  FreeAndNil(FRequest);
  FreeAndNil(FCustomHeader);
  inherited;
end;

function TfrxHTTPRequest.GetText: AnsiString;
begin
  SureEmptyLineAtEnd;
  Result := AnsiString(FRequest.Text);
end;

function TfrxHTTPRequest.Host(bTruncPort: Boolean = True): AnsiString;
var
  Slash: Integer;
begin
  if PosEx(HTTP_LINK_PREFIX, URL, 1) = 1 then
    Result := copy(URL, 8, Length(URL) - 7)
  else if PosEx(HTTPS_LINK_PREFIX, URL, 1) = 1 then
    Result := copy(URL, 9, Length(URL) - 8)
  else if URL[1] = '/' then
    Result := copy(URL, 2, Length(URL) - 1);

  Slash := PosEx(AnsiString('/'), Result, 1);
  if Slash <> 0 then
    Result := copy(Result, 1, Slash - 1);
  { check port }
  if not bTruncPort then Exit;
  Slash := PosEx(AnsiString(':'), Result, 1);
  if Slash <> 0 then
    Result := copy(Result, 1, Slash - 1);
end;

function TfrxHTTPRequest.IsValidAddress: Boolean;
begin
  Result := (PosEx(HTTP_LINK_PREFIX, FURL, 1) = 1) or
            (PosEx(HTTPS_LINK_PREFIX, FURL, 1) = 1);
end;

function TfrxHTTPRequest.GetPort: AnsiString;
var
  Index: Integer;
begin
  Result := Host(False);
  Index := PosEx(AnsiString(':'), Result, 1);
  if Index <> 0 then
    Result := Copy(Result, Index + 1, Length(Result) - Index)
  else if (PosEx(HTTP_LINK_PREFIX, FURL, 1) = 1) then
    Result := '80'
  else if (PosEx(HTTPS_LINK_PREFIX, FURL, 1) = 1) then
        Result := '443'
  else if FPort <> 0 then
    Result := AnsiString(IntToStr(FPort))
  else
    Result := '';
end;

procedure TfrxHTTPRequest.Redirect(const NewAddress: AnsiString);
begin
  FURL := NewAddress;
end;

procedure TfrxHTTPRequest.SetText(const Value: AnsiString);
begin
  FRequest.Text := String(Value);
end;

procedure TfrxHTTPRequest.SureEmptyLineAtEnd;
begin
  if (FRequest.Count > 0) and (FRequest[FRequest.Count - 1] <> '') then
    FRequest.Add('');
end;

procedure TfrxHTTPRequest.BuildRequest;
var
  ReqTyp, aHost, aPath, TempS: AnsiString;
  len: Integer;
  i: Integer;
begin
  aPath := '';
  FRequest.Clear;
  ReqTyp := HTTP_POST;
  aHost := Host;
  len := Pos(aHost, URL) + Length(aHost);
  len := PosEx(AnsiString('/'), URL, len);
  if len > 0 then
    aPath := Copy(URL, len, Length(URL) - len + 1);
  case ReqType of
    xrtPost: ReqTyp := HTTP_POST;
    xrtGet: ReqTyp := HTTP_GET;
    xrtDelete: ReqTyp := HTTP_DELETE;
    xrtPut: ReqTyp := HTTP_PUT;
  end;
  if aPath = '' then
    aPath := '/'; // root

  FRequest.Add(String(ReqTyp) + ' ' + String(aPath) + ' ' + HTTP_VER1);

  if ContentType <> '' then
    FRequest.Add('Content-Type: ' + String(ContentType));

  len := 0;
  if Assigned(SourceStream) then
    len := SourceStream.Size;
  if len > 0 then
    FRequest.Add('Content-Length: ' + IntToStr(len));
  if Authorization <> '' then
    FRequest.Add('Authorization: ' + String(Authorization));
  FRequest.Add('Host: ' + String(aHost));
  { toDo something better }
  TempS := '';
  case DefAcceptTypes of
    htcNone: ;
    hctDefaultHTML: TempS := 'text/html,application/xhtml+xml,application/xml;q=0.9';
    htcDefaultXML: TempS := 'text/html,application/xhtml+xml,application/xml;q=0.9' ;
    htcDefaultApp: TempS := 'application/octet-stream' ;
  end;
  TempS := TempS + AcceptTypes;
  if TempS <> '' then
    TempS := TempS + ',';
  TempS := TempS + '*/*;q=0.8';
  if TempS <> '' then
    FRequest.Add('Accept: ' + String(TempS));

  if Encoding <> '' then
    FRequest.Add('Accept-Encoding: ' + String(Encoding));
  for i := 0 to FCustomHeader.Count - 1 do
    FRequest.Add(FCustomHeader[i]);
  if UserAgent <> '' then
    FRequest.Add('User-Agent: ' + String(UserAgent));
  FRequest.Add('');
end;

initialization
  msc := GetExceptionMask;

end.