source: tags/1.4.0/fphttpclient2.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 fphttpclient2;

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

{$mode objfpc}{$H+}

interface

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

Const
  // Socket Read buffer size
  ReadBufLen = 4096;
  // Default for MaxRedirects Request redirection is aborted after this number of redirects.
  DefMaxRedirects = 16;

Type
  TRedirectEvent = Procedure (Sender : TObject; Const ASrc : String; Var ADest: String) of object;
  TPasswordEvent = Procedure (Sender : TObject; Var RepeatRequest : Boolean) of object;
  // During read of headers, ContentLength equals 0.
  // During read of content, of Server did not specify contentlength, -1 is passed.
  // CurrentPos is reset to 0 when the actual content is read, i.e. it is the position in the data, discarding header size.
  TDataEvent   = Procedure (Sender : TObject; Const ContentLength, CurrentPos : Int64) of object;
  // Use this to set up a socket handler. UseSSL is true if protocol was https
  TGetSocketHandlerEvent = Procedure (Sender : TObject; Const UseSSL : Boolean; Out AHandler : TSocketHandler) of object;

  { TFPCustomHTTPClient }
  TFPCustomHTTPClient = Class(TComponent)
  private
    FDataRead : Int64;
    FContentLength : Int64;
    FAllowRedirect: Boolean;
    FMaxRedirects: Byte;
    FOnDataReceived: TDataEvent;
    FOnHeaders: TNotifyEvent;
    FOnPassword: TPasswordEvent;
    FOnRedirect: TRedirectEvent;
    FPassword: String;
    FSentCookies,
    FCookies: TStrings;
    FHTTPVersion: String;
    FRequestBody: TStream;
    FRequestHeaders: TStrings;
    FResponseHeaders: TStrings;
    FResponseStatusCode: Integer;
    FResponseStatusText: String;
    FServerHTTPVersion: String;
    FSocket : TInetSocket;
    FBuffer : Ansistring;
    FUserName: String;
    FOnGetSocketHandler : TGetSocketHandlerEvent;
    function CheckContentLength: Int64;
    function CheckTransferEncoding: string;
    function GetCookies: TStrings;
    Procedure ResetResponse;
    Procedure SetCookies(const AValue: TStrings);
    Procedure SetRequestHeaders(const AValue: TStrings);
  protected
    // Called whenever data is read.
    Procedure DoDataRead; virtual;
    // 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.
    // If AllowRedirect is true, and the result is a Redirect status code, the result is also true
    // If the OnPassword event is set, then a 401 will also result in True.
    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; UseSSL : Boolean=False); 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.
    // If HandleRedirect is True, then Redirect status is accepted as a correct status, but request is not repeated.
    // No authorization callback.
    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;
    // Create socket handler for protocol AProtocol. Calls OnGetSocketHandler.
    Function GetSocketHandler(Const UseSSL : Boolean) : TSocketHandler;  virtual;
  Public
    Constructor Create(AOwner: TComponent); override;
    Destructor Destroy; override;
    // Add header Aheader with value AValue to HTTPHeaders, replacing exiting values
    Class Procedure AddHeader(HTTPHeaders : TStrings; Const AHeader,AValue : String);
    // Index of header AHeader in httpheaders.
    Class Function IndexOfHeader(HTTPHeaders : TStrings; Const AHeader : String) : Integer;
    // Return value of header AHeader from httpheaders. Returns empty if it doesn't exist yet.
    Class Function GetHeader(HTTPHeaders : TStrings; Const AHeader : String) : String;
    // 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. Handles redirect and authorization retry (OnPassword).
    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;
    // Check if responsecode is a redirect code that this class handles (301,302,303,307,308)
    Class Function IsRedirect(ACode : Integer) : Boolean; virtual;
    // If the code is a redirect, then this method  must return TRUE if the next request should happen with a GET (307/308)
    Class Function RedirectForcesGET(ACode : Integer) : Boolean; virtual;
   // 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);
    // Post form with a file
    Procedure FileFormPost(const AURL: string; FormData: TStrings; AFieldName, AFileName: string; const Response: TStream);
    // Post a stream
    Procedure StreamFormPost(const AURL, AFieldName, AFileName: string; const AStream: TStream; const Response: TStream);
    // Post form with a stream
    Procedure StreamFormPost(const AURL: string; FormData: TStrings; const AFieldName, AFileName: string; const AStream: TStream; 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;
    // Allow redirect in HTTPMethod ?
    Property AllowRedirect : Boolean Read FAllowRedirect Write FAllowRedirect;
    // Maximum number of redirects. When this number is reached, an exception is raised.
    Property MaxRedirects : Byte Read FMaxRedirects Write FMaxRedirects default DefMaxRedirects;
    // Called On redirect. Dest URL can be edited.
    // If The DEST url is empty on return, the method is aborted (with redirect status).
    Property OnRedirect : TRedirectEvent Read FOnRedirect Write FOnRedirect;
    // Authentication.
    // When set, they override the credentials found in the URI.
    // They also override any Authenticate: header in Requestheaders.
    Property UserName : String Read FUserName Write FUserName;
    Property Password : String Read FPassword Write FPassword;
    // If a request returns a 401, then the OnPassword event is fired.
    // It can modify the username/password and set RepeatRequest to true;
    Property OnPassword : TPasswordEvent Read FOnPassword Write FOnPassword;
    // Called whenever data is read from the connection.
    Property OnDataReceived : TDataEvent Read FOnDataReceived Write FOnDataReceived;
    // Called when headers have been processed.
    Property OnHeaders : TNotifyEvent Read FOnHeaders Write FOnHeaders;
    // Called to create socket handler. If not set, or Nil is returned, a standard socket handler is created.
    Property OnGetSocketHandler : TGetSocketHandlerEvent Read FOnGetSocketHandler Write FOnGetSocketHandler;
  end;


  TFPHTTPClient = Class(TFPCustomHTTPClient)
  Public
    Property RequestHeaders;
    Property RequestBody;
    Property ResponseHeaders;
    Property HTTPversion;
    Property ServerHTTPVersion;
    Property ResponseStatusCode;
    Property ResponseStatusText;
    Property Cookies;
    Property AllowRedirect;
    Property MaxRedirects;
    Property OnRedirect;
    Property UserName;
    Property Password;
    Property OnPassword;
    Property OnDataReceived;
    Property OnHeaders;
    Property OnGetSocketHandler;
  end;

  EHTTPClient = Class(EHTTP);

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

implementation
{$if not defined(hasamiga)}
uses sslsockets;
{$endif}

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';
  SErrMaxRedirectsReached = 'Maximum allowed redirects reached : %d';
  //SErrRedirectAborted = 'Redirect aborted.';

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;

procedure TFPCustomHTTPClient.DoDataRead;
begin
  If Assigned(FOnDataReceived) Then
    FOnDataReceived(Self,FContentLength,FDataRead);
end;

function TFPCustomHTTPClient.IndexOfHeader(const AHeader: String): Integer;
begin
  Result:=IndexOfHeader(RequestHeaders,AHeader);
end;

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

begin
  AddHeader(RequestHeaders,AHeader,AValue);
end;

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


begin
  Result:=GetHeader(RequestHeaders,AHeader);
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;

function TFPCustomHTTPClient.GetSocketHandler(const UseSSL: Boolean): TSocketHandler;

begin
  Result:=Nil;
  if Assigned(FonGetSocketHandler) then
    FOnGetSocketHandler(Self,UseSSL,Result);
  if (Result=Nil) then
  {$if not defined(HASAMIGA)}
    If UseSSL then
      Result:=TSSLSocketHandler.Create
    else
  {$endif}  
      Result:=TSocketHandler.Create;
end;

procedure TFPCustomHTTPClient.ConnectToServer(const AHost: String;
  APort: Integer; UseSSL : Boolean = False);

Var
  G : TSocketHandler;


begin
  if (Aport=0) then
    if UseSSL then
      Aport:=443
    else
      Aport:=80;
  G:=GetSocketHandler(UseSSL);    
  FSocket:=TInetSocket.Create(AHost,APort,G);
  try
    FSocket.Connect;
  except
    FreeAndNil(FSocket);
    Raise;
  end;
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
  UN,PW,S,L : String;
  I : Integer;

begin
  S:=Uppercase(AMethod)+' '+GetServerURL(URI)+' '+'HTTP/'+FHTTPVersion+CRLF;
  UN:=URI.Username;
  PW:=URI.Password;
  if (UserName<>'') then
    begin
    UN:=UserName;
    PW:=Password;
    end;
  If (UN<>'') then
    begin
    S:=S+'Authorization: Basic ' + EncodeStringBase64(UN+':'+PW)+CRLF;
    I:=IndexOfHeader('Authorization');
    If I<>-1 then
      RequestHeaders.Delete(i);
    end;
  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;
  FreeAndNil(FSentCookies);
  FSentCookies:=FCookies;
  FCookies:=Nil;
  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);
    FDataRead:=FDataRead+R;
    DoDataRead;
  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='');
  If Assigned(FOnHeaders) then
    FOnHeaders(Self);
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;
  If (Not Result) then
    begin
    if AllowRedirect then
      Result:=IsRedirect(ACode);
    If (ACode=401) then
      Result:=Assigned(FOnPassword);
    end;
