path: root/fpcsrc/packages/fcl-web/src/base/fphttpclient.pp

{
    This file is part of the Free Pascal run time library.
    Copyright (c) 2011 by the Free Pascal development team

    HTTP client component.

    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 fphttpclient;

{ ---------------------------------------------------------------------
  Todo:
  * Proxy support ?
  * Https support.
  ---------------------------------------------------------------------}

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, ssockets, httpdefs, uriparser, base64;

Const
  ReadBufLen = 4096;

Type
  { TFPCustomHTTPClient }
  TFPCustomHTTPClient = Class(TComponent)
  private
    FCookies: TStrings;
    FHTTPVersion: String;
    FRequestBody: TStream;
    FRequestHeaders: TStrings;
    FResponseHeaders: TStrings;
    FResponseStatusCode: Integer;
    FResponseStatusText: String;
    FServerHTTPVersion: String;
    FSocket : TInetSocket;
    FBuffer : Ansistring;
    function CheckContentLength: Integer;
    function CheckTransferEncoding: string;
    function GetCookies: TStrings;
    procedure SetCookies(const AValue: TStrings);
    procedure SetRequestHeaders(const AValue: TStrings);
  protected
    // Parse response status line. Saves status text and protocol, returns numerical code. Exception if invalid line.
    Function ParseStatusLine(AStatusLine : String) : Integer;
    // Construct server URL for use in request line.
    function GetServerURL(URI: TURI): String;
    // Read 1 line of response. Fills FBuffer
    function ReadString: String;
    // Check if response code is in AllowedResponseCodes. if not, an exception is raised.
    function CheckResponseCode(ACode: Integer;  const AllowedResponseCodes: array of Integer): Boolean; virtual;
    // Read response from server, and write any document to Stream.
    procedure ReadResponse(Stream: TStream;  const AllowedResponseCodes: array of Integer; HeadersOnly: Boolean = False); virtual;
    // Read server response line and headers. Returns status code.
    Function ReadResponseHeaders : integer; virtual;
    // Allow header in request ? (currently checks only if non-empty and contains : token)
    function AllowHeader(var AHeader: String): Boolean; virtual;
    // Connect to the server. Must initialize FSocket.
    procedure ConnectToServer(const AHost: String; APort: Integer); virtual;
    // Disconnect from server. Must free FSocket.
    procedure DisconnectFromServer; virtual;
    // Run method AMethod, using request URL AURL. Write Response to Stream, and headers in ResponseHeaders.
    // If non-empty, AllowedResponseCodes contains an array of response codes considered valid responses.
    Procedure DoMethod(Const AMethod,AURL : String; Stream : TStream; Const AllowedResponseCodes : Array of Integer); virtual;
    // Send request to server: construct request line and send headers and request body.
    procedure SendRequest(const AMethod: String; URI: TURI); virtual;
  Public
    Constructor Create(AOwner: TComponent); override;
    Destructor Destroy; override;
    // Request Header management
    // Return index of header, -1 if not present.
    Function IndexOfHeader(Const AHeader : String) : Integer;
    // Add header, replacing an existing one if it exists.
    Procedure AddHeader(Const AHeader,AValue : String);
    // Return header value, empty if not present.
    Function GetHeader(Const AHeader : String) : String;
    // General-purpose call.
    Procedure HTTPMethod(Const AMethod,AURL : String; Stream : TStream; Const AllowedResponseCodes : Array of Integer); virtual;
    // Execute GET on server, store result in Stream, File, StringList or string
    Procedure Get(Const AURL : String; Stream : TStream);
    Procedure Get(Const AURL : String; const LocalFileName : String);
    Procedure Get(Const AURL : String; Response : TStrings);
    Function Get(Const AURL : String) : String;
    // Simple class methods
    Class Procedure SimpleGet(Const AURL : String; Stream : TStream);
    Class Procedure SimpleGet(Const AURL : String; const LocalFileName : String);
    Class Procedure SimpleGet(Const AURL : String; Response : TStrings);
    Class Function SimpleGet(Const AURL : String) : String;
    // Simple post
    // Post URL, and Requestbody. Return response in Stream, File, TstringList or String;
    procedure Post(const URL: string; const Response: TStream);
    procedure Post(const URL: string; Response : TStrings);
    procedure Post(const URL: string; const LocalFileName: String);
    function Post(const URL: string) : String;
    // Simple class methods.
    Class procedure SimplePost(const URL: string; const Response: TStream);
    Class procedure SimplePost(const URL: string; Response : TStrings);
    Class procedure SimplePost(const URL: string; const LocalFileName: String);
    Class function SimplePost(const URL: string) : String;
    // Simple Put
    // Put URL, and Requestbody. Return response in Stream, File, TstringList or String;
    procedure Put(const URL: string; const Response: TStream);
    procedure Put(const URL: string; Response : TStrings);
    procedure Put(const URL: string; const LocalFileName: String);
    function Put(const URL: string) : String;
    // Simple class methods.
    Class procedure SimplePut(const URL: string; const Response: TStream);
    Class procedure SimplePut(const URL: string; Response : TStrings);
    Class procedure SimplePut(const URL: string; const LocalFileName: String);
    Class function SimplePut(const URL: string) : String;
    // Simple Delete
    // Delete URL, and Requestbody. Return response in Stream, File, TstringList or String;
    procedure Delete(const URL: string; const Response: TStream);
    procedure Delete(const URL: string; Response : TStrings);
    procedure Delete(const URL: string; const LocalFileName: String);
    function Delete(const URL: string) : String;
    // Simple class methods.
    Class procedure SimpleDelete(const URL: string; const Response: TStream);
    Class procedure SimpleDelete(const URL: string; Response : TStrings);
    Class procedure SimpleDelete(const URL: string; const LocalFileName: String);
    Class function SimpleDelete(const URL: string) : String;
    // Simple Options
    // Options from URL, and Requestbody. Return response in Stream, File, TstringList or String;
    procedure Options(const URL: string; const Response: TStream);
    procedure Options(const URL: string; Response : TStrings);
    procedure Options(const URL: string; const LocalFileName: String);
    function Options(const URL: string) : String;
    // Simple class methods.
    Class procedure SimpleOptions(const URL: string; const Response: TStream);
    Class procedure SimpleOptions(const URL: string; Response : TStrings);
    Class procedure SimpleOptions(const URL: string; const LocalFileName: String);
    Class function SimpleOptions(const URL: string) : String;
    // Get HEAD
    Class Procedure Head(AURL : String; Headers: TStrings);
    // Post Form data (www-urlencoded).
    // Formdata in string (urlencoded) or TStrings (plain text) format.
    // Form data will be inserted in the requestbody.
    // Return response in Stream, File, TStringList or String;
    Procedure FormPost(const URL, FormData: string; const Response: TStream);
    Procedure FormPost(const URL : string; FormData:  TStrings; const Response: TStream);
    Procedure FormPost(const URL, FormData: string; const Response: TStrings);
    Procedure FormPost(const URL : string; FormData:  TStrings; const Response: TStrings);
    function FormPost(const URL, FormData: string): String;
    function FormPost(const URL: string; FormData : TStrings): String;
    // Simple form 
    Class Procedure SimpleFormPost(const URL, FormData: string; const Response: TStream);
    Class Procedure SimpleFormPost(const URL : string; FormData:  TStrings; const Response: TStream);
    Class Procedure SimpleFormPost(const URL, FormData: string; const Response: TStrings);
    Class Procedure SimpleFormPost(const URL : string; FormData:  TStrings; const Response: TStrings);
    Class function SimpleFormPost(const URL, FormData: string): String;
    Class function SimpleFormPost(const URL: string; FormData : TStrings): String;
    // Post a file
    Procedure FileFormPost(const AURL, AFieldName, AFileName: string; const Response: TStream);
    // Simple form of Posting a file
    Class Procedure SimpleFileFormPost(const AURL, AFieldName, AFileName: string; const Response: TStream);
  Protected
    // Before request properties.
    // Additional headers for request. Host; and Authentication are automatically added.
    Property RequestHeaders : TStrings Read FRequestHeaders Write SetRequestHeaders;
    // Cookies. Set before request to send cookies to server.
    // After request the property is filled with the cookies sent by the server.
    Property Cookies : TStrings Read GetCookies Write SetCookies;
    // Optional body to send (mainly in POST request)
    Property RequestBody : TStream read FRequestBody Write FRequestBody;
    // used HTTP version when constructing the request.
    Property HTTPversion : String Read FHTTPVersion Write FHTTPVersion;
    // After request properties.
    // After request, this contains the headers sent by server.
    Property ResponseHeaders : TStrings Read FResponseHeaders;
    // After request, HTTP version of server reply.
    Property ServerHTTPVersion : String Read FServerHTTPVersion;
    // After request, HTTP response status of the server.
    Property ResponseStatusCode : Integer Read FResponseStatusCode;
    // After request, HTTP response status text of the server.
    Property ResponseStatusText : String Read FResponseStatusText;
  end;

  TFPHTTPClient = Class(TFPCustomHTTPClient)
  Public
    Property RequestHeaders;
    Property RequestBody;
    Property ResponseHeaders;
    Property HTTPversion;
    Property ServerHTTPVersion;
    Property ResponseStatusCode;
    Property ResponseStatusText;
    Property Cookies;
  end;
  EHTTPClient = Class(Exception);

Function EncodeURLElement(S : String) : String;
Function DecodeURLElement(Const S : String) : String;

implementation

resourcestring
  SErrInvalidProtocol = 'Invalid protocol : "%s"';
  SErrReadingSocket = 'Error reading data from socket';
  SErrInvalidProtocolVersion = 'Invalid protocol version in response: "%s"';
  SErrInvalidStatusCode = 'Invalid response status code: %s';
  SErrUnexpectedResponse = 'Unexpected response status code: %d';
  SErrChunkTooBig = 'Chunk too big';
  SErrChunkLineEndMissing = 'Chunk line end missing';

Const
  CRLF = #13#10;

function EncodeURLElement(S: String): String;

Const
  NotAllowed = [ ';', '/', '?', ':', '@', '=', '&', '#', '+', '_', '<', '>',
                 '"', '%', '{', '}', '|', '\', '^', '~', '[', ']', '`' ];

var
  i, o, l : Integer;
  h: string[2];
  P : PChar;
  c: AnsiChar;
begin
  l:=Length(S);
  If (l=0) then Exit;
  SetLength(Result,l*3);
  P:=Pchar(Result);
  for I:=1 to L do
    begin
    C:=S[i];
    O:=Ord(c);
    if (O<=$20) or (O>=$7F) or (c in NotAllowed) then
      begin
      P^ := '%';
      Inc(P);
      h := IntToHex(Ord(c), 2);
      p^ := h[1];
      Inc(P);
      p^ := h[2];
      Inc(P);
      end
    else
      begin
      P^ := c;
      Inc(p);
      end;
    end;
  SetLength(Result,P-PChar(Result));
end;

function DecodeURLElement(Const S: AnsiString): AnsiString;

var
  i,l,o : Integer;
  c: AnsiChar;
  p : pchar;
  h : string;

begin
  l := Length(S);
  if l=0 then exit;
  SetLength(Result, l);
  P:=PChar(Result);
  i:=1;
  While (I<=L) do
    begin
    c := S[i];
    if (c<>'%') then
      begin
      P^:=c;
      Inc(P);
      end
    else if (I<L-1) then
      begin
      H:='$'+Copy(S,I+1,2);
      o:=StrToIntDef(H,-1);
      If (O>=0) and (O<=255) then
        begin
        P^:=char(O);
        Inc(P);
        Inc(I,2);
        end;
      end;
    Inc(i);
  end;
  SetLength(Result, P-Pchar(Result));
end;

{ TFPCustomHTTPClient }

procedure TFPCustomHTTPClient.SetRequestHeaders(const AValue: TStrings);
begin
  if FRequestHeaders=AValue then exit;
  FRequestHeaders.Assign(AValue);
end;

function TFPCustomHTTPClient.IndexOfHeader(const AHeader: String): Integer;
Var
  L : Integer;
  H : String;
begin
  H:=LowerCase(Aheader);
  l:=Length(AHeader);
  Result:=Requestheaders.Count-1;
  While (Result>=0) and ((LowerCase(Copy(RequestHeaders[Result],1,l)))<>h) do
    Dec(Result);
end;

procedure TFPCustomHTTPClient.AddHeader(const AHeader, AValue: String);

Var
  J: Integer;
begin
  j:=IndexOfHeader(Aheader);
  if (J<>-1) then
    RequestHeaders.Delete(j);
  RequestHeaders.Add(AHeader+': '+Avalue);
end;

function TFPCustomHTTPClient.GetHeader(const AHeader: String): String;

Var
  I : Integer;

begin
  I:=indexOfHeader(AHeader);
  Result:=RequestHeaders[i];
  I:=Pos(':',Result);
  if (I=0) then
    I:=Length(Result);
  System.Delete(Result,1,I);
end;

Function TFPCustomHTTPClient.GetServerURL(URI : TURI) : String;

Var
  D : String;

begin
  D:=URI.Path;
  If Length(D) = 0 then
    D := '/'
  else  If (D[1]<>'/') then
    D:='/'+D;
  If (D[Length(D)]<>'/') then
    D:=D+'/';
  Result:=D+URI.Document;
  if (URI.Params<>'') then
    Result:=Result+'?'+URI.Params;
end;

procedure TFPCustomHTTPClient.ConnectToServer(Const AHost : String; APort : Integer);

begin
  if Aport=0 then
    Aport:=80;
  FSocket:=TInetSocket.Create(AHost,APort);
end;

procedure TFPCustomHTTPClient.DisconnectFromServer;

begin
  FreeAndNil(FSocket);
end;

function TFPCustomHTTPClient.AllowHeader(Var AHeader : String) : Boolean;

begin
  Result:=(AHeader<>'') and (Pos(':',AHeader)<>0);
end;

procedure TFPCustomHTTPClient.SendRequest(Const AMethod : String; URI : TURI);

Var
  S,L : String;
  I : Integer;

begin
  S:=Uppercase(AMethod)+' '+GetServerURL(URI)+' '+'HTTP/'+FHTTPVersion+CRLF;
  If (URI.Username<>'') then
    S:=S+'Authorization: Basic ' + EncodeStringBase64(URI.UserName+ ':' + URI.Password)+CRLF;
  S:=S+'Host: '+URI.Host;
  If (URI.Port<>0) then
    S:=S+':'+IntToStr(URI.Port);
  S:=S+CRLF;
  If Assigned(RequestBody) and (IndexOfHeader('Content-Length')=-1) then
    AddHeader('Content-Length',IntToStr(RequestBody.Size));
  For I:=0 to FRequestHeaders.Count-1 do
    begin
    l:=FRequestHeaders[i];
    If AllowHeader(L) then
      S:=S+L+CRLF;
    end;
  if Assigned(FCookies) then
    begin
    L:='Cookie:';
    For I:=0 to FCookies.Count-1 do
      begin
      If (I>0) then
        L:=L+'; ';
      L:=L+FCookies[i];
      end;
    if AllowHeader(L) then
      S:=S+L+CRLF;
    end;
  S:=S+CRLF;
  FSocket.WriteBuffer(S[1],Length(S));
  If Assigned(FRequestBody) then
    FSocket.CopyFrom(FRequestBody,FRequestBody.Size);
end;

function TFPCustomHTTPClient.ReadString : String;

  Procedure FillBuffer;

  Var
    R : Integer;

  begin
    SetLength(FBuffer,ReadBufLen);
    r:=FSocket.Read(FBuffer[1],ReadBufLen);
    If r<0 then
      Raise EHTTPClient.Create(SErrReadingSocket);
    if (r<ReadBuflen) then
      SetLength(FBuffer,r);
  end;

Var
  CheckLF,Done : Boolean;
  P,L : integer;

begin
  Result:='';
  Done:=False;
  CheckLF:=False;
  Repeat
    if Length(FBuffer)=0 then
      FillBuffer;
    if Length(FBuffer)=0 then
      Done:=True
    else if CheckLF then
      begin
      If (FBuffer[1]<>#10) then
        Result:=Result+#13
      else
        begin
        System.Delete(FBuffer,1,1);
        Done:=True;
        end;
      end;
    if not Done then
      begin
      P:=Pos(#13#10,FBuffer);
      If P=0 then
        begin
        L:=Length(FBuffer);
        CheckLF:=FBuffer[L]=#13;
        if CheckLF then
          Result:=Result+Copy(FBuffer,1,L-1)
        else
          Result:=Result+FBuffer;
        FBuffer:='';
        end
      else
        begin
        Result:=Result+Copy(FBuffer,1,P-1);
        System.Delete(FBuffer,1,P+1);
        Done:=True;
        end;
      end;
  until Done;
end;
Function GetNextWord(Var S : String) : string;

Const
  WhiteSpace = [' ',#9];

Var
  P : Integer;

begin
  While (Length(S)>0) and (S[1] in WhiteSpace) do
    Delete(S,1,1);
  P:=Pos(' ',S);
  If (P=0) then
   P:=Pos(#9,S);
  If (P=0) then
    P:=Length(S)+1;
  Result:=Copy(S,1,P-1);
  Delete(S,1,P);
end;

Function TFPCustomHTTPClient.ParseStatusLine(AStatusLine : String) : Integer;

Var
  S : String;

begin
  S:=Uppercase(GetNextWord(AStatusLine));
  If (Copy(S,1,5)<>'HTTP/') then
    Raise EHTTPClient.CreateFmt(SErrInvalidProtocolVersion,[S]);
  System.Delete(S,1,5);
  FServerHTTPVersion:=S;
  S:=GetNextWord(AStatusLine);
  Result:=StrToIntDef(S,-1);
  if Result=-1 then
   Raise EHTTPClient.CreateFmt(SErrInvalidStatusCode,[S]);
  FResponseStatusText:=AStatusLine;
end;

Function TFPCustomHTTPClient.ReadResponseHeaders : Integer;

  Procedure DoCookies(S : String);

  Var
    P : Integer;
    C : String;

  begin
    If Assigned(FCookies) then
      FCookies.Clear;
    P:=Pos(':',S);
    System.Delete(S,1,P);
    Repeat
      P:=Pos(';',S);
      If (P=0) then
        P:=Length(S)+1;
      C:=Trim(Copy(S,1,P-1));
      Cookies.Add(C);
      System.Delete(S,1,P);
    Until (S='');
  end;

Const
  SetCookie = 'set-cookie';

Var
  StatusLine,S : String;

begin
  StatusLine:=ReadString;
  Result:=ParseStatusLine(StatusLine);
  Repeat
    S:=ReadString;
    if (S<>'') then
      begin
      ResponseHeaders.Add(S);
      If (LowerCase(Copy(S,1,Length(SetCookie)))=SetCookie) then
        DoCookies(S);
      end
  Until (S='');
end;

Function TFPCustomHTTPClient.CheckResponseCode(ACode : Integer; Const AllowedResponseCodes : Array of Integer) : Boolean;

Var
  I : Integer;

begin
  Result:=(High(AllowedResponseCodes)=-1);
  if not Result then
    begin
    I:=Low(AllowedResponseCodes);
    While (Not Result) and (I<=High(AllowedResponseCodes)) do
      begin
      Result:=(AllowedResponseCodes[i]=ACode);
      Inc(I);
      end
    end;
end;

Function TFPCustomHTTPClient.CheckContentLength: Integer;

Const CL ='content-length:';

Var
  S : String;
  I : integer;

begin
  Result:=-1;
  I:=0;
  While (Result=-1) and (I<FResponseHeaders.Count) do
    begin
    S:=Trim(LowerCase(FResponseHeaders[i]));
    If (Copy(S,1,Length(Cl))=Cl) then
      begin
      System.Delete(S,1,Length(CL));
      Result:=StrToIntDef(Trim(S),-1);
      end;
    Inc(I);
    end;
end;

Function TFPCustomHTTPClient.CheckTransferEncoding: string;

Const CL ='transfer-encoding:';

Var
  S : String;
  I : integer;

begin
  Result:='';
  I:=0;
  While (I<FResponseHeaders.Count) do
    begin
    S:=Trim(LowerCase(FResponseHeaders[i]));
    If (Copy(S,1,Length(Cl))=Cl) then
      begin
      System.Delete(S,1,Length(CL));
      Result:=Trim(S);
      exit;
      end;
    Inc(I);
    end;
end;

function TFPCustomHTTPClient.GetCookies: TStrings;
begin
  If (FCookies=Nil) then
    FCookies:=TStringList.Create;
  Result:=FCookies;
end;

procedure TFPCustomHTTPClient.SetCookies(const AValue: TStrings);
begin
  if GetCookies=AValue then exit;
  GetCookies.Assign(AValue);
end;

procedure TFPCustomHTTPClient.ReadResponse(Stream: TStream; Const AllowedResponseCodes : Array of Integer; HeadersOnly: Boolean = False);

  Function Transfer(LB : Integer) : Integer;

  begin
    Result:=FSocket.Read(FBuffer[1],LB);
    If Result<0 then
      Raise EHTTPClient.Create(SErrReadingSocket);
    if (Result>0) then
      Stream.Write(FBuffer[1],Result);
  end;

  Procedure ReadChunkedResponse;
  { HTTP 1.1 chunked response:
    There is no content-length. The response consists of several chunks of
    data, each
    - beginning with a line
      - starting with a hex number DataSize,
      - an optional parameter,
      - ending with #13#10,
    - followed by the data,
    - ending with #13#10 (not in DataSize),
    It ends when the DataSize is 0.
    After the last chunk there can be a some optional entity header fields.
    This trailer is not yet implemented. }
  var
    BufPos: Integer;

    function FetchData(out Cnt: integer): boolean;

    begin
      SetLength(FBuffer,ReadBuflen);
      Cnt:=FSocket.Read(FBuffer[1],length(FBuffer));
      If Cnt<0 then
        Raise EHTTPClient.Create(SErrReadingSocket);
      SetLength(FBuffer,Cnt);
      BufPos:=1;
      Result:=Cnt>0;
    end;

    Function ReadData(Data: PByte; Cnt: integer): integer;

    var
      l: Integer;
    begin
      Result:=0;
      while Cnt>0 do
        begin
        l:=length(FBuffer)-BufPos+1;
        if l=0 then
          if not FetchData(l) then
            exit; // end of stream
        if l>Cnt then
          l:=Cnt;
        System.Move(FBuffer[BufPos],Data^,l);
        inc(BufPos,l);
        inc(Data,l);
        inc(Result,l);
        dec(Cnt,l);
      end;
    end;

  var
    c: char;
    ChunkSize: Integer;
    l: Integer;
  begin
    BufPos:=1;
    repeat
      // read ChunkSize
      ChunkSize:=0;
      repeat
        if ReadData(@c,1)<1 then exit;
        case c of
        '0'..'9': ChunkSize:=ChunkSize*16+ord(c)-ord('0');
        'a'..'f': ChunkSize:=ChunkSize*16+ord(c)-ord('a')+10;
        'A'..'F': ChunkSize:=ChunkSize*16+ord(c)-ord('A')+10;
        else break;
        end;
        if ChunkSize>1000000 then
          Raise EHTTPClient.Create(SErrChunkTooBig);
      until false;
      // read till line end
      while (c<>#10) do
        if ReadData(@c,1)<1 then exit;
      if ChunkSize=0 then exit;
      // read data
      repeat
        l:=length(FBuffer)-BufPos+1;
        if l=0 then
          if not FetchData(l) then
            exit; // end of stream
        if l>ChunkSize then
          l:=ChunkSize;
        if l>0 then
          begin
          // copy chunk data to output
          Stream.Write(FBuffer[BufPos],l);
          inc(BufPos,l);
          dec(ChunkSize,l);
          end;
      until ChunkSize=0;
      // read #13#10
      if ReadData(@c,1)<1 then exit;
      if c<>#13 then
        Raise EHTTPClient.Create(SErrChunkLineEndMissing);
      if ReadData(@c,1)<1 then exit;
      if c<>#10 then
        Raise EHTTPClient.Create(SErrChunkLineEndMissing);
      // next chunk
    until false;
  end;

Var
  L,LB,R : Integer;
begin
  SetLength(FBuffer,0);
  FResponseStatusCode:=ReadResponseHeaders;
  if not CheckResponseCode(FResponseStatusCode,AllowedResponseCodes) then
    Raise EHTTPClient.CreateFmt(SErrUnexpectedResponse,[ResponseStatusCode]);
  if HeadersOnly then
    exit;
  if CompareText(CheckTransferEncoding,'chunked')=0 then
    ReadChunkedResponse
  else
    begin
    // Write remains of buffer to output.
    LB:=Length(FBuffer);
    If (LB>0) then
      Stream.WriteBuffer(FBuffer[1],LB);
    // Now read the rest, if any.
    SetLength(FBuffer,ReadBuflen);
    L:=CheckContentLength;
    If (L>LB) then
      begin
      // We cannot use copyfrom, it uses ReadBuffer, and this is dangerous with sockets
      L:=L-LB;
      Repeat
        LB:=ReadBufLen;
        If (LB>L) then
          LB:=L;
        R:=Transfer(LB);
        L:=L-R;
      until (L=0) or (R=0);
      end
    else if L<0 then
      begin
      // No content-length, so we read till no more data available.
      Repeat
        R:=Transfer(ReadBufLen);
      until (R=0);
      end;
    end;
end;

procedure TFPCustomHTTPClient.DoMethod(Const AMethod,AURL: String; Stream: TStream; Const AllowedResponseCodes : Array of Integer);

Var
  URI : TURI;

begin
  FResponseHeaders.Clear;
  URI:=ParseURI(AURL,False);
  If (Lowercase(URI.Protocol)<>'http') then
   Raise EHTTPClient.CreateFmt(SErrInvalidProtocol,[URI.Protocol]);
  ConnectToServer(URI.Host,URI.Port);
  try
    SendRequest(AMethod,URI);
    ReadResponse(Stream,AllowedResponseCodes,CompareText(AMethod,'HEAD')=0);
  finally
    DisconnectFromServer;
  end;
end;

constructor TFPCustomHTTPClient.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FRequestHeaders:=TStringList.Create;
  FResponseHeaders:=TStringList.Create;
  FHTTPVersion:='1.1';
end;

destructor TFPCustomHTTPClient.Destroy;
begin
  FreeAndNil(FCookies);
  FreeAndNil(FRequestHeaders);
  FreeAndNil(FResponseHeaders);
  inherited Destroy;
end;

procedure TFPCustomHTTPClient.HTTPMethod(const AMethod, AURL: String;
  Stream: TStream; const AllowedResponseCodes: array of Integer);
begin
  DoMethod(AMethod,AURL,Stream,AllowedResponseCodes);
end;

procedure TFPCustomHTTPClient.Get(Const AURL: String; Stream: TStream);
begin
  DoMethod('GET',AURL,Stream,[200]);
end;

procedure TFPCustomHTTPClient.Get(Const AURL: String; const LocalFileName: String);

Var
  F : TFileStream;

begin
  F:=TFileStream.Create(LocalFileName,fmCreate);
  try
    Get(AURL,F);
  finally
    F.Free;
  end;
end;

procedure TFPCustomHTTPClient.Get(const AURL: String; Response: TStrings);
begin
  Response.Text:=Get(AURL);
end;

function TFPCustomHTTPClient.Get(Const AURL: String): String;

Var
  SS : TStringStream;

begin
  SS:=TStringStream.Create('');
  try
    Get(AURL,SS);
    Result:=SS.Datastring;
  finally
    SS.Free;
  end;
end;


Class Procedure TFPCustomHTTPClient.SimpleGet(Const AURL : String; Stream : TStream);

begin
  With Self.Create(nil) do
    try
      RequestHeaders.Add('Connection: Close');
      Get(AURL,Stream);
    finally
      Free;
    end;
end;


Class Procedure TFPCustomHTTPClient.SimpleGet(Const AURL : String; const LocalFileName : String);

begin
  With Self.Create(nil) do
    try
      RequestHeaders.Add('Connection: Close');
      Get(AURL,LocalFileName);
    finally
      Free;
    end;
end;


Class Procedure TFPCustomHTTPClient.SimpleGet(Const AURL : String; Response : TStrings);

begin
  With Self.Create(nil) do
    try
      RequestHeaders.Add('Connection: Close');
      Get(AURL,Response);
    finally
      Free;
    end;
end;


Class Function TFPCustomHTTPClient.SimpleGet(Const AURL : String) : String;
 
begin
  With Self.Create(nil) do
    try
      Result:=Get(AURL);
    finally
      Free;
    end;
end;


procedure TFPCustomHTTPClient.Post(const URL: string; const Response: TStream);
begin
  DoMethod('POST',URL,Response,[]);
end;


procedure TFPCustomHTTPClient.Post(const URL: string; Response: TStrings);
begin
  Response.Text:=Post(URL);
end;


procedure TFPCustomHTTPClient.Post(const URL: string;
  const LocalFileName: String);

Var
  F : TFileStream;

begin
  F:=TFileStream.Create(LocalFileName,fmCreate);
  try
    Post(URL,F);
  finally
    F.Free;
  end;
end;


function TFPCustomHTTPClient.Post(const URL: string): String;
Var
  SS : TStringStream;
begin
  SS:=TStringStream.Create('');
  try
    Post(URL,SS);
    Result:=SS.Datastring;
  finally
    SS.Free;
  end;
end;


Class procedure TFPCustomHTTPClient.SimplePost(const URL: string; const Response: TStream);

begin
  With Self.Create(nil) do
    try
      RequestHeaders.Add('Connection: Close');
      Post(URL,Response);
    finally
      Free;
    end;
end;


Class procedure TFPCustomHTTPClient.SimplePost(const URL: string; Response : TStrings);

begin
  With Self.Create(nil) do
    try
      RequestHeaders.Add('Connection: Close');
      Post(URL,Response);
    finally
      Free;
    end;
end;


Class procedure TFPCustomHTTPClient.SimplePost(const URL: string; const LocalFileName: String);

begin
  With Self.Create(nil) do
    try
      RequestHeaders.Add('Connection: Close');
      Post(URL,LocalFileName);
    finally
      Free;
    end;
end;


Class function TFPCustomHTTPClient.SimplePost(const URL: string) : String;

begin
  With Self.Create(nil) do
    try
      RequestHeaders.Add('Connection: Close');
      Result:=Post(URL);
    finally
      Free;
    end;
end;

procedure TFPCustomHTTPClient.Put(const URL: string; const Response: TStream);
begin
  DoMethod('PUT',URL,Response,[]);
end;

procedure TFPCustomHTTPClient.Put(const URL: string; Response: TStrings);
begin
  Response.Text:=Put(URL);
end;

procedure TFPCustomHTTPClient.Put(const URL: string;
  const LocalFileName: String);

Var
  F : TFileStream;

begin
  F:=TFileStream.Create(LocalFileName,fmCreate);
  try
    Put(URL,F);
  finally
    F.Free;
  end;
end;

function TFPCustomHTTPClient.Put(const URL: string): String;
Var
  SS : TStringStream;
begin
  SS:=TStringStream.Create('');
  try
    Put(URL,SS);
    Result:=SS.Datastring;
  finally
    SS.Free;
  end;
end;

Class procedure TFPCustomHTTPClient.SimplePut(const URL: string;
  const Response: TStream);

begin
  With Self.Create(nil) do
    try
      RequestHeaders.Add('Connection: Close');
      Put(URL,Response);
    finally
      Free;
    end;
end;

Class procedure TFPCustomHTTPClient.SimplePut(const URL: string;
  Response: TStrings);

begin
  With Self.Create(nil) do
    try
      RequestHeaders.Add('Connection: Close');
      Put(URL,Response);
    finally
      Free;
    end;
end;

Class procedure TFPCustomHTTPClient.SimplePut(const URL: string;
  const LocalFileName: String);

begin
  With Self.Create(nil) do
    try
      RequestHeaders.Add('Connection: Close');
      Put(URL,LocalFileName);
    finally
      Free;
    end;
end;

Class function TFPCustomHTTPClient.SimplePut(const URL: string): String;

begin
  With Self.Create(nil) do
    try
      RequestHeaders.Add('Connection: Close');
      Result:=Put(URL);
    finally
      Free;
    end;
end;

procedure TFPCustomHTTPClient.Delete(const URL: string; const Response: TStream);
begin
  DoMethod('DELETE',URL,Response,[]);
end;

procedure TFPCustomHTTPClient.Delete(const URL: string; Response: TStrings);
begin
  Response.Text:=Delete(URL);
end;

procedure TFPCustomHTTPClient.Delete(const URL: string;
  const LocalFileName: String);

Var
  F : TFileStream;

begin
  F:=TFileStream.Create(LocalFileName,fmCreate);
  try
    Delete(URL,F);
  finally
    F.Free;
  end;
end;

function TFPCustomHTTPClient.Delete(const URL: string): String;
Var
  SS : TStringStream;
begin
  SS:=TStringStream.Create('');
  try
    Delete(URL,SS);
    Result:=SS.Datastring;
  finally
    SS.Free;
  end;
end;

Class procedure TFPCustomHTTPClient.SimpleDelete(const URL: string;
  const Response: TStream);

begin
  With Self.Create(nil) do
    try
      RequestHeaders.Add('Connection: Close');
      Delete(URL,Response);
    finally
      Free;
    end;
end;

Class procedure TFPCustomHTTPClient.SimpleDelete(const URL: string;
  Response: TStrings);

begin
  With Self.Create(nil) do
    try
      RequestHeaders.Add('Connection: Close');
      Delete(URL,Response);
    finally
      Free;
    end;
end;

Class procedure TFPCustomHTTPClient.SimpleDelete(const URL: string;
  const LocalFileName: String);

begin
  With Self.Create(nil) do
    try
      RequestHeaders.Add('Connection: Close');
      Delete(URL,LocalFileName);
    finally
      Free;
    end;
end;

Class function TFPCustomHTTPClient.SimpleDelete(const URL: string): String;

begin
  With Self.Create(nil) do
    try
      RequestHeaders.Add('Connection: Close');
      Result:=Delete(URL);
    finally
      Free;
    end;
end;

procedure TFPCustomHTTPClient.Options(const URL: string; const Response: TStream);
begin
  DoMethod('OPTIONS',URL,Response,[]);
end;

procedure TFPCustomHTTPClient.Options(const URL: string; Response: TStrings);
begin
  Response.Text:=Options(URL);
end;

procedure TFPCustomHTTPClient.Options(const URL: string;
  const LocalFileName: String);

Var
  F : TFileStream;

begin
  F:=TFileStream.Create(LocalFileName,fmCreate);
  try
    Options(URL,F);
  finally
    F.Free;
  end;
end;

function TFPCustomHTTPClient.Options(const URL: string): String;
Var
  SS : TStringStream;
begin
  SS:=TStringStream.Create('');
  try
    Options(URL,SS);
    Result:=SS.Datastring;
  finally
    SS.Free;
  end;
end;

Class procedure TFPCustomHTTPClient.SimpleOptions(const URL: string;
  const Response: TStream);

begin
  With Self.Create(nil) do
    try
      RequestHeaders.Add('Connection: Close');
      Options(URL,Response);
    finally
      Free;
    end;
end;

Class procedure TFPCustomHTTPClient.SimpleOptions(const URL: string;
  Response: TStrings);

begin
  With Self.Create(nil) do
    try
      RequestHeaders.Add('Connection: Close');
      Options(URL,Response);
    finally
      Free;
    end;
end;

Class procedure TFPCustomHTTPClient.SimpleOptions(const URL: string;
  const LocalFileName: String);

begin
  With Self.Create(nil) do
    try
      RequestHeaders.Add('Connection: Close');
      Options(URL,LocalFileName);
    finally
      Free;
    end;
end;

Class function TFPCustomHTTPClient.SimpleOptions(const URL: string): String;

begin
  With Self.Create(nil) do
    try
      RequestHeaders.Add('Connection: Close');
      Result:=Options(URL);
    finally
      Free;
    end;
end;

class procedure TFPCustomHTTPClient.Head(AURL : String; Headers: TStrings);
begin
  With Self.Create(nil) do
    try
      RequestHeaders.Add('Connection: Close');
      HTTPMethod('HEAD', AURL, Nil, [200]);
      Headers.Assign(ResponseHeaders);
    Finally
      Free;
    end;
end;

procedure TFPCustomHTTPClient.FormPost(const URL, FormData: string;
  const Response: TStream);

begin
  RequestBody:=TStringStream.Create(FormData);
  try
    AddHeader('Content-Type','application/x-www-form-urlencoded');
    Post(URL,Response);
  finally
    RequestBody.Free;
    RequestBody:=Nil;
  end;
end;

procedure TFPCustomHTTPClient.FormPost(const URL: string; FormData: TStrings;
  const Response: TStream);

Var
  I : Integer;
  S,N,V : String;

begin
  S:='';
  For I:=0 to FormData.Count-1 do
    begin
    If (S<>'') then
      S:=S+'&';
    FormData.GetNameValue(i,n,v);
    S:=S+EncodeURLElement(N)+'='+EncodeURLElement(V);
    end;
  FormPost(URL,S,Response);
end;

procedure TFPCustomHTTPClient.FormPost(const URL, FormData: string;
  const Response: TStrings);
begin
  Response.Text:=FormPost(URL,FormData);
end;

procedure TFPCustomHTTPClient.FormPost(const URL: string; FormData: TStrings;
  const Response: TStrings);
begin
  Response.Text:=FormPost(URL,FormData);
end;

function TFPCustomHTTPClient.FormPost(const URL, FormData: string): String;
Var
  SS : TStringStream;
begin
  SS:=TStringStream.Create('');
  try
    FormPost(URL,FormData,SS);
    Result:=SS.Datastring;
  finally
    SS.Free;
  end;
end;

function TFPCustomHTTPClient.FormPost(const URL: string; FormData: TStrings
  ): String;
Var
  SS : TStringStream;
begin
  SS:=TStringStream.Create('');
  try
    FormPost(URL,FormData,SS);
    Result:=SS.Datastring;
  finally
    SS.Free;
  end;
end;

Class Procedure TFPCustomHTTPClient.SimpleFormPost(const URL, FormData: string; const Response: TStream);

begin
  With Self.Create(nil) do
    try
      RequestHeaders.Add('Connection: Close');
      FormPost(URL,FormData,Response);
    Finally
      Free;
    end;
end;


Class Procedure TFPCustomHTTPClient.SimpleFormPost(const URL : string; FormData:  TStrings; const Response: TStream);

begin
  With Self.Create(nil) do
    try
      RequestHeaders.Add('Connection: Close');
      FormPost(URL,FormData,Response);
    Finally
      Free;
    end;
end;


Class Procedure TFPCustomHTTPClient.SimpleFormPost(const URL, FormData: string; const Response: TStrings);

begin
  With Self.Create(nil) do
    try
      RequestHeaders.Add('Connection: Close');
      FormPost(URL,FormData,Response);
    Finally
      Free;
    end;
end;

Class Procedure TFPCustomHTTPClient.SimpleFormPost(const URL : string; FormData:  TStrings; const Response: TStrings);

begin
  With Self.Create(nil) do
    try
      RequestHeaders.Add('Connection: Close');
      FormPost(URL,FormData,Response);
    Finally
      Free;
    end;
end;

Class function TFPCustomHTTPClient.SimpleFormPost(const URL, FormData: string): String;

begin
  With Self.Create(nil) do
    try
      RequestHeaders.Add('Connection: Close');
      Result:=FormPost(URL,FormData);
    Finally
      Free;
    end;
end;

Class function TFPCustomHTTPClient.SimpleFormPost(const URL: string; FormData : TStrings): String;

begin
  With Self.Create(nil) do
    try
      RequestHeaders.Add('Connection: Close');
      Result:=FormPost(URL,FormData);
    Finally
      Free;
    end;
end;


procedure TFPCustomHTTPClient.FileFormPost(const AURL, AFieldName, AFileName: string; const Response: TStream);

Var
  S, Sep : string;
  SS : TStringStream;
  F : TFileStream;
begin
  Sep:=Format('%.8x_multipart_boundary',[Random($ffffff)]);
  AddHeader('Content-Type','multipart/form-data; boundary='+Sep);
  S:='--'+Sep+CRLF;
  s:=s+Format('Content-Disposition: form-data; name="%s"; filename="%s"'+CRLF,[AFieldName,ExtractFileName(AFileName)]);
  s:=s+'Content-Type: application/octet-string'+CRLF+CRLF;
  SS:=TStringStream.Create(s);
  try
    SS.Seek(0,soFromEnd);
    F:=TFileStream.Create(AFileName,fmOpenRead or fmShareDenyWrite);
    try
      SS.CopyFrom(F,F.Size);
    finally
      F.Free;
    end;
    S:=CRLF+'--'+Sep+'--'+CRLF;
    SS.WriteBuffer(S[1],Length(S));
    SS.Position:=0;
    RequestBody:=SS;
    Post(AURL,Response);
  finally
   RequestBody:=Nil;
   SS.Free;
  end;
end;


Class Procedure TFPCustomHTTPClient.SimpleFileFormPost(const AURL, AFieldName, AFileName: string; const Response: TStream);

begin
  With Self.Create(nil) do
    try
      RequestHeaders.Add('Connection: Close');
      FileFormPost(AURL,AFieldName,AFileName,Response);
    Finally
      Free;
    end;
end;

end.