end;

function TFPCustomHTTPClient.CheckContentLength: Int64;

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:=StrToInt64Def(Trim(S),-1);
      end;
    Inc(I);
    end;
  FContentLength:=Result;
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);

  Function Transfer(LB : Integer) : Integer;

  begin
    Result:=FSocket.Read(FBuffer[1],LB);
    If Result<0 then
      Raise EHTTPClient.Create(SErrReadingSocket);
    if (Result>0) then
      begin
      FDataRead:=FDataRead+Result;
      DoDataRead;
      Stream.Write(FBuffer[1],Result);
      end;
  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;
      FDataRead:=FDataRead+Cnt;
      DoDataRead;
  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>10000000 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 : Int64;
  LB,R : Integer;

begin
  FDataRead:=0;
  FContentLength:=0;
  SetLength(FBuffer,0);
  FResponseStatusCode:=ReadResponseHeaders;
  if not CheckResponseCode(FResponseStatusCode,AllowedResponseCodes) then
    Raise EHTTPClient.CreateFmt(SErrUnexpectedResponse,[ResponseStatusCode]);
  if HeadersOnly Or (AllowRedirect and IsRedirect(FResponseStatusCode)) then
    exit;
  if CompareText(CheckTransferEncoding,'chunked')=0 then
    ReadChunkedResponse
  else
    begin
    // Write remains of buffer to output.
    LB:=Length(FBuffer);
    FDataRead:=LB;
    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;
  P : String;

begin
  ResetResponse;
  URI:=ParseURI(AURL,False);
  p:=LowerCase(URI.Protocol);
  If Not ((P='http') or (P='https')) then
   Raise EHTTPClient.CreateFmt(SErrInvalidProtocol,[URI.Protocol]);
  ConnectToServer(URI.Host,URI.Port,P='https');
  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';
  FMaxRedirects:=DefMaxRedirects;
end;

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

class procedure TFPCustomHTTPClient.AddHeader(HTTPHeaders: TStrings;
  const AHeader, AValue: String);
Var
J: Integer;
begin
  j:=IndexOfHeader(HTTPHeaders,Aheader);
  if (J<>-1) then
    HTTPHeaders.Delete(j);
  HTTPHeaders.Add(AHeader+': '+Avalue);
end;


class function TFPCustomHTTPClient.IndexOfHeader(HTTPHeaders: TStrings;
  const AHeader: String): Integer;

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

class function TFPCustomHTTPClient.GetHeader(HTTPHeaders: TStrings;
  const AHeader: String): String;
Var
  I : Integer;
begin
  I:=IndexOfHeader(HTTPHeaders,AHeader);
  if (I=-1) then
    Result:=''
  else
    begin
    Result:=HTTPHeaders[i];
    I:=Pos(':',Result);
    if (I=0) then
      I:=Length(Result);
    System.Delete(Result,1,I);
    Result:=TrimLeft(Result);
    end;
end;

procedure TFPCustomHTTPClient.ResetResponse;

begin
  FResponseStatusCode:=0;
  FResponseStatusText:='';
  FResponseHeaders.Clear;
  FServerHTTPVersion:='';
  FBuffer:='';
end;


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

Var
  M,L,NL : String;
  RC : Integer;
  RR : Boolean; // Repeat request ?

begin
  L:=AURL;
  RC:=0;
  RR:=False;
  M:=AMethod;
  Repeat
    if Not AllowRedirect then
      DoMethod(M,L,Stream,AllowedResponseCodes)
    else
      begin
      DoMethod(M,L,Stream,AllowedResponseCodes);
      if IsRedirect(FResponseStatusCode) then
        begin
        Inc(RC);
        if (RC>MaxRedirects) then
          Raise EHTTPClient.CreateFmt(SErrMaxRedirectsReached,[RC]);
        NL:=GetHeader(FResponseHeaders,'Location');
        if Not Assigned(FOnRedirect) then
          L:=NL
        else
          FOnRedirect(Self,L,NL);
        if (RedirectForcesGET(FResponseStatusCode)) then
          M:='GET';
        L:=NL;
        // Request has saved cookies in sentcookies.
        FreeAndNil(FCookies);
        FCookies:=FSentCookies;
        FSentCookies:=Nil;
        end;
      end;
    if (FResponseStatusCode=401) then
      begin
      RR:=False;
      if Assigned(FOnPassword) then
        FOnPassword(Self,RR);
      end
    else
      RR:=AllowRedirect and IsRedirect(FResponseStatusCode) and (L<>'')
  until not RR;
end;

procedure TFPCustomHTTPClient.Get(const AURL: String; Stream: TStream);
begin
  HTTPMethod('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 function TFPCustomHTTPClient.IsRedirect(ACode: Integer): Boolean;
begin
  Case ACode of
    301,
    302,
    303,
    307,808 : Result:=True;
  else
    Result:=False;
  end;
end;

class function TFPCustomHTTPClient.RedirectForcesGET(ACode: Integer): Boolean;
begin
  Result:=(ACode=303)
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
  HTTPMethod('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
  HTTPMethod('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
  HTTPMethod('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
  HTTPMethod('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);
begin
  FileFormPost(AURL, nil, AFieldName, AFileName, Response);
end;

procedure TFPCustomHTTPClient.FileFormPost(const AURL: string;
  FormData: TStrings; AFieldName, AFileName: string; const Response: TStream);
var
  F: TFileStream;
begin
  F:=TFileStream.Create(AFileName,fmOpenRead or fmShareDenyWrite);
  try
    StreamFormPost(AURL, FormData, AFieldName, ExtractFileName(AFileName), F, Response);
  finally
    F.Free;
  end;
end;

procedure TFPCustomHTTPClient.StreamFormPost(const AURL, AFieldName,
  AFileName: string; const AStream: TStream; const Response: TStream);
begin
  StreamFormPost(AURL, nil, AFieldName, AFileName, AStream, Response);
end;

procedure TFPCustomHTTPClient.StreamFormPost(const AURL: string;
  FormData: TStrings; const AFieldName, AFileName: string;
  const AStream: TStream; const Response: TStream);
Var
  S, Sep : string;
  SS : TStringStream;
  I: Integer;
  N,V: String;
begin
  Sep:=Format('%.8x_multipart_boundary',[Random($ffffff)]);
  AddHeader('Content-Type','multipart/form-data; boundary='+Sep);
  SS:=TStringStream.Create('');
  try
    if (FormData<>Nil) then
      for I:=0 to FormData.Count -1 do
        begin
        // not url encoded
        FormData.GetNameValue(I,N,V);
        S :='--'+Sep+CRLF;
        S:=S+Format('Content-Disposition: form-data; name="%s"'+CRLF+CRLF+'%s'+CRLF,[N, V]);
        SS.WriteBuffer(S[1],Length(S));
        end;
    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.WriteBuffer(S[1],Length(S));
    AStream.Seek(0, soFromBeginning);
    SS.CopyFrom(AStream,AStream.Size);
    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.