{ $Project$ $Workfile$ $Revision$ $DateUTC$ $Id$ This file is part of the Indy (Internet Direct) project, and is offered under the dual-licensing agreement described on the Indy website. (http://www.indyproject.org/) Copyright: (c) 1993-2005, Chad Z. Hower and the Indy Pit Crew. All rights reserved. } { $Log$ } { Rev 1.65 3/5/2005 3:33:52 PM JPMugaas Fix for some compiler warnings having to do with TStream.Read being platform specific. This was fixed by changing the Compressor API to use TIdStreamVCL instead of TStream. I also made appropriate adjustments to other units for this. Rev 1.64 2/13/2005 3:09:20 PM DSiders Modified TIdCustomHTTP.PrepareRequest to free the local URI instance if an exception occurs in the method. (try...finally) Rev 1.63 2/11/05 11:29:34 AM RLebeau Removed compiler warning Rev 1.62 2/9/05 2:12:08 AM RLebeau Fixes for Compiler errors Rev 1.61 2/8/05 6:43:42 PM RLebeau Added OnHeaderAvailable event Rev 1.60 1/11/05 1:25:08 AM RLebeau More changes to SetHostAndPort() Rev 1.59 1/6/05 2:28:52 PM RLebeau Fix for SetHostAndPort() not using its local variables properly Rev 1.58 06/01/2005 22:23:04 CCostelloe Bug fix (typo, gizp instead of gzip) Rev 1.57 05/12/2004 23:10:58 CCostelloe Recoded fix to suit Delphi < 7 Rev 1.56 30/11/2004 23:46:12 CCostelloe Bug fix for SSL connections giving a "Connection closed gracefully" exception and requested page not getting returned (IOHandler.Response is empty) Rev 1.55 25/11/2004 21:28:06 CCostelloe Bug fix for POSTing fields that have the same name Rev 1.54 10/26/2004 10:13:24 PM JPMugaas Updated refs. Rev 1.53 7/16/04 1:19:20 AM RLebeau Fix for compiler error Rev 1.52 7/15/04 8:19:30 PM RLebeau Updated TIdHTTPProtocol.ProcessResponse() to treat 302 redirects like 303. Updated TIdHTTPProtocol.BuildAndSendRequest() to use a try...except block Rev 1.51 6/17/2004 8:30:04 AM DSiders TIdCustomHTTP modified: - Fixed error in AuthRetries property reading wrong member var. - Added AuthProxyRetries and MaxAuthRetries properties to public interface. TIdHTTP modified to publish AuthRetries, AuthProxyRetries, and MaxAuthRetries. TIdHTTPProtocol.ProcessResponse modified to use public properties AuthRetries, AuthProxyRetries, and MaxAutrhRetries. Rev 1.50 2004.05.20 11:36:46 AM czhower IdStreamVCL Rev 1.49 4/28/04 1:45:26 PM RLebeau Updated TIdCustomHTTP.SetRequestParams() to strip off the trailing CRLF before encoding rather than afterwards Rev 1.48 2004.04.07 11:18:08 PM czhower Bug and naming fix. Rev 1.47 7/4/2004 6:00:02 PM SGrobety Reformatted to match project guidelines Rev 1.46 7/4/2004 4:58:24 PM SGrobety Reformatted to match project guidelines Rev 1.45 6/4/2004 5:16:40 PM SGrobety Added AMaxHeaderCount: integer parameter to TIdHTTPProtocol.RetrieveHeaders and MaxHeaderLines property to TIdCustomHTTP (default to 255) Rev 1.44 2004.03.06 10:39:52 PM czhower Removed duplicate code Rev 1.43 2004.03.06 8:56:30 PM czhower -Change to disconnect -Addition of DisconnectNotifyPeer -WriteHeader now write bufers Rev 1.42 3/3/2004 5:58:00 AM JPMugaas Some IFDEF excluses were removed because the functionality is now in DotNET. Rev 1.41 2004.02.23 9:33:12 PM czhower Now can optionally ignore response codes for exceptions. Rev 1.40 2/15/2004 6:34:02 AM JPMugaas Fix for where I broke the HTTP client with a parameter change in the GZip decompress method. Rev 1.39 2004.02.03 5:43:44 PM czhower Name changes Rev 1.38 2004.02.03 2:12:10 PM czhower $I path change Rev 1.37 2004.01.27 11:41:18 PM czhower Removed const arguments Rev 1.35 24/01/2004 19:22:34 CCostelloe Cleaned up warnings Rev 1.34 2004.01.22 5:29:02 PM czhower TextIsSame Rev 1.33 2004.01.21 1:04:50 PM czhower InitComponenet Rev 1.32 1/2/2004 11:41:48 AM BGooijen Enabled IPv6 support Rev 1.31 22/11/2003 12:04:28 AM GGrieve Add support for HTTP status code 303 Rev 1.30 10/25/2003 06:51:58 AM JPMugaas Updated for new API changes and tried to restore some functionality. Rev 1.29 2003.10.24 10:43:08 AM czhower TIdSTream to dos Rev 1.28 24/10/2003 10:58:40 AM SGrobety Made authentication work even if no OnAnthenticate envent handler present Rev 1.27 10/18/2003 1:53:10 PM BGooijen Added include Rev 1.26 10/17/2003 12:08:48 AM DSiders Added localization comments. Rev 1.25 2003.10.14 1:27:52 PM czhower DotNet Rev 1.24 10/7/2003 11:33:54 PM GGrieve Get works under DotNet Rev 1.23 10/7/2003 10:07:04 PM GGrieve Get HTTP compiling for DotNet Rev 1.22 10/4/2003 9:15:58 PM GGrieve fix to compile Rev 1.21 9/26/2003 01:41:48 PM JPMugaas Fix for problem wihere "identity" was being added more than once to the accepted encoding contents. Rev 1.20 9/14/2003 07:54:20 PM JPMugaas Published the Compressor property. Rev 1.19 7/30/2003 05:34:22 AM JPMugaas Fix for bug where decompression was not done if the Content Length was specified. I found that at http://www.news.com. Added Identity to the content encoding to be consistant with Opera. Identity is the default Accept-Encoding (RFC 2616). Rev 1.18 7/13/2003 10:57:28 PM BGooijen Fixed GZip and Deflate decoding Rev 1.17 7/13/2003 11:29:06 AM JPMugaas Made sure some GZIP decompression stub code is in IdHTTP. Rev 1.15 10.7.2003 ã. 21:03:02 DBondzhev Fixed NTML proxy authorization Rev 1.14 6/19/2003 02:36:56 PM JPMugaas Removed a connected check and it seems to work better that way. Rev 1.13 6/5/2003 04:53:54 AM JPMugaas Reworkings and minor changes for new Reply exception framework. Rev 1.12 4/30/2003 01:47:24 PM JPMugaas Added TODO concerning a ConnectTimeout. Rev 1.11 4/2/2003 3:18:30 PM BGooijen fixed av when retrieving an url when no iohandler was assigned Rev 1.10 3/26/2003 5:13:40 PM BGooijen TIdSSLIOHandlerSocketBase.URIToCheck is now set Rev 1.9 3/13/2003 11:05:26 AM JPMugaas Now should work with 3rd party vendor SSL IOHandlers. Rev 1.8 3/11/2003 10:14:52 PM BGooijen Undid the stripping of the CR Rev 1.7 2/27/2003 2:04:26 PM BGooijen If any call to iohandler.readln returns a CR at the end, it is removed now. Rev 1.6 2/26/2003 11:50:08 AM BGooijen things were messed up in TIdHTTPProtocol.RetrieveHeaders, because the call to readln doesn't strip the CR at the end (terminator=LF), therefore the end of the header was not found. Rev 1.5 2/26/2003 11:42:46 AM BGooijen changed ReadLn (IOerror 6) to IOHandler.ReadLn Rev 1.4 2/4/2003 6:30:44 PM BGooijen Re-enabled SSL-support Rev 1.3 1/17/2003 04:14:42 PM JPMugaas Fixed warnings. Rev 1.2 12/7/2002 05:32:16 PM JPMugaas Now compiles with destination removed. Rev 1.1 12/6/2002 05:29:52 PM JPMugaas Now decend from TIdTCPClientCustom instead of TIdTCPClient. Rev 1.0 11/13/2002 07:54:12 AM JPMugaas 2001-Nov Nick Panteleeff - Authentication and POST parameter extentsions 2001-Sept Doychin Bondzhev - New internal design and new Authentication procedures. - Bug fixes and new features in few other supporting components 2001-Jul-7 Doychin Bondzhev - new property AllowCookie - There is no more ExtraHeders property in Request/Response. Raw headers is used for that purpose. 2001-Jul-1 Doychin Bondzhev - SSL support is up again - Thanks to Gregor 2001-Jun-17 Doychin Bondzhev - New unit IdHTTPHeaderInfo.pas that contains the TIdHeaderInfo(TIdEntytiHeaderInfo, TIdRequestHeaderInfo and TIdResponseHeaderInfo) - Still in development and not verry well tested By default when there is no authorization object associated with HTTP compoenet and there is user name and password HTTP component creates and instance of TIdBasicAuthentication class. This behaivor is for both web server and proxy server authorizations 2001-Apr-17 Doychin Bondzhev - Added OnProxyAuthorization event. This event is called on 407 response from the HTTP Proxy. - Added 2 new properties in TIdHeaderInfo property AuthenticationScheme: TIdAuthenticationScheme - this property contains information for authentication scheme requested by the web server property ProxyAuthenticationScheme: TIdAuthenticationScheme - this property contains information for authentication scheme requested by the proxy server - Now the component authomaticly reconginizes the requested authorization scheme and it supports Basic like before and has been extend to support Digest authorization 2001-Mar-31 Doychin Bondzhev - If there is no CookieManager it does not support cookies. 2001-Feb-18 Doychin Bondzhev - Added OnAuthorization event. This event is called on 401 response from the HTTP server. This can be used to ask the user program to supply user name and password in order to acces the requested resource 2001-Feb-02 Doychin Bondzhev - Added Cookie support and relative paths on redirect 2000-Jul-25 Hadi Hariri - Overloaded POst and moved clearing to disconect. 2000-June-22 Hadi Hariri - Added Proxy support. 2000-June-10 Hadi Hariri - Added Chunk-Encoding support and HTTP version number. Some additional improvements. 2000-May-23 J. Peter Mugaas -added redirect capability and supporting properties. Redirect is optional and is set with HandleRedirects. Redirection is limited to RedirectMaximum to prevent stack overflow due to recursion and to prevent redirects between two places which would cause this to go on to infinity. 2000-May-22 J. Peter Mugaas -adjusted code for servers which returned LF instead of EOL -Headers are now retreived before an exception is raised. This also facilitates server redirection where the server tells the client to get a document from another location. 2000-May-01 Hadi Hariri -Converted to Mercury 2000-May-01 Hadi Hariri -Added PostFromStream and some clean up 2000-Apr-10 Hadi Hariri -Re-done quite a few things and fixed GET bugs and finished POST method. 2000-Jan-13 MTL -Moved to the New Palette Scheme 2000-Jan-08 MTL -Cleaned up a few compiler hints during 7.038 build 1999-Dec-10 Hadi Hariri -Started. } unit IdHTTP; { Implementation of the HTTP protcol as specified in RFC 2616, 2109, 2965. (See NOTE below for details of what is exactly implemented) Author: Hadi Hariri (hadi@urusoft.com) Copyright: (c) Chad Z. Hower and The Winshoes Working Group. Initials: Hadi Hariri - HH } { TODO: Figure out what to do with ConnectTimeout. Ideally, that should be in the core and is not the same as a read Timeout. } interface {$I IdCompilerDefines.inc} uses Classes, IdException, IdExceptionCore, IdAssignedNumbers, IdHeaderList, IdHTTPHeaderInfo, IdReplyRFC, IdSSL, IdZLibCompressorBase, IdTCPClient, IdURI, IdCookie, IdCookieManager, IdAuthentication, IdAuthenticationManager, IdMultipartFormData, IdGlobal, IdBaseComponent, IdUriUtils; type // TO DOCUMENTATION TEAM // ------------------------ // For internal use. No need of documentation // hmConnect - Used to connect trought CERN proxy to SSL enabled sites. TIdHTTPMethod = string; const Id_HTTPMethodHead = 'HEAD'; Id_HTTPMethodGet = 'GET'; Id_HTTPMethodPost = 'POST'; Id_HTTPMethodOptions = 'OPTIONS'; Id_HTTPMethodTrace = 'TRACE'; Id_HTTPMethodPut = 'PUT'; Id_HTTPMethodDelete = 'DELETE'; Id_HTTPMethodConnect = 'CONNECT'; Id_HTTPMethodPatch = 'PATCH'; //(hmHead, hmGet, hmPost, hmOptions, hmTrace, hmPut, hmDelete, hmConnect, hmPatch); type TIdHTTPWhatsNext = (wnGoToURL, wnJustExit, wnDontKnow, wnReadAndGo, wnAuthRequest); TIdHTTPConnectionType = (ctNormal, ctSSL, ctProxy, ctSSLProxy); // Protocol options TIdHTTPOption = (hoInProcessAuth, hoKeepOrigProtocol, hoForceEncodeParams, hoNonSSLProxyUseConnectVerb, hoNoParseMetaHTTPEquiv, hoWaitForUnexpectedData, hoTreat302Like303, hoNoProtocolErrorException, hoNoReadMultipartMIME); TIdHTTPOptions = set of TIdHTTPOption; // Must be documented TIdHTTPProtocolVersion = (pv1_0, pv1_1); TIdHTTPOnRedirectEvent = procedure(Sender: TObject; var dest: string; var NumRedirect: Integer; var Handled: boolean; var VMethod: TIdHTTPMethod) of object; TIdHTTPOnHeadersAvailable = procedure(Sender: TObject; AHeaders: TIdHeaderList; var VContinue: Boolean) of object; TIdOnSelectAuthorization = procedure(Sender: TObject; var AuthenticationClass: TIdAuthenticationClass; AuthInfo: TIdHeaderList) of object; TIdOnAuthorization = procedure(Sender: TObject; Authentication: TIdAuthentication; var Handled: Boolean) of object; // TIdProxyOnAuthorization = procedure(Sender: TObject; Authentication: TIdAuthentication; var Handled: boolean) of object; const Id_TIdHTTP_ProtocolVersion = pv1_1; Id_TIdHTTP_RedirectMax = 15; Id_TIdHTTP_MaxHeaderLines = 255; Id_TIdHTTP_HandleRedirects = False; Id_TIdHTTP_MaxAuthRetries = 3; type TIdCustomHTTP = class; // TO DOCUMENTATION TEAM // ------------------------ // The following classes are used internally and no need of documentation // Only TIdHTTP must be documented // TIdHTTPResponse = class(TIdResponseHeaderInfo) protected {$IFDEF USE_OBJECT_ARC}[Weak]{$ENDIF} FHTTP: TIdCustomHTTP; FResponseCode: Integer; FResponseText: string; FKeepAlive: Boolean; {$IFDEF USE_OBJECT_ARC}[Weak]{$ENDIF} FContentStream: TStream; FResponseVersion: TIdHTTPProtocolVersion; FMetaHTTPEquiv : TIdMetaHTTPEquiv; // function GetKeepAlive: Boolean; function GetResponseCode: Integer; procedure SetResponseText(const AValue: String); procedure ProcessMetaHTTPEquiv; public constructor Create(AHTTP: TIdCustomHTTP); reintroduce; virtual; destructor Destroy; override; procedure Clear; override; property KeepAlive: Boolean read GetKeepAlive write FKeepAlive; property MetaHTTPEquiv: TIdMetaHTTPEquiv read FMetaHTTPEquiv; property ResponseText: string read FResponseText write SetResponseText; property ResponseCode: Integer read GetResponseCode write FResponseCode; property ResponseVersion: TIdHTTPProtocolVersion read FResponseVersion write FResponseVersion; property ContentStream: TStream read FContentStream write FContentStream; end; TIdHTTPRequest = class(TIdRequestHeaderInfo) protected {$IFDEF USE_OBJECT_ARC}[Weak]{$ENDIF} FHTTP: TIdCustomHTTP; FURL: string; FMethod: TIdHTTPMethod; {$IFDEF USE_OBJECT_ARC}[Weak]{$ENDIF} FSourceStream: TStream; FUseProxy: TIdHTTPConnectionType; FIPVersion: TIdIPVersion; FDestination: string; public constructor Create(AHTTP: TIdCustomHTTP); reintroduce; virtual; property URL: string read FURL write FURL; property Method: TIdHTTPMethod read FMethod write FMethod; property Source: TStream read FSourceStream write FSourceStream; property UseProxy: TIdHTTPConnectionType read FUseProxy; property IPVersion: TIdIPversion read FIPVersion write FIPVersion; property Destination: string read FDestination write FDestination; end; TIdHTTPProtocol = class(TObject) protected {$IFDEF USE_OBJECT_ARC}[Weak]{$ENDIF} FHTTP: TIdCustomHTTP; FRequest: TIdHTTPRequest; FResponse: TIdHTTPResponse; public constructor Create(AConnection: TIdCustomHTTP); destructor Destroy; override; function ProcessResponse(AIgnoreReplies: array of Int16): TIdHTTPWhatsNext; procedure BuildAndSendRequest(AURI: TIdURI); procedure RetrieveHeaders(AMaxHeaderCount: integer); // property Request: TIdHTTPRequest read FRequest; property Response: TIdHTTPResponse read FResponse; end; TIdCustomHTTP = class(TIdTCPClientCustom) protected {Retries counter for WWW authorization} FAuthRetries: Integer; {Retries counter for proxy authorization} FAuthProxyRetries: Integer; {$IFDEF USE_OBJECT_ARC}[Weak]{$ENDIF} FCookieManager: TIdCookieManager; {$IFDEF USE_OBJECT_ARC}[Weak]{$ENDIF} FCompressor : TIdZLibCompressorBase; FImplicitCookieManager: Boolean; {Max retries for authorization} FMaxAuthRetries: Integer; FMaxHeaderLines: integer; FAllowCookies: Boolean; {$IFDEF USE_OBJECT_ARC}[Weak]{$ENDIF} FAuthenticationManager: TIdAuthenticationManager; FProtocolVersion: TIdHTTPProtocolVersion; {this is an internal counter for redirects} FRedirectCount: Integer; FRedirectMax: Integer; FHandleRedirects: Boolean; FOptions: TIdHTTPOptions; FURI: TIdURI; FHTTPProto: TIdHTTPProtocol; FProxyParameters: TIdProxyConnectionInfo; // FOnHeadersAvailable: TIdHTTPOnHeadersAvailable; FOnRedirect: TIdHTTPOnRedirectEvent; FOnSelectAuthorization: TIdOnSelectAuthorization; FOnSelectProxyAuthorization: TIdOnSelectAuthorization; FOnAuthorization: TIdOnAuthorization; FOnProxyAuthorization: TIdOnAuthorization; // { procedure SetHost(const Value: string); override; procedure SetPort(const Value: integer); override; } procedure DoRequest(const AMethod: TIdHTTPMethod; AURL: string; ASource, AResponseContent: TStream; AIgnoreReplies: array of Int16); virtual; function CreateProtocol: TIdHTTPProtocol; virtual; procedure InitComponent; override; function InternalReadLn: String; procedure SetAuthenticationManager(Value: TIdAuthenticationManager); procedure SetCookieManager(ACookieManager: TIdCookieManager); procedure SetAllowCookies(AValue: Boolean); function GetResponseCode: Integer; function GetResponseText: string; function DoOnAuthorization(ARequest: TIdHTTPRequest; AResponse: TIdHTTPResponse): Boolean; virtual; function DoOnProxyAuthorization(ARequest: TIdHTTPRequest; AResponse: TIdHTTPResponse): Boolean; virtual; function DoOnRedirect(var Location: string; var VMethod: TIdHTTPMethod; RedirectCount: integer): boolean; virtual; procedure Notification(AComponent: TComponent; Operation: TOperation); override; procedure ProcessCookies(ARequest: TIdHTTPRequest; AResponse: TIdHTTPResponse); function SetHostAndPort: TIdHTTPConnectionType; procedure SetCookies(AURL: TIdURI; ARequest: TIdHTTPRequest); procedure ReadResult(ARequest: TIdHTTPRequest; AResponse: TIdHTTPResponse); procedure PrepareRequest(ARequest: TIdHTTPRequest); procedure ConnectToHost(ARequest: TIdHTTPRequest; AResponse: TIdHTTPResponse); function GetResponse: TIdHTTPResponse; function GetRequest: TIdHTTPRequest; function GetMetaHTTPEquiv: TIdMetaHTTPEquiv; procedure SetRequest(Value: TIdHTTPRequest); procedure SetProxyParams(AValue: TIdProxyConnectionInfo); function SetRequestParams(ASource: TStrings; AByteEncoding: IIdTextEncoding {$IFDEF STRING_IS_ANSI}; ASrcEncoding: IIdTextEncoding{$ENDIF} ): string; procedure CheckAndConnect(ARequest: TIdHTTPRequest; AResponse: TIdHTTPResponse); procedure DoOnDisconnected; override; //misc internal stuff function ResponseCharset: String; public destructor Destroy; override; procedure Delete(AURL: string; AResponseContent: TStream); overload; function Delete(AURL: string {$IFDEF STRING_IS_ANSI}; ADestEncoding: IIdTextEncoding = nil{$ENDIF} ): string; overload; procedure Options(AURL: string; AResponseContent: TStream); overload; function Options(AURL: string {$IFDEF STRING_IS_ANSI}; ADestEncoding: IIdTextEncoding = nil{$ENDIF} ): string; overload; procedure Get(AURL: string; AResponseContent: TStream); overload; procedure Get(AURL: string; AResponseContent: TStream; AIgnoreReplies: array of Int16); overload; function Get(AURL: string {$IFDEF STRING_IS_ANSI}; ADestEncoding: IIdTextEncoding = nil{$ENDIF} ): string; overload; function Get(AURL: string; AIgnoreReplies: array of Int16 {$IFDEF STRING_IS_ANSI}; ADestEncoding: IIdTextEncoding = nil{$ENDIF} ): string; overload; procedure Trace(AURL: string; AResponseContent: TStream); overload; function Trace(AURL: string {$IFDEF STRING_IS_ANSI}; ADestEncoding: IIdTextEncoding = nil{$ENDIF} ): string; overload; procedure Head(AURL: string); function Post(AURL: string; const ASourceFile: String {$IFDEF STRING_IS_ANSI}; ADestEncoding: IIdTextEncoding = nil{$ENDIF} ): string; overload; function Post(AURL: string; ASource: TStrings; AByteEncoding: IIdTextEncoding = nil {$IFDEF STRING_IS_ANSI}; ASrcEncoding: IIdTextEncoding = nil; ADestEncoding: IIdTextEncoding = nil{$ENDIF}): string; overload; function Post(AURL: string; ASource: TStream {$IFDEF STRING_IS_ANSI}; ADestEncoding: IIdTextEncoding = nil{$ENDIF} ): string; overload; function Post(AURL: string; ASource: TIdMultiPartFormDataStream {$IFDEF STRING_IS_ANSI}; ADestEncoding: IIdTextEncoding = nil{$ENDIF} ): string; overload; procedure Post(AURL: string; const ASourceFile: String; AResponseContent: TStream); overload; procedure Post(AURL: string; ASource: TStrings; AResponseContent: TStream; AByteEncoding: IIdTextEncoding = nil {$IFDEF STRING_IS_ANSI}; ASrcEncoding: IIdTextEncoding = nil{$ENDIF}); overload; procedure Post(AURL: string; ASource, AResponseContent: TStream); overload; procedure Post(AURL: string; ASource: TIdMultiPartFormDataStream; AResponseContent: TStream); overload; function Put(AURL: string; ASource: TStream {$IFDEF STRING_IS_ANSI}; ADestEncoding: IIdTextEncoding = nil{$ENDIF} ): string; overload; procedure Put(AURL: string; ASource, AResponseContent: TStream); overload; procedure Patch(AURL: string; ASource, AResponseContent: TStream); overload; function Patch(AURL: string; ASource: TStream {$IFDEF STRING_IS_ANSI}; ADestEncoding: IIdTextEncoding = nil{$ENDIF} ): string; overload; {This is an object that can compress and decompress HTTP Deflate encoding} property Compressor : TIdZLibCompressorBase read FCompressor write FCompressor; {This is the response code number such as 404 for File not Found} property ResponseCode: Integer read GetResponseCode; {This is the text of the message such as "404 File Not Found here Sorry"} property ResponseText: string read GetResponseText; property Response: TIdHTTPResponse read GetResponse; property MetaHTTPEquiv: TIdMetaHTTPEquiv read GetMetaHTTPEquiv; { This is the last processed URL } property URL: TIdURI read FURI; // number of retry attempts for Authentication property AuthRetries: Integer read FAuthRetries; property AuthProxyRetries: Integer read FAuthProxyRetries; // maximum number of Authentication retries permitted property MaxAuthRetries: Integer read FMaxAuthRetries write FMaxAuthRetries default Id_TIdHTTP_MaxAuthRetries; property AllowCookies: Boolean read FAllowCookies write SetAllowCookies; {Do we handle redirect requests or simply raise an exception and let the developer deal with it} property HandleRedirects: Boolean read FHandleRedirects write FHandleRedirects default Id_TIdHTTP_HandleRedirects; property ProtocolVersion: TIdHTTPProtocolVersion read FProtocolVersion write FProtocolVersion default Id_TIdHTTP_ProtocolVersion; //how many redirects were made in the last request property RedirectCount: Integer read FRedirectCount; {This is the maximum number of redirects we wish to handle, we limit this to prevent stack overflow due to recursion. Recursion is safe ONLY if prevented for continuing to infinity} property RedirectMaximum: Integer read FRedirectMax write FRedirectMax default Id_TIdHTTP_RedirectMax; // S.G. 6/4/2004: This is to prevent the server from responding with too many header lines property MaxHeaderLines: integer read FMaxHeaderLines write FMaxHeaderLines default Id_TIdHTTP_MaxHeaderLines; property ProxyParams: TIdProxyConnectionInfo read FProxyParameters write SetProxyParams; property Request: TIdHTTPRequest read GetRequest write SetRequest; property HTTPOptions: TIdHTTPOptions read FOptions write FOptions; // property OnHeadersAvailable: TIdHTTPOnHeadersAvailable read FOnHeadersAvailable write FOnHeadersAvailable; // Fired when a rediretion is requested. property OnRedirect: TIdHTTPOnRedirectEvent read FOnRedirect write FOnRedirect; property OnSelectAuthorization: TIdOnSelectAuthorization read FOnSelectAuthorization write FOnSelectAuthorization; property OnSelectProxyAuthorization: TIdOnSelectAuthorization read FOnSelectProxyAuthorization write FOnSelectProxyAuthorization; property OnAuthorization: TIdOnAuthorization read FOnAuthorization write FOnAuthorization; property OnProxyAuthorization: TIdOnAuthorization read FOnProxyAuthorization write FOnProxyAuthorization; // Cookie stuff property CookieManager: TIdCookieManager read FCookieManager write SetCookieManager; // property AuthenticationManager: TIdAuthenticationManager read FAuthenticationManager write SetAuthenticationManager; end; TIdHTTP = class(TIdCustomHTTP) published // number of Authentication retries permitted property MaxAuthRetries; property AllowCookies; { Do we handle redirect requests or simply raise an exception and let the developer deal with it } property HandleRedirects; property ProtocolVersion; { This is the maximum number of redirects we wish to handle, we limit this to prevent stack overflow due to recursion. Recursion is safe ONLY if prevented for continuing to infinity } property RedirectMaximum; property ProxyParams; property Request; property HTTPOptions; // property OnHeadersAvailable; // Fired when a rediretion is requested. property OnRedirect; property OnSelectAuthorization; property OnSelectProxyAuthorization; property OnAuthorization; property OnProxyAuthorization; // property Host; // property Port default IdPORT_HTTP; // Cookie stuff property CookieManager; // property AuthenticationManager: TIdAuthenticationManager read FAuthenticationManager write SetAuthenticationManager; // ZLib compression library object for use with deflate and gzip encoding property Compressor; end; EIdUnknownProtocol = class(EIdException); EIdHTTPProtocolException = class( EIdReplyRFCError ) protected FErrorMessage: string; public constructor CreateError(const anErrCode: Integer; const asReplyMessage: string; const asErrorMessage: string); reintroduce; virtual; property ErrorMessage: string read FErrorMessage; end; implementation uses SysUtils, IdAllAuthentications, IdComponent, IdCoderMIME, IdTCPConnection, IdResourceStringsCore, IdResourceStringsProtocols, IdGlobalProtocols, IdIOHandler, IdIOHandlerSocket; const ProtocolVersionString: array[TIdHTTPProtocolVersion] of string = ('1.0', '1.1'); {do not localize} { EIdHTTPProtocolException } constructor EIdHTTPProtocolException.CreateError(const anErrCode: Integer; const asReplyMessage: string; const asErrorMessage: string); begin inherited CreateError(anErrCode, asReplyMessage); FErrorMessage := asErrorMessage; end; { TIdHTTP } function IsContentTypeHtml(AInfo: TIdEntityHeaderInfo) : Boolean; begin Result := IsHeaderMediaTypes(AInfo.ContentType, ['text/html', 'text/html-sandboxed','application/xhtml+xml']); {do not localize} end; function IsContentTypeAppXml(AInfo: TIdEntityHeaderInfo) : Boolean; begin Result := IsHeaderMediaTypes(AInfo.ContentType, ['application/xml', 'application/xml-external-parsed-entity', 'application/xml-dtd'] {do not localize} ); if not Result then begin Result := not IsHeaderMediaType(AInfo.ContentType, 'text'); {do not localize} if Result then begin Result := TextEndsWith(ExtractHeaderMediaSubType(AInfo.ContentType), '+xml') {do not localize} end; end; end; destructor TIdCustomHTTP.Destroy; begin FreeAndNil(FHTTPProto); FreeAndNil(FURI); FreeAndNil(FProxyParameters); SetCookieManager(nil); inherited Destroy; end; procedure TIdCustomHTTP.Delete(AURL: string; AResponseContent: TStream); begin DoRequest(Id_HTTPMethodDelete, AURL, nil, AResponseContent, []); end; function TIdCustomHTTP.Delete(AURL: string {$IFDEF STRING_IS_ANSI}; ADestEncoding: IIdTextEncoding = nil{$ENDIF} ): string; var LStream: TMemoryStream; begin LStream := TMemoryStream.Create; try DoRequest(Id_HTTPMethodDelete, AURL, nil, LStream, []); LStream.Position := 0; Result := ReadStringAsCharset(LStream, ResponseCharset{$IFDEF STRING_IS_ANSI}, ADestEncoding{$ENDIF}); // TODO: if the data is XML, add/update the declared encoding to 'UTF-16LE'... finally FreeAndNil(LStream); end; end; procedure TIdCustomHTTP.Options(AURL: string; AResponseContent: TStream); begin DoRequest(Id_HTTPMethodOptions, AURL, nil, AResponseContent, []); end; function TIdCustomHTTP.Options(AURL: string {$IFDEF STRING_IS_ANSI}; ADestEncoding: IIdTextEncoding = nil{$ENDIF} ): string; var LStream: TMemoryStream; begin LStream := TMemoryStream.Create; try DoRequest(Id_HTTPMethodOptions, AURL, nil, LStream, []); LStream.Position := 0; Result := ReadStringAsCharset(LStream, ResponseCharset{$IFDEF STRING_IS_ANSI}, ADestEncoding{$ENDIF}); // TODO: if the data is XML, add/update the declared encoding to 'UTF-16LE'... finally FreeAndNil(LStream); end; end; procedure TIdCustomHTTP.Get(AURL: string; AResponseContent: TStream); begin Get(AURL, AResponseContent, []); end; procedure TIdCustomHTTP.Trace(AURL: string; AResponseContent: TStream); begin DoRequest(Id_HTTPMethodTrace, AURL, nil, AResponseContent, []); end; procedure TIdCustomHTTP.Head(AURL: string); begin DoRequest(Id_HTTPMethodHead, AURL, nil, nil, []); end; procedure TIdCustomHTTP.Post(AURL: string; ASource, AResponseContent: TStream); var OldProtocol: TIdHTTPProtocolVersion; begin // PLEASE READ CAREFULLY // Currently when issuing a POST, IdHTTP will automatically set the protocol // to version 1.0 independently of the value it had initially. This is because // there are some servers that don't respect the RFC to the full extent. In // particular, they don't respect sending/not sending the Expect: 100-Continue // header. Until we find an optimum solution that does NOT break the RFC, we // will restrict POSTS to version 1.0. OldProtocol := FProtocolVersion; try // If hoKeepOrigProtocol is SET, is possible to assume that the developer // is sure in operations of the server if not (hoKeepOrigProtocol in FOptions) then begin if Connected then begin Disconnect; end; FProtocolVersion := pv1_0; end; DoRequest(Id_HTTPMethodPost, AURL, ASource, AResponseContent, []); finally FProtocolVersion := OldProtocol; end; end; // RLebeau 12/21/2010: this is based on W3's HTML standards: // // HTML 4.01 // http://www.w3.org/TR/html401/ // // HTML 5 // http://www.w3.org/TR/html5/ function WWWFormUrlEncode(const ASrc: string; AByteEncoding: IIdTextEncoding {$IFDEF STRING_IS_ANSI}; ASrcEncoding: IIdTextEncoding{$ENDIF} ): string; const // HTML 4.01 Section 17.13.4 ("Form content types") says: // // application/x-www-form-urlencoded // // Control names and values are escaped. Space characters are replaced by `+', // and then reserved characters are escaped as described in [RFC1738], section // 2.2: Non-alphanumeric characters are replaced by `%HH', a percent sign and // two hexadecimal digits representing the ASCII code of the character. Line // breaks are represented as "CR LF" pairs (i.e., `%0D%0A'). // // On the other hand, HTML 5 Section 4.10.16.4 ("URL-encoded form data") says: // // If the character isn't in the range U+0020, U+002A, U+002D, U+002E, // U+0030 .. U+0039, U+0041 .. U+005A, U+005F, U+0061 .. U+007A then replace // the character with a string formed as follows: Start with the empty string, // and then, taking each byte of the character when expressed in the selected // character encoding in turn, append to the string a U+0025 PERCENT SIGN // character (%) followed by two characters in the ranges U+0030 DIGIT ZERO (0) // to U+0039 DIGIT NINE (9) and U+0041 LATIN CAPITAL LETTER A to // U+005A LATIN CAPITAL LETTER Z representing the hexadecimal value of the // byte zero-padded if necessary). // // If the character is a U+0020 SPACE character, replace it with a single // U+002B PLUS SIGN character (+). // // So, lets err on the side of caution and use the HTML 5.x definition, as it // encodes some of the characters that HTML 4.01 allows unencoded... // SafeChars: TIdUnicodeString = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789*-._'; {do not localize} var I, J, CharLen, ByteLen: Integer; Buf: TIdBytes; {$IFDEF STRING_IS_ANSI} LChars: TIdWideChars; {$ENDIF} LChar: WideChar; Encoded: Boolean; begin Result := ''; {Do not Localize} // keep the compiler happy Buf := nil; {$IFDEF STRING_IS_ANSI} LChars := nil; {$ENDIF} if ASrc = '' then begin Exit; end; EnsureEncoding(AByteEncoding, encUTF8); {$IFDEF STRING_IS_ANSI} EnsureEncoding(ASrcEncoding, encOSDefault); LChars := ASrcEncoding.GetChars(RawToBytes(ASrc[1], Length(ASrc))); {$ENDIF} // 2 Chars to handle UTF-16 surrogates SetLength(Buf, AByteEncoding.GetMaxByteCount(2)); I := 0; while I < Length({$IFDEF STRING_IS_UNICODE}ASrc{$ELSE}LChars{$ENDIF}) do begin LChar := {$IFDEF STRING_IS_UNICODE}ASrc[I+1]{$ELSE}LChars[I]{$ENDIF}; // RLebeau 1/7/09: using Ord() for #128-#255 because in D2009 and later, the // compiler may change characters >= #128 from their Ansi codepage value to // their true Unicode codepoint value, depending on the codepage used for // the source code. For instance, #128 may become #$20AC... if Ord(LChar) = 32 then {do not localize} begin Result := Result + '+'; {do not localize} Inc(I); end else if WideCharIsInSet(SafeChars, LChar) then begin Result := Result + Char(LChar); Inc(I); end else begin // HTML 5 Section 4.10.16.4 says: // // For each character ... that cannot be expressed using the selected character // encoding, replace the character by a string consisting of a U+0026 AMPERSAND // character (&), a U+0023 NUMBER SIGN character (#), one or more characters in // the range U+0030 DIGIT ZERO (0) to U+0039 DIGIT NINE (9) representing the // Unicode code point of the character in base ten, and finally a U+003B // SEMICOLON character (;). // CharLen := CalcUTF16CharLength( {$IFDEF STRING_IS_UNICODE}ASrc, I+1{$ELSE}LChars, I{$ENDIF} ); // calculate length including surrogates ByteLen := AByteEncoding.GetBytes( {$IFDEF STRING_IS_UNICODE}ASrc, I+1{$ELSE}LChars, I{$ENDIF}, CharLen, Buf, 0); // explicit Unicode->Ansi conversion Encoded := (ByteLen > 0); if Encoded and (LChar <> '?') then begin {do not localize} for J := 0 to ByteLen-1 do begin if Buf[J] = Ord('?') then begin {do not localize} Encoded := False; Break; end; end; end; if Encoded then begin for J := 0 to ByteLen-1 do begin Result := Result + '%' + IntToHex(Ord(Buf[J]), 2); {do not localize} end; end else begin J := GetUTF16Codepoint( {$IFDEF STRING_IS_UNICODE}ASrc, I+1{$ELSE}LChars, I{$ENDIF}); Result := Result + '&#' + IntToStr(J) + ';'; {do not localize} end; Inc(I, CharLen); end; end; end; function TIdCustomHTTP.SetRequestParams(ASource: TStrings; AByteEncoding: IIdTextEncoding {$IFDEF STRING_IS_ANSI}; ASrcEncoding: IIdTextEncoding{$ENDIF} ): string; var i: Integer; LPos: integer; LStr: string; LTemp: TStringList; function EncodeLineBreaks(AStrings: TStrings): String; begin if AStrings.Count > 1 then begin // break trailing CR&LF Result := ReplaceAll(Trim(AStrings.Text), sLineBreak, '&'); {do not localize} end else begin Result := Trim(AStrings.Text); end; end; begin if Assigned(ASource) then begin if hoForceEncodeParams in FOptions then begin // make a copy of ASource so the caller's TStrings object is not modified LTemp := TStringList.Create; try LTemp.Assign(ASource); for i := 0 to LTemp.Count - 1 do begin LStr := LTemp[i]; // TODO: use LTemp.NameValueSeparator on platforms that support it LPos := IndyPos('=', LStr); {do not localize} if LPos > 0 then begin LTemp[i] := WWWFormUrlEncode(LTemp.Names[i], AByteEncoding{$IFDEF STRING_IS_ANSI}, ASrcEncoding{$ENDIF}) + '=' {do not localize} + WWWFormUrlEncode(IndyValueFromIndex(LTemp, i), AByteEncoding{$IFDEF STRING_IS_ANSI}, ASrcEncoding{$ENDIF}); end else begin LTemp[i] := WWWFormUrlEncode(LStr, AByteEncoding{$IFDEF STRING_IS_ANSI}, ASrcEncoding{$ENDIF}); end; end; Result := EncodeLineBreaks(LTemp); finally LTemp.Free; end; end else begin Result := EncodeLineBreaks(ASource); end; end else begin Result := ''; end; end; function TIdCustomHTTP.Post(AURL: string; const ASourceFile: String {$IFDEF STRING_IS_ANSI}; ADestEncoding: IIdTextEncoding = nil{$ENDIF} ): string; var LSource: TIdReadFileExclusiveStream; begin LSource := TIdReadFileExclusiveStream.Create(ASourceFile); try Result := Post(AURL, LSource{$IFDEF STRING_IS_ANSI}, ADestEncoding{$ENDIF}); finally FreeAndNil(LSource); end; end; procedure TIdCustomHTTP.Post(AURL: string; const ASourceFile: String; AResponseContent: TStream); var LSource: TStream; begin LSource := TIdReadFileExclusiveStream.Create(ASourceFile); try Post(AURL, LSource, AResponseContent); finally FreeAndNil(LSource); end; end; procedure TIdCustomHTTP.Post(AURL: string; ASource: TStrings; AResponseContent: TStream; AByteEncoding: IIdTextEncoding = nil {$IFDEF STRING_IS_ANSI}; ASrcEncoding: IIdTextEncoding = nil{$ENDIF} ); var LParams: TMemoryStream; begin // Usual posting request have default ContentType is application/x-www-form-urlencoded if (Request.ContentType = '') or IsContentTypeHtml(Request) then begin Request.ContentType := 'application/x-www-form-urlencoded'; {do not localize} end; if ASource <> nil then begin LParams := TMemoryStream.Create; try WriteStringToStream(LParams, SetRequestParams(ASource, AByteEncoding{$IFDEF STRING_IS_ANSI}, ASrcEncoding{$ENDIF})); LParams.Position := 0; Post(AURL, LParams, AResponseContent); finally FreeAndNil(LParams); end; end else begin Post(AURL, TStream(nil), AResponseContent); end; end; function TIdCustomHTTP.Post(AURL: string; ASource: TStrings; AByteEncoding: IIdTextEncoding = nil {$IFDEF STRING_IS_ANSI}; ASrcEncoding: IIdTextEncoding = nil; ADestEncoding: IIdTextEncoding = nil{$ENDIF} ): string; var LResponse: TMemoryStream; begin LResponse := TMemoryStream.Create; try Post(AURL, ASource, LResponse, AByteEncoding{$IFDEF STRING_IS_ANSI}, ASrcEncoding{$ENDIF}); LResponse.Position := 0; Result := ReadStringAsCharset(LResponse, ResponseCharset{$IFDEF STRING_IS_ANSI}, ADestEncoding{$ENDIF}); // TODO: if the data is XML, add/update the declared encoding to 'UTF-16LE'... finally FreeAndNil(LResponse); end; end; function TIdCustomHTTP.Post(AURL: string; ASource: TStream {$IFDEF STRING_IS_ANSI}; ADestEncoding: IIdTextEncoding = nil{$ENDIF} ): string; var LResponse: TMemoryStream; begin LResponse := TMemoryStream.Create; try Post(AURL, ASource, LResponse); LResponse.Position := 0; Result := ReadStringAsCharset(LResponse, ResponseCharset{$IFDEF STRING_IS_ANSI}, ADestEncoding{$ENDIF}); // TODO: if the data is XML, add/update the declared encoding to 'UTF-16LE'... finally FreeAndNil(LResponse); end; end; procedure TIdCustomHTTP.Put(AURL: string; ASource, AResponseContent: TStream); begin DoRequest(Id_HTTPMethodPut, AURL, ASource, AResponseContent, []); end; function TIdCustomHTTP.Put(AURL: string; ASource: TStream {$IFDEF STRING_IS_ANSI}; ADestEncoding: IIdTextEncoding = nil{$ENDIF} ): string; var LResponse: TMemoryStream; begin LResponse := TMemoryStream.Create; try Put(AURL, ASource, LResponse); LResponse.Position := 0; Result := ReadStringAsCharset(LResponse, ResponseCharset{$IFDEF STRING_IS_ANSI}, ADestEncoding{$ENDIF}); // TODO: if the data is XML, add/update the declared encoding to 'UTF-16LE'... finally FreeAndNil(LResponse); end; end; function TIdCustomHTTP.Get(AURL: string {$IFDEF STRING_IS_ANSI}; ADestEncoding: IIdTextEncoding = nil{$ENDIF} ): string; begin Result := Get(AURL, []{$IFDEF STRING_IS_ANSI}, ADestEncoding{$ENDIF}); end; function TIdCustomHTTP.Trace(AURL: string {$IFDEF STRING_IS_ANSI}; ADestEncoding: IIdTextEncoding = nil{$ENDIF} ): string; var LResponse: TMemoryStream; begin LResponse := TMemoryStream.Create; try Trace(AURL, LResponse); LResponse.Position := 0; Result := ReadStringAsCharset(LResponse, ResponseCharset{$IFDEF STRING_IS_ANSI}, ADestEncoding{$ENDIF}); // TODO: if the data is XML, add/update the declared encoding to 'UTF-16LE'... finally FreeAndNil(LResponse); end; end; function TIdCustomHTTP.DoOnRedirect(var Location: string; var VMethod: TIdHTTPMethod; RedirectCount: integer): boolean; begin // TODO: convert relative URLs to full URLs here... Result := HandleRedirects; if Assigned(FOnRedirect) then begin FOnRedirect(Self, Location, RedirectCount, Result, VMethod); end; end; procedure TIdCustomHTTP.SetCookies(AURL: TIdURI; ARequest: TIdHTTPRequest); var // under ARC, convert a weak reference to a strong reference before working with it LCookieManager: TIdCookieManager; begin LCookieManager := FCookieManager; if Assigned(LCookieManager) and AllowCookies then begin // Send secure cookies only if we have Secured connection LCookieManager.GenerateClientCookies( AURL, TextIsSame(AURL.Protocol, 'HTTPS'), {do not localize} ARequest.RawHeaders); end; end; // This function sets the Host and Port and returns a boolean depending on // whether a PROXY is being used or not. function TIdCustomHTTP.SetHostAndPort: TIdHTTPConnectionType; var LHost: string; LPort: Integer; begin // First check to see if a Proxy has been specified. if Length(ProxyParams.ProxyServer) > 0 then begin if (not TextIsSame(FHost, ProxyParams.ProxyServer)) or (FPort <> ProxyParams.ProxyPort) then begin if Connected then begin Disconnect; end; end; LHost := ProxyParams.ProxyServer; LPort := ProxyParams.ProxyPort; if TextIsSame(URL.Protocol, 'HTTPS') then begin {do not localize} Result := ctSSLProxy; end else begin Result := ctProxy; end; end else begin if Assigned(Socket) then begin if Assigned(Socket.Binding) then begin if URL.IPVersion <> Socket.Binding.IPVersion then begin if Connected then begin Disconnect; // get rid of current socket handle end; end; end; end; LHost := URL.Host; LPort := IndyStrToInt(URL.Port, IdPORT_HTTP); if (not TextIsSame(FHost, LHost)) or (LPort <> FPort) then begin if Connected then begin Disconnect; end; end; if TextIsSame(URL.Protocol, 'HTTPS') then begin {do not localize} Result := ctSSL; end else begin Result := ctNormal; end; end; Host := LHost; Port := LPort; end; procedure TIdCustomHTTP.ReadResult(ARequest: TIdHTTPRequest; AResponse: TIdHTTPResponse); var LS: TStream; LOrigStream : TStream; LParseHTML : Boolean; LCreateTmpContent : Boolean; LDecMeth : Integer; //0 - no compression was used or we can't support that feature //1 - deflate //2 - gzip // under ARC, convert a weak reference to a strong reference before working with it LCompressor: TIdZLibCompressorBase; function CheckForPendingData(ATimeout: Integer): Boolean; begin if IOHandler.InputBufferIsEmpty then begin IOHandler.CheckForDataOnSource(ATimeout); end; Result := not IOHandler.InputBufferIsEmpty; end; function ShouldRead: Boolean; var CanRead: Boolean; begin Result := False; if IndyPos('chunked', LowerCase(AResponse.TransferEncoding)) > 0 then begin {do not localize} CanRead := True; end else if AResponse.HasContentLength then begin CanRead := AResponse.ContentLength > 0; // If chunked then this is also 0 end else if IsHeaderMediaType(AResponse.ContentType, 'multipart') then begin {do not localize} CanRead := not (hoNoReadMultipartMIME in FOptions); end else begin CanRead := True; end; if CanRead then begin // DO NOT READ IF THE REQUEST IS HEAD!!! // The server is supposed to send a 'Content-Length' header without sending // the actual data. 1xx, 204, and 304 replies are not supposed to contain // entity bodies, either... if TextIsSame(ARequest.Method, Id_HTTPMethodHead) or ({TextIsSame(ARequest.Method, Id_HTTPMethodPost) and} TextIsSame(ARequest.MethodOverride, Id_HTTPMethodHead)) or // TODO: check for 'X-HTTP-Method' and 'X-METHOD-OVERRIDE' request headers as well... ((AResponse.ResponseCode div 100) = 1) or (AResponse.ResponseCode = 204) or (AResponse.ResponseCode = 304) then begin // Have noticed one case where a non-conforming server did send an // entity body in response to a HEAD request. If requested, ignore // anything the server may send by accident if not (hoWaitForUnexpectedData in FOptions) then begin Exit; end; Result := CheckForPendingData(100); end else if (AResponse.ResponseCode div 100) = 3 then begin // This is a workaround for buggy HTTP 1.1 servers which // does not return any body with 302 response code Result := CheckForPendingData(5000); end else begin Result := True; end; end; end; function ChunkSize: integer; var j: Integer; s: string; begin s := InternalReadLn; j := IndyPos(';', s); {do not localize} if j > 0 then begin s := Copy(s, 1, j - 1); end; Result := IndyStrToInt('$' + Trim(s), 0); {do not localize} end; procedure ReadChunked; var LSize: Integer; LTrailHeader: String; begin DoStatus(hsStatusText, [RSHTTPChunkStarted]); BeginWork(wmRead); try LSize := ChunkSize; while LSize <> 0 do begin if Assigned(LS) then begin IOHandler.ReadStream(LS, LSize); end else begin IOHandler.Discard(LSize); end; InternalReadLn; // CRLF at end of chunk data LSize := ChunkSize; end; // read trailer headers LTrailHeader := InternalReadLn; while LTrailHeader <> '' do begin AResponse.RawHeaders.Add(LTrailHeader); LTrailHeader := InternalReadLn; end; finally EndWork(wmRead); end; end; procedure ReadMIME; var LMIMEBoundary: TIdBytes; LIndex: Integer; LSize: Integer; begin LMIMEBoundary := ToBytes('--' + ExtractHeaderSubItem(AResponse.ContentType, 'boundary', QuoteHTTP) + '--'); BeginWork(wmRead); try try repeat LIndex := IOHandler.InputBuffer.IndexOf(LMIMEBoundary); if LIndex <> -1 then begin LSize := LIndex + Length(LMIMEBoundary); if Assigned(LS) then begin IOHandler.ReadStream(LS, LSize); end else begin IOHandler.Discard(LSize); end; InternalReadLn; // CRLF at end of boundary Break; end; LSize := IOHandler.InputBuffer.Size - (Length(LMIMEBoundary)-1); if LSize > 0 then begin if Assigned(LS) then begin IOHandler.ReadStream(LS, LSize); end else begin IOHandler.Discard(LSize); end; end; IOHandler.CheckForDataOnSource; IOHandler.CheckForDisconnect(True, True); until False; except on E: EIdConnClosedGracefully do begin if Assigned(LS) then begin IOHandler.InputBuffer.ExtractToStream(LS); end else begin IOHandler.InputBuffer.Clear; end; end; end; finally EndWork(wmRead); end; end; begin if not ShouldRead then begin Exit; end; LDecMeth := 0; LParseHTML := Assigned(AResponse.ContentStream) and IsContentTypeHtml(AResponse) and not (hoNoParseMetaHTTPEquiv in FOptions); LCreateTmpContent := LParseHTML and not (AResponse.ContentStream is TCustomMemoryStream); LOrigStream := AResponse.ContentStream; if LCreateTmpContent then begin AResponse.ContentStream := TMemoryStream.Create; end; LCompressor := Compressor; try // we need to determine what type of decompression may need to be used // before we read from the IOHandler. If there is compression, then we // use a local stream to download the compressed data and decompress it. // If no compression is used, ContentStream will be used directly if Assigned(AResponse.ContentStream) then begin if Assigned(LCompressor) and LCompressor.IsReady then begin LDecMeth := PosInStrArray(AResponse.ContentEncoding, ['deflate', 'gzip'], False) + 1; {do not localize} end; if LDecMeth > 0 then begin LS := TMemoryStream.Create; end else begin LS := AResponse.ContentStream; end; end else begin LS := nil; end; try if IndyPos('chunked', LowerCase(AResponse.TransferEncoding)) > 0 then begin {do not localize} ReadChunked; end else if AResponse.HasContentLength then begin if AResponse.ContentLength > 0 then begin// If chunked then this is also 0 try if Assigned(LS) then begin IOHandler.ReadStream(LS, AResponse.ContentLength); end else begin IOHandler.Discard(AResponse.ContentLength); end; except // should this be caught here? We are being told the size, so a // premature disconnect should be an error, right? on E: EIdConnClosedGracefully do begin end; end; end; end else if IsHeaderMediaType(AResponse.ContentType, 'multipart') then begin {do not localize} ReadMIME; end else begin if Assigned(LS) then begin IOHandler.ReadStream(LS, -1, True); end else begin IOHandler.DiscardAll; end; end; if LDecMeth > 0 then begin LS.Position := 0; case LDecMeth of 1 : LCompressor.DecompressDeflateStream(LS, AResponse.ContentStream); 2 : LCompressor.DecompressGZipStream(LS, AResponse.ContentStream); end; end; finally if LDecMeth > 0 then begin FreeAndNil(LS); end; end; if LParseHTML then begin AResponse.ProcessMetaHTTPEquiv; end; finally if LCreateTmpContent then begin try LOrigStream.CopyFrom(AResponse.ContentStream, 0); finally {$IFNDEF USE_OBJECT_ARC} AResponse.ContentStream.Free; {$ENDIF} AResponse.ContentStream := LOrigStream; end; end; end; end; // TODO: move the XML charset detector below to the IdGlobalProtocols unit so // it can be used in other components, like TIdMessageClient and TIdIMAP4... type XmlEncoding = (xmlUCS4BE, xmlUCS4BEOdd, xmlUCS4LE, xmlUCS4LEOdd, xmlUTF16BE, xmlUTF16LE, xmlUTF8, xmlEBCDIC, xmlUnknown ); XmlBomInfo = record Charset: String; BOMLen: Integer; BOM: UInt32; BOMMask: UInt32; end; XmlNonBomInfo = record CharLen: Integer; FirstChar: UInt32; LastChar: UInt32; CharMask: UInt32; end; const XmlBOMs: array[xmlUCS4BE..xmlUTF8] of XmlBomInfo = ( (Charset: 'UCS-4BE'; BOMLen: 4; BOM: $0000FEFF; BOMMask: $FFFFFFFF), {do not localize} (Charset: ''; {UCS-4} BOMLen: 4; BOM: $0000FFFE; BOMMask: $FFFFFFFF), (Charset: 'UCS-4LE'; BOMLen: 4; BOM: $FFFE0000; BOMMask: $FFFFFFFF), {do not localize} (Charset: ''; {UCS-4} BOMLen: 4; BOM: $FEFF0000; BOMMask: $FFFFFFFF), (Charset: 'UTF-16BE'; BOMLen: 2; BOM: $FEFF0000; BOMMask: $FFFF0000), {do not localize} (Charset: 'UTF-16LE'; BOMLen: 2; BOM: $FFFE0000; BOMMask: $FFFF0000), {do not localize} (Charset: 'UTF-8'; BOMLen: 3; BOM: $EFBBBF00; BOMMask: $FFFFFF00) {do not localize} ); XmlNonBOMs: array[xmlUCS4BE..xmlEBCDIC] of XmlNonBomInfo = ( (CharLen: 4; FirstChar: $0000003C; LastChar: $0000003E; CharMask: $FFFFFFFF), (CharLen: 4; FirstChar: $00003C00; LastChar: $00003E00; CharMask: $FFFFFFFF), (CharLen: 4; FirstChar: $3C000000; LastChar: $3E000000; CharMask: $FFFFFFFF), (CharLen: 4; FirstChar: $003C0000; LastChar: $003E0000; CharMask: $FFFFFFFF), (CharLen: 2; FirstChar: $003C003F; LastChar: $003E0000; CharMask: $FFFF0000), (CharLen: 2; FirstChar: $3C003F00; LastChar: $3E000000; CharMask: $FFFF0000), (CharLen: 1; FirstChar: $3C3F786D; LastChar: $3E000000; CharMask: $FF000000), (CharLen: 1; FirstChar: $4C6FA794; LastChar: $6E000000; CharMask: $FF000000) ); XmlUCS4AsciiIndex: array[xmlUCS4BE..xmlUCS4LEOdd] of Integer = (3, 2, 0, 1); // RLebeau: only interested in EBCDIC ASCII characters that are allowed in // an XML declaration, we'll treat everything else as #01 for now... XmlEBCDICTable: array[Byte] of Char = ( { -0 -1 -2 -3 -4 -5 -6 -7 -8 -9 -A -B -C -D -E -F } {0-} #01, #01, #01, #01, #01, #09, #01, #01, #01, #01, #01, #01, #01, #13, #01, #01, {do not localize} {1-} #01, #01, #01, #01, #01, #01, #01, #01, #01, #01, #01, #01, #01, #01, #01, #01, {do not localize} {2-} #01, #01, #01, #01, #01, #10, #01, #01, #01, #01, #01, #01, #01, #01, #01, #01, {do not localize} {3-} #01, #01, #01, #01, #01, #01, #01, #01, #01, #01, #01, #01, #01, #01, #01, #01, {do not localize} {4-} ' ', #01, #01, #01, #01, #01, #01, #01, #01, #01, #01, '.', '<', #01, #01, #01, {do not localize} {5-} #01, #01, #01, #01, #01, #01, #01, #01, #01, #01, #01, #01, #01, #01, #01, #01, {do not localize} {6-} '-', #01, #01, #01, #01, #01, #01, #01, #01, #01, #01, #01, #01, '_', '>', '?', {do not localize} {7-} #01, #01, #01, #01, #01, #01, #01, #01, #01, #01, #01, #01, #01, #27, '=', '"', {do not localize} {8-} #01, 'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', #01, #01, #01, #01, #01, #01, {do not localize} {9-} #01, 'j', 'k', 'l', 'm', 'n', 'o', 'p', 'q', 'r', #01, #01, #01, #01, #01, #01, {do not localize} {A-} #01, #01, 's', 't', 'u', 'v', 'w', 'x', 'y', 'z', #01, #01, #01, #01, #01, #01, {do not localize} {B-} #01, #01, #01, #01, #01, #01, #01, #01, #01, #01, #01, #01, #01, #01, #01, #01, {do not localize} {C-} #01, 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', #01, #01, #01, #01, #01, #01, {do not localize} {D-} #01, 'J', 'K', 'L', 'N', 'N', 'O', 'P', 'Q', 'R', #01, #01, #01, #01, #01, #01, {do not localize} {E-} #01, #01, 'S', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z', #01, #01, #01, #01, #01, #01, {do not localize} {F-} '0', '1', '2', '3', '4', '5', '6', '7', '8', '9', #01, #01, #01, #01, #01, #01 {do not localize} ); function DetectXmlCharset(AStream: TStream): String; var Buffer: TIdBytes; InBuf, StreamPos, CurPos: TIdStreamSize; XmlDec, XmlEnc: String; {$IFDEF STRING_IS_IMMUTABLE} LSB: TIdStringBuilder; {$ENDIF} I, Len: Integer; Enc: XmlEncoding; Signature: UInt32; function BufferToUInt32: UInt32; begin Result := (UInt32(Buffer[0]) shl 24) or (UInt32(Buffer[1]) shl 16) or (UInt32(Buffer[2]) shl 8) or UInt32(Buffer[3]); end; begin // XML's default encoding is UTF-8 unless specified otherwise, either // by a BOM or an explicit "encoding" in the XML's prolog... Result := 'UTF-8'; {do not localize} StreamPos := AStream.Position; try AStream.Position := 0; SetLength(Buffer, 4); FillBytes(Buffer, 4, $00); InBuf := ReadTIdBytesFromStream(AStream, Buffer, 4); if InBuf < 3 then begin Exit; end; Signature := BufferToUInt32; // check for known BOMs first... for Enc := Low(XmlBOMs) to High(XmlBOMs) do begin if (Signature and XmlBOMs[Enc].BOMMask) = XmlBOMs[Enc].BOM then begin Inc(StreamPos, XmlBOMs[Enc].BOMLen); Result := XmlBOMs[Enc].Charset; Exit; end; end; // check for non-BOM'ed encodings now... if InBuf <> 4 then begin Exit; end; XmlDec := ''; for Enc := Low(XmlNonBOMs) to High(XmlNonBOMs) do begin if Signature = XmlNonBOMs[Enc].FirstChar then begin FillBytes(Buffer, 4, $00); while (AStream.Size - AStream.Position) >= XmlNonBOMs[Enc].CharLen do begin ReadTIdBytesFromStream(AStream, Buffer, XmlNonBOMs[Enc].CharLen); Signature := BufferToUInt32; if (Signature and XmlNonBOMs[Enc].CharMask) = XmlNonBOMs[Enc].LastChar then begin CurPos := AStream.Position; AStream.Position := 0; case Enc of xmlUCS4BE, xmlUCS4LE, xmlUCS4BEOdd, xmlUCS4LEOdd: begin // TODO: create UCS-4 IIdTextEncoding implementations... Len := CurPos div XmlNonBOMs[Enc].CharLen; {$IFDEF STRING_IS_IMMUTABLE} LSB := TIdStringBuilder.Create(Len); {$ELSE} SetLength(XmlDec, Len); {$ENDIF} for I := 1 to Len do begin ReadTIdBytesFromStream(AStream, Buffer, XmlNonBOMs[Enc].CharLen); {$IFDEF STRING_IS_IMMUTABLE} LSB.Append(Char(Buffer[XmlUCS4AsciiIndex[Enc]])); {$ELSE} XmlDec[I] := Char(Buffer[XmlUCS4AsciiIndex[Enc]]); {$ENDIF} end; {$IFDEF STRING_IS_IMMUTABLE} XmlDec := LSB.ToString; LSB := nil; {$ENDIF} end; xmlUTF16BE: begin XmlDec := ReadStringFromStream(AStream, CurPos, IndyTextEncoding_UTF16BE); end; xmlUTF16LE: begin XmlDec := ReadStringFromStream(AStream, CurPos, IndyTextEncoding_UTF16LE); end; xmlUTF8: begin XmlDec := ReadStringFromStream(AStream, CurPos, IndyTextEncoding_UTF8); end; xmlEBCDIC: begin // TODO: create an EBCDIC IIdTextEncoding implementation... {$IFDEF STRING_IS_IMMUTABLE} Len := ReadTIdBytesFromStream(AStream, Buffer, CurPos); LSB := TStringBuilder.Create(Len); for I := 0 to Len-1 do begin LSB.Append(XmlEBCDICTable[Buffer[I]]); end; XmlDec := LSB.ToString; {$ELSE} XmlDec := ReadStringFromStream(AStream, CurPos, IndyTextEncoding_8Bit); for I := 1 to Length(XmlDec) do begin XmlDec[I] := XmlEBCDICTable[Byte(XmlDec[I])]; end; {$ENDIF} end; end; Break; end; end; Break; end; end; if XmlDec = '' then begin Exit; end; I := Pos('encoding', XmlDec); {do not localize} if I = 0 then begin Exit; end; XmlDec := TrimLeft(Copy(XmlDec, I+8, MaxInt)); if not CharEquals(XmlDec, 1, '=') then begin {do not localize} Exit; end; XmlDec := TrimLeft(Copy(XmlDec, 2, MaxInt)); if XmlDec = '' then begin Exit; end; if XmlDec[1] = #$27 then begin XmlDec := Copy(XmlDec, 2, MaxInt); XmlEnc := Fetch(XmlDec, #$27); end else if XmlDec[1] = '"' then begin XmlDec := Copy(XmlDec, 2, MaxInt); XmlEnc := Fetch(XmlDec, '"'); end; XmlEnc := Trim(XmlEnc); if XmlEnc = '' then begin Exit; end; Result := XmlEnc; finally AStream.Position := StreamPos; end; end; function TIdCustomHTTP.ResponseCharset: String; begin if IsContentTypeAppXml(Response) then begin // the media type is not a 'text/...' based XML type, so ignore the // charset from the headers, if present, and parse the XML itself... Result := DetectXmlCharset(Response.ContentStream); end else begin // RLebeau 1/30/2012: Response.CharSet is now updated at the time // when HTML content is parsed for tags ... // TODO: if the Charset is not specified, return an appropriate value // that is registered with IANA for the reported ContentType... Result := Response.CharSet; end; end; const Requires_HTTP_1_1: array[0..4] of String = (Id_HTTPMethodTrace, Id_HTTPMethodPut, Id_HTTPMethodOptions, Id_HTTPMethodDelete, Id_HTTPMethodPatch); procedure TIdCustomHTTP.PrepareRequest(ARequest: TIdHTTPRequest); var LURI: TIdURI; LHost: string; begin LURI := TIdURI.Create(ARequest.URL); try if Length(LURI.Username) > 0 then begin ARequest.Username := LURI.Username; ARequest.Password := LURI.Password; end; FURI.Username := ARequest.Username; FURI.Password := ARequest.Password; FURI.Path := ProcessPath(FURI.Path, LURI.Path); FURI.Document := LURI.Document; FURI.Params := LURI.Params; if Length(LURI.Host) > 0 then begin FURI.Host := LURI.Host; end; if Length(LURI.Protocol) > 0 then begin FURI.Protocol := LURI.Protocol; end // non elegant solution - to be recoded, only for pointing the bug / GREGOR else if TextIsSame(FURI.Protocol, 'https') then begin {do not localize} FURI.Protocol := 'https'; {do not localize} end else begin FURI.Protocol := 'http'; {do not localize} end; if Length(LURI.Port) > 0 then begin FURI.Port := LURI.Port; end else if TextIsSame(LURI.Protocol, 'http') then begin {do not localize} FURI.Port := IntToStr(IdPORT_HTTP); end else if TextIsSame(LURI.Protocol, 'https') then begin {do not localize} FURI.Port := IntToStr(IdPORT_https); end else if Length(FURI.Port) = 0 then begin raise EIdUnknownProtocol.Create(RSHTTPUnknownProtocol); end; if (TextIsSame(ARequest.Method, Id_HTTPMethodOptions) or TextIsSame(ARequest.MethodOverride, Id_HTTPMethodOptions)) and TextIsSame(LURI.Document, '*') then {do not localize} begin ARequest.URL := LURI.Document; end else begin // The URL part is not URL encoded at this place ARequest.URL := URL.GetPathAndParams; end; ARequest.IPVersion := LURI.IPVersion; FURI.IPVersion := ARequest.IPVersion; // Check for valid HTTP request methods if (PosInStrArray(ARequest.Method, Requires_HTTP_1_1, False) > -1) or (PosInStrArray(ARequest.MethodOverride, Requires_HTTP_1_1, False) > -1) then begin if ProtocolVersion <> pv1_1 then begin raise EIdException.Create(RSHTTPMethodRequiresVersion); end; end; if Assigned(ARequest.Source) then begin ARequest.ContentLength := ARequest.Source.Size; end else begin ARequest.ContentLength := -1; end; // RLebeau: wrap an IPv6 address in brackets, per RFC 2732, and RFC 3986 section 3.2.2... if (FURI.IPVersion = Id_IPv6) and (MakeCanonicalIPv6Address(FURI.Host) <> '') then begin LHost := '[' + FURI.Host + ']'; {do not localize} end else begin LHost := FURI.Host; end; if (TextIsSame(FURI.Protocol, 'http') and (FURI.Port = IntToStr(IdPORT_HTTP))) or {do not localize} (TextIsSame(FURI.Protocol, 'https') and (FURI.Port = IntToStr(IdPORT_https))) then {do not localize} begin ARequest.Host := LHost; end else begin ARequest.Host := LHost + ':' + FURI.Port; {do not localize} end; finally FreeAndNil(LURI); // Free URI Object end; end; procedure TIdCustomHTTP.CheckAndConnect(ARequest: TIdHTTPRequest; AResponse: TIdHTTPResponse); begin if not AResponse.KeepAlive then begin Disconnect; end; if Assigned(IOHandler) then begin IOHandler.InputBuffer.Clear; end; CheckForGracefulDisconnect(False); if not Connected then try IPVersion := FURI.IPVersion; case ARequest.UseProxy of ctNormal, ctProxy: begin if (IOHandler is TIdSSLIOHandlerSocketBase) then begin TIdSSLIOHandlerSocketBase(IOHandler).PassThrough := True; TIdSSLIOHandlerSocketBase(IOHandler).URIToCheck := FURI.URI; end; end; ctSSL, ctSSLProxy: begin // if an IOHandler has not been assigned yet, try to create a default SSL IOHandler object // // TODO: if an IOHandler has been assigned, but is not an SSL IOHandler, // release it and try to create a default SSL IOHandler object? // if IOHandler = nil then begin IOHandler := TIdIOHandler.TryMakeIOHandler(TIdSSLIOHandlerSocketBase, Self); if IOHandler = nil then begin raise EIdIOHandlerPropInvalid.Create(RSIOHandlerPropInvalid); end; IOHandler.OnStatus := OnStatus; ManagedIOHandler := True; end else if not (IOHandler is TIdSSLIOHandlerSocketBase) then begin raise EIdIOHandlerPropInvalid.Create(RSIOHandlerPropInvalid); end; TIdSSLIOHandlerSocketBase(IOHandler).URIToCheck := FURI.URI; TIdSSLIOHandlerSocketBase(IOHandler).PassThrough := (ARequest.UseProxy = ctSSLProxy); end; end; Connect; except on E: EIdSSLProtocolReplyError do begin Disconnect; raise; end; end; end; procedure TIdCustomHTTP.ConnectToHost(ARequest: TIdHTTPRequest; AResponse: TIdHTTPResponse); var LLocalHTTP: TIdHTTPProtocol; LUseConnectVerb: Boolean; // under ARC, convert a weak reference to a strong reference before working with it LCompressor: TIdZLibCompressorBase; LOldProxy: TIdHTTPConnectionType; LNewDest: string; begin LNewDest := URL.Host + ':' + URL.Port; LOldProxy := ARequest.FUseProxy; ARequest.FUseProxy := SetHostAndPort; if ARequest.UseProxy <> LOldProxy then begin if Connected then begin Disconnect; end; end else if (ARequest.UseProxy = ctSSLProxy) and (not TextIsSame(ARequest.Destination, LNewDest)) then begin if Connected then begin Disconnect; end; end; ARequest.Destination := LNewDest; LUseConnectVerb := False; case ARequest.UseProxy of ctNormal: begin if (ProtocolVersion = pv1_0) and (Length(ARequest.Connection) = 0) then begin ARequest.Connection := 'keep-alive'; {do not localize} end; end; ctSSL, ctSSLProxy: begin ARequest.Connection := ''; if ARequest.UseProxy = ctSSLProxy then begin // if already connected to an SSL proxy, DO NOT send another // CONNECT request, as it will be sent directly to the target // HTTP server and not to the proxy! LUseConnectVerb := not Connected; end; end; ctProxy: begin ARequest.URL := FURI.URI; if (ProtocolVersion = pv1_0) and (Length(ARequest.Connection) = 0) then begin ARequest.ProxyConnection := 'keep-alive'; {do not localize} end; if hoNonSSLProxyUseConnectVerb in FOptions then begin // if already connected to a proxy, DO NOT send another CONNECT // request, as it will be sent directly to the target HTTP server // and not to the proxy! LUseConnectVerb := not Connected; end; end; end; LCompressor := FCompressor; if Assigned(LCompressor) and LCompressor.IsReady then begin if IndyPos('deflate', ARequest.AcceptEncoding) = 0 then {do not localize} begin if ARequest.AcceptEncoding <> '' then begin {do not localize} ARequest.AcceptEncoding := ARequest.AcceptEncoding + ', deflate'; {do not localize} end else begin ARequest.AcceptEncoding := 'deflate'; {do not localize} end; end; if IndyPos('gzip', ARequest.AcceptEncoding) = 0 then {do not localize} begin if ARequest.AcceptEncoding <> '' then begin {do not localize} ARequest.AcceptEncoding := ARequest.AcceptEncoding + ', gzip'; {do not localize} end else begin ARequest.AcceptEncoding := 'gzip'; {do not localize} end; end; end; {$IFDEF USE_OBJECT_ARC}LCompressor := nil;{$ENDIF} // TODO: if AcceptEncoding is blank, DON'T set it to 'identity'! Oddly, // some faulty servers do not understand 'identity' when explicitly // stated. It is the default behavior when no "Accept-Encoding" header // is sent, so just let the server fallback to it normally... if IndyPos('identity', ARequest.AcceptEncoding) = 0 then begin {do not localize} if ARequest.AcceptEncoding <> '' then begin ARequest.AcceptEncoding := ARequest.AcceptEncoding + ', identity'; {do not localize} end else begin ARequest.AcceptEncoding := 'identity'; {do not localize} end; end; if LUseConnectVerb then begin LLocalHTTP := CreateProtocol; try LLocalHTTP.Request.UserAgent := ARequest.UserAgent; LLocalHTTP.Request.Host := ARequest.Host; LLocalHTTP.Request.Pragma := 'no-cache'; {do not localize} LLocalHTTP.Request.URL := ARequest.Destination; LLocalHTTP.Request.Method := Id_HTTPMethodConnect; LLocalHTTP.Request.ProxyConnection := 'keep-alive'; {do not localize} LLocalHTTP.Request.FUseProxy := ARequest.UseProxy; // leaving LLocalHTTP.Response.ContentStream set to nil so response data is discarded without wasting memory try repeat CheckAndConnect(LLocalHTTP.Request, LLocalHTTP.Response); LLocalHTTP.BuildAndSendRequest(nil); LLocalHTTP.Response.ResponseText := InternalReadLn; if Length(LLocalHTTP.Response.ResponseText) = 0 then begin // Support for HTTP responses without status line and headers LLocalHTTP.Response.ResponseText := 'HTTP/1.0 200 OK'; {do not localize} LLocalHTTP.Response.Connection := 'close'; {do not localize} end else begin LLocalHTTP.RetrieveHeaders(MaxHeaderLines); ProcessCookies(LLocalHTTP.Request, LLocalHTTP.Response); end; if (LLocalHTTP.Response.ResponseCode div 100) = 2 then begin // Connection established if (ARequest.UseProxy = ctSSLProxy) and (IOHandler is TIdSSLIOHandlerSocketBase) then begin TIdSSLIOHandlerSocketBase(IOHandler).PassThrough := False; end; Break; end else begin LLocalHTTP.ProcessResponse([]); end; until False; except raise; // TODO: Add property that will contain the error messages. end; finally FreeAndNil(LLocalHTTP); end; end else begin CheckAndConnect(ARequest, AResponse); end; FHTTPProto.BuildAndSendRequest(URL); // RLebeau 1/31/2008: in order for TIdWebDAV to post data correctly, don't // restrict which HTTP methods can post (except logically for GET and HEAD), // especially since TIdCustomHTTP.PrepareRequest() does not differentiate when // setting up the 'Content-Length' header ... // TODO: when sending an HTTP 1.1 request with an 'Expect: 100-continue' header, // do not send the Source data until the server replies with a 100 response code, // or until a timeout occurs if the server does not send a 100... if ARequest.Source <> nil then begin IOHandler.Write(ARequest.Source, 0, False); end; end; procedure TIdCustomHTTP.SetAllowCookies(AValue: Boolean); begin FAllowCookies := AValue; end; procedure TIdCustomHTTP.ProcessCookies(ARequest: TIdHTTPRequest; AResponse: TIdHTTPResponse); var LCookies: TStringList; // under ARC, convert a weak reference to a strong reference before working with it LCookieManager: TIdCookieManager; begin LCookieManager := FCookieManager; if (not Assigned(LCookieManager)) and AllowCookies then begin LCookieManager := TIdCookieManager.Create(Self); SetCookieManager(LCookieManager); FImplicitCookieManager := True; end; if Assigned(LCookieManager) and AllowCookies then begin LCookies := TStringList.Create; try AResponse.RawHeaders.Extract('Set-Cookie', LCookies); {do not localize} AResponse.MetaHTTPEquiv.RawHeaders.Extract('Set-Cookie', LCookies); {do not localize} LCookieManager.AddServerCookies(LCookies, FURI); finally FreeAndNil(LCookies); end; end; end; // under ARC, all weak references to a freed object get nil'ed automatically // so this is mostly redundant procedure TIdCustomHTTP.Notification(AComponent: TComponent; Operation: TOperation); begin if Operation = opRemove then begin if (AComponent = FCookieManager) then begin FCookieManager := nil; FImplicitCookieManager := False; end {$IFNDEF USE_OBJECT_ARC} else if (AComponent = FAuthenticationManager) then begin FAuthenticationManager := nil; end else if (AComponent = FCompressor) then begin FCompressor := nil; end {$ENDIF} ; end; inherited Notification(AComponent, Operation); end; procedure TIdCustomHTTP.SetCookieManager(ACookieManager: TIdCookieManager); var // under ARC, convert a weak reference to a strong reference before working with it LCookieManager: TIdCookieManager; begin LCookieManager := FCookieManager; if LCookieManager <> ACookieManager then begin // under ARC, all weak references to a freed object get nil'ed automatically if Assigned(LCookieManager) then begin if FImplicitCookieManager then begin FCookieManager := nil; FImplicitCookieManager := False; IdDisposeAndNil(LCookieManager); end else begin {$IFNDEF USE_OBJECT_ARC} LCookieManager.RemoveFreeNotification(Self); {$ENDIF} end; end; FCookieManager := ACookieManager; FImplicitCookieManager := False; {$IFNDEF USE_OBJECT_ARC} if Assigned(ACookieManager) then begin ACookieManager.FreeNotification(Self); end; {$ENDIF} end; end; function TIdCustomHTTP.DoOnAuthorization(ARequest: TIdHTTPRequest; AResponse: TIdHTTPResponse): Boolean; var i: Integer; S: string; LAuthCls: TIdAuthenticationClass; LAuth: TIdAuthentication; begin Inc(FAuthRetries); if not Assigned(ARequest.Authentication) then begin // Find wich Authentication method is supported from us. LAuthCls := nil; for i := 0 to AResponse.WWWAuthenticate.Count - 1 do begin S := AResponse.WWWAuthenticate[i]; LAuthCls := FindAuthClass(Fetch(S)); if Assigned(LAuthCls) then begin Break; end; end; // let the user override us, if desired. if Assigned(FOnSelectAuthorization) then begin OnSelectAuthorization(Self, LAuthCls, AResponse.WWWAuthenticate); end; if not Assigned(LAuthCls) then begin Result := False; Exit; end; ARequest.Authentication := LAuthCls.Create; end; { this is commented out as it breaks SSPI and NTLM authentication. it is normal and expected to get multiple 407 responses during negotiation. // Clear password and reset autorization if previous failed if (AResponse.FResponseCode = 401) then begin ARequest.Password := ''; ARequest.Authentication.Reset; end; } // S.G. 20/10/2003: Added part about the password. Not testing user name as some // S.G. 20/10/2003: web sites do not require user name, only password. // // RLebeau 11/18/2014: what about SSPI? It does not require an explicit // username/password as it can use the identity of the user token associated // with the calling thread! // Result := Assigned(FOnAuthorization) or (Trim(ARequest.Password) <> ''); if not Result then begin Exit; end; LAuth := ARequest.Authentication; LAuth.Username := ARequest.Username; LAuth.Password := ARequest.Password; // S.G. 20/10/2003: ToDo: We need to have a marker here to prevent the code to test with the same username/password combo // S.G. 20/10/2003: if they are picked up from properties. LAuth.Params.Values['Authorization'] := ARequest.Authentication.Authentication; {do not localize} LAuth.AuthParams := AResponse.WWWAuthenticate; Result := False; repeat case LAuth.Next of wnAskTheProgram: begin // Ask the user porgram to supply us with authorization information if Assigned(FOnAuthorization) then begin LAuth.UserName := ARequest.Username; LAuth.Password := ARequest.Password; OnAuthorization(Self, LAuth, Result); if Result then begin ARequest.BasicAuthentication := True; ARequest.Username := LAuth.UserName; ARequest.Password := LAuth.Password; end else begin Break; end; end; end; wnDoRequest: begin Result := True; Break; end; wnFail: begin Result := False; Break; end; end; until False; end; function TIdCustomHTTP.DoOnProxyAuthorization(ARequest: TIdHTTPRequest; AResponse: TIdHTTPResponse): Boolean; var i: Integer; S: string; LAuthCls: TIdAuthenticationClass; LAuth: TIdAuthentication; begin Inc(FAuthProxyRetries); if not Assigned(ProxyParams.Authentication) then begin // Find which Authentication method is supported from us. LAuthCls := nil; for i := 0 to AResponse.ProxyAuthenticate.Count-1 do begin S := AResponse.ProxyAuthenticate[i]; LAuthCls := FindAuthClass(Fetch(S)); if Assigned(LAuthCls) then begin Break; end; end; // let the user override us, if desired. if Assigned(FOnSelectProxyAuthorization) then begin OnSelectProxyAuthorization(Self, LAuthCls, AResponse.ProxyAuthenticate); end; if not Assigned(LAuthCls) then begin Result := False; Exit; end; ProxyParams.Authentication := LAuthCls.Create; end; { this is commented out as it breaks SSPI and NTLM authentication. it is normal and expected to get multiple 407 responses during negotiation. // Clear password and reset authorization if previous failed if (AResponse.FResponseCode = 407) then begin ProxyParams.ProxyPassword := ''; ProxyParams.Authentication.Reset; end; } // RLebeau 11/18/2014: Added part about the password. Not testing user name // as some proxies do not require user name, only password. // // RLebeau 11/18/2014: what about SSPI? It does not require an explicit // username/password as it can use the identity of the user token associated // with the calling thread! // Result := Assigned(OnProxyAuthorization) or (Trim(ProxyParams.ProxyPassword) <> ''); if not Result then begin Exit; end; LAuth := ProxyParams.Authentication; LAuth.Username := ProxyParams.ProxyUsername; LAuth.Password := ProxyParams.ProxyPassword; // TODO: do we need to set this, like DoOnAuthorization does? //LAuth.Params.Values['Authorization'] := ProxyParams.Authentication; {do not localize} LAuth.AuthParams := AResponse.ProxyAuthenticate; Result := False; repeat case LAuth.Next of wnAskTheProgram: // Ask the user porgram to supply us with authorization information begin if Assigned(OnProxyAuthorization) then begin LAuth.Username := ProxyParams.ProxyUsername; LAuth.Password := ProxyParams.ProxyPassword; OnProxyAuthorization(Self, LAuth, Result); if Result then begin // TODO: do we need to set this, like DoOnAuthorization does? //ProxyParams.BasicAuthentication := True; ProxyParams.ProxyUsername := LAuth.Username; ProxyParams.ProxyPassword := LAuth.Password; end else begin Break; end; end; end; wnDoRequest: begin Result := True; Break; end; wnFail: begin Result := False; Break; end; end; until False; end; function TIdCustomHTTP.GetResponseCode: Integer; begin Result := Response.ResponseCode; end; function TIdCustomHTTP.GetResponseText: string; begin Result := Response.ResponseText; end; function TIdCustomHTTP.GetResponse: TIdHTTPResponse; begin Result := FHTTPProto.Response; end; function TIdCustomHTTP.GetRequest: TIdHTTPRequest; begin Result := FHTTPProto.Request; end; function TIdCustomHTTP.GetMetaHTTPEquiv: TIdMetaHTTPEquiv; begin Result := Response.MetaHTTPEquiv; end; procedure TIdCustomHTTP.DoOnDisconnected; var // under ARC, convert a weak reference to a strong reference before working with it LAuthManager: TIdAuthenticationManager; begin inherited DoOnDisconnected; if Assigned(Request.Authentication) and (Request.Authentication.CurrentStep = Request.Authentication.Steps) then begin LAuthManager := AuthenticationManager; if Assigned(LAuthManager) then begin LAuthManager.AddAuthentication(Request.Authentication, URL); end; {$IFNDEF USE_OBJECT_ARC} Request.Authentication.Free; {$ENDIF} Request.Authentication := nil; end; if Assigned(ProxyParams.Authentication) and (ProxyParams.Authentication.CurrentStep = ProxyParams.Authentication.Steps) then begin ProxyParams.Authentication.Reset; end; end; procedure TIdCustomHTTP.SetAuthenticationManager(Value: TIdAuthenticationManager); begin {$IFDEF USE_OBJECT_ARC} // under ARC, all weak references to a freed object get nil'ed automatically FAuthenticationManager := Value; {$ELSE} if FAuthenticationManager <> Value then begin if Assigned(FAuthenticationManager) then begin FAuthenticationManager.RemoveFreeNotification(self); end; FAuthenticationManager := Value; if Assigned(FAuthenticationManager) then begin FAuthenticationManager.FreeNotification(Self); end; end; {$ENDIF} end; { procedure TIdCustomHTTP.SetHost(const Value: string); begin inherited SetHost(Value); URL.Host := Value; end; procedure TIdCustomHTTP.SetPort(const Value: integer); begin inherited SetPort(Value); URL.Port := IntToStr(Value); end; } procedure TIdCustomHTTP.SetRequest(Value: TIdHTTPRequest); begin FHTTPProto.Request.Assign(Value); end; procedure TIdCustomHTTP.SetProxyParams(AValue: TIdProxyConnectionInfo); begin FProxyParameters.Assign(AValue); end; procedure TIdCustomHTTP.Post(AURL: string; ASource: TIdMultiPartFormDataStream; AResponseContent: TStream); begin Assert(ASource<>nil); Request.ContentType := ASource.RequestContentType; // TODO: Request.CharSet := ASource.RequestCharSet; Post(AURL, TStream(ASource), AResponseContent); end; function TIdCustomHTTP.Post(AURL: string; ASource: TIdMultiPartFormDataStream {$IFDEF STRING_IS_ANSI}; ADestEncoding: IIdTextEncoding = nil{$ENDIF} ): string; begin Assert(ASource<>nil); Request.ContentType := ASource.RequestContentType; // TODO: Request.CharSet := ASource.RequestCharSet; Result := Post(AURL, TStream(ASource){$IFDEF STRING_IS_ANSI}, ADestEncoding{$ENDIF}); end; { TIdHTTPResponse } constructor TIdHTTPResponse.Create(AHTTP: TIdCustomHTTP); begin inherited Create(AHTTP); FHTTP := AHTTP; FResponseCode := -1; FMetaHTTPEquiv := TIdMetaHTTPEquiv.Create(AHTTP); end; destructor TIdHTTPResponse.Destroy; begin FreeAndNil(FMetaHTTPEquiv); inherited Destroy; end; procedure TIdHTTPResponse.Clear; begin inherited Clear; FMetaHTTPEquiv.Clear; end; procedure TIdHTTPResponse.ProcessMetaHTTPEquiv; var StdValues: TStringList; I: Integer; Name: String; begin FMetaHTTPEquiv.ProcessMetaHTTPEquiv(ContentStream); if FMetaHTTPEquiv.RawHeaders.Count > 0 then begin // TODO: optimize this StdValues := TStringList.Create; try FMetaHTTPEquiv.RawHeaders.ConvertToStdValues(StdValues); for I := 0 to StdValues.Count-1 do begin Name := StdValues.Names[I]; if Name <> '' then begin RawHeaders.Values[Name] := IndyValueFromIndex(StdValues, I); end; end; finally StdValues.Free; end; ProcessHeaders; end; if FMetaHTTPEquiv.CharSet <> '' then begin FCharSet := FMetaHTTPEquiv.CharSet; end; end; function TIdHTTPResponse.GetKeepAlive: Boolean; begin if FHTTP.Connected then begin FHTTP.IOHandler.CheckForDisconnect(False); end; FKeepAlive := FHTTP.Connected; if FKeepAlive then begin case FHTTP.ProtocolVersion of // TODO: use ResponseVersion instead? pv1_1: { By default we assume that keep-alive is by default and will close the connection only there is "close" } begin FKeepAlive := not ( TextIsSame(Trim(Connection), 'CLOSE') or {do not localize} TextIsSame(Trim(ProxyConnection), 'CLOSE') {do not localize} ); end; pv1_0: { By default we assume that keep-alive is not by default and will keep the connection only if there is "keep-alive" } begin FKeepAlive := TextIsSame(Trim(Connection), 'KEEP-ALIVE') or {do not localize} TextIsSame(Trim(ProxyConnection), 'KEEP-ALIVE') {do not localize} { or ((ResponseVersion = pv1_1) and (Length(Trim(Connection)) = 0) and (Length(Trim(ProxyConnection)) = 0)) }; end; end; end; Result := FKeepAlive; end; function TIdHTTPResponse.GetResponseCode: Integer; var S, Tmp: string; begin if FResponseCode = -1 then begin S := FResponseText; Fetch(S); S := Trim(S); // RLebeau: IIS supports status codes with decimals in them, but it is not supposed to // transmit them to clients, which is a violation of RFC 2616. But have seen it happen, // so check for it... Tmp := Fetch(S, ' ', False); {do not localize} S := Fetch(Tmp, '.', False); {do not localize} FResponseCode := IndyStrToInt(S, -1); end; Result := FResponseCode; end; procedure TIdHTTPResponse.SetResponseText(const AValue: String); var S: String; i: TIdHTTPProtocolVersion; begin FResponseText := AValue; FResponseCode := -1; // re-parse the next time it is accessed ResponseVersion := pv1_0; // default until determined otherwise... S := Copy(FResponseText, 6, 3); for i := Low(TIdHTTPProtocolVersion) to High(TIdHTTPProtocolVersion) do begin if TextIsSame(ProtocolVersionString[i], S) then begin ResponseVersion := i; Exit; end; end; end; { TIdHTTPRequest } constructor TIdHTTPRequest.Create(AHTTP: TIdCustomHTTP); begin inherited Create(AHTTP); FHTTP := AHTTP; FUseProxy := ctNormal; end; { TIdHTTPProtocol } constructor TIdHTTPProtocol.Create(AConnection: TIdCustomHTTP); begin inherited Create; FHTTP := AConnection; // Create the headers FRequest := TIdHTTPRequest.Create(FHTTP); FResponse := TIdHTTPResponse.Create(FHTTP); end; destructor TIdHTTPProtocol.Destroy; begin FreeAndNil(FRequest); FreeAndNil(FResponse); inherited Destroy; end; procedure TIdHTTPProtocol.BuildAndSendRequest(AURI: TIdURI); var i: Integer; LBufferingStarted: Boolean; begin // needed for Digest authentication, but maybe others as well... if Assigned(Request.Authentication) then begin // TODO: include entity body for Digest "auth-int" qop... Request.Authentication.SetRequest(Request.Method, Request.URL); end; // TODO: disable header folding for HTTP 1.0 requests Request.SetHeaders; FHTTP.ProxyParams.SetHeaders(Request.RawHeaders); if Assigned(AURI) then begin FHTTP.SetCookies(AURI, Request); end; // This is a workaround for some HTTP servers which do not implement // the HTTP protocol properly LBufferingStarted := not FHTTP.IOHandler.WriteBufferingActive; if LBufferingStarted then begin FHTTP.IOHandler.WriteBufferOpen; end; try FHTTP.IOHandler.WriteLn(Request.Method + ' ' + Request.URL + ' HTTP/' + ProtocolVersionString[FHTTP.ProtocolVersion]); {do not localize} // write the headers for i := 0 to Request.RawHeaders.Count - 1 do begin if Length(Request.RawHeaders.Strings[i]) > 0 then begin FHTTP.IOHandler.WriteLn(Request.RawHeaders.Strings[i]); end; end; FHTTP.IOHandler.WriteLn(''); {do not localize} if LBufferingStarted then begin FHTTP.IOHandler.WriteBufferClose; end; except if LBufferingStarted then begin FHTTP.IOHandler.WriteBufferCancel; end; raise; end; end; procedure TIdHTTPProtocol.RetrieveHeaders(AMaxHeaderCount: integer); var s: string; LHeaderCount: Integer; begin // Set the response headers // Clear headers // Don't use Capture. // S.G. 6/4/2004: Added AmaxHeaderCount parameter to prevent the "header bombing" of the server Response.Clear; s := FHTTP.InternalReadLn; try LHeaderCount := 0; while (s <> '') and ( (AMaxHeaderCount > 0) or (LHeaderCount < AMaxHeaderCount) ) do begin Response.RawHeaders.Add(S); s := FHTTP.InternalReadLn; Inc(LHeaderCount); end; except on E: EIdConnClosedGracefully do begin FHTTP.Disconnect; end else begin raise; end; end; Response.ProcessHeaders; end; function TIdHTTPProtocol.ProcessResponse(AIgnoreReplies: array of Int16): TIdHTTPWhatsNext; var LResponseCode, LResponseDigit: Integer; procedure CheckException; var i: Integer; LTempResponse: TMemoryStream; LTempStream: TStream; begin LTempResponse := TMemoryStream.Create; try LTempStream := Response.ContentStream; Response.ContentStream := LTempResponse; try try FHTTP.ReadResult(Request, Response); except on E: EIdConnClosedGracefully do begin FHTTP.Disconnect; end; end; if hoNoProtocolErrorException in FHTTP.HTTPOptions then begin Exit; end; if High(AIgnoreReplies) > -1 then begin for i := Low(AIgnoreReplies) to High(AIgnoreReplies) do begin if LResponseCode = AIgnoreReplies[i] then begin Exit; end; end; end; LTempResponse.Position := 0; raise EIdHTTPProtocolException.CreateError(LResponseCode, FHTTP.ResponseText, ReadStringAsCharset(LTempResponse, FHTTP.ResponseCharSet)); finally Response.ContentStream := LTempStream; end; finally FreeAndNil(LTempResponse); end; end; procedure DiscardContent; var LOrigStream: TStream; begin LOrigStream := Response.ContentStream; Response.ContentStream := nil; try try FHTTP.ReadResult(Request, Response); except on E: EIdConnClosedGracefully do begin FHTTP.Disconnect; end; end; finally Response.ContentStream := LOrigStream; end; end; function HeadersCanContinue: Boolean; begin Result := True; if Assigned(FHTTP.OnHeadersAvailable) then begin FHTTP.OnHeadersAvailable(FHTTP, Response.RawHeaders, Result); end; end; var LLocation: string; LMethod: TIdHTTPMethod; LNeedAuth: Boolean; //LTemp: Integer; begin // provide the user with the headers and let the user decide // whether the response processing should continue... if not HeadersCanContinue then begin Response.KeepAlive := False; // TODO: provide the user an option whether to force DoRequest() to disconnect the connection or not Result := wnJustExit; Exit; end; // Cache this as ResponseCode calls GetResponseCode which parses it out LResponseCode := Response.ResponseCode; LResponseDigit := LResponseCode div 100; LNeedAuth := False; // Handle Redirects // RLebeau: All 3xx replies other than 304 are redirects. Reply 201 has a // Location header but is NOT a redirect! // RLebeau 4/21/2011: Amazon S3 includes a Location header in its 200 reply // to some PUT requests. Not sure if this is a bug or intentional, but we // should NOT perform a redirect for any replies other than 3xx. Amazon S3 // does NOT include a Location header in its 301 reply, though! This is // intentional, per Amazon's documentation, as a way for developers to // detect when URLs are addressed incorrectly... if (LResponseDigit = 3) and (LResponseCode <> 304) then begin if Response.Location = '' then begin CheckException; Result := wnJustExit; Exit; end; Inc(FHTTP.FRedirectCount); // LLocation := TIdURI.URLDecode(Response.Location); LLocation := Response.Location; LMethod := Request.Method; // fire the event if not FHTTP.DoOnRedirect(LLocation, LMethod, FHTTP.FRedirectCount) then begin CheckException; Result := wnJustExit; Exit; end; if (FHTTP.FHandleRedirects) and (FHTTP.FRedirectCount < FHTTP.FRedirectMax) then begin Result := wnGoToURL; Request.URL := LLocation; // GDG 21/11/2003. If it's a 303, we should do a get this time // RLebeau 7/15/2004 - do a GET on 302 as well, as mentioned in RFC 2616 // RLebeau 1/11/2008 - turns out both situations are WRONG! RFCs 2068 and // 2616 specifically state that changing the method to GET in response // to 302 and 303 is errorneous. Indy 9 did it right by reusing the // original method and source again and only changing the URL, so lets // revert back to that same behavior! // RLebeau 12/28/2012 - one more time. RFCs 2068 and 2616 actually say that // changing the method in response to 302 is erroneous, but changing the // method to GET in response to 303 is intentional and why 303 was introduced // in the first place. Erroneous clients treat 302 as 303, though. Now // encountering servers that actually expect this 303 behavior, so we have // to enable it again! Adding an optional HTTPOption flag so clients can // enable the erroneous 302 behavior if they really need it. if ((LResponseCode = 302) and (hoTreat302Like303 in FHTTP.HTTPOptions)) or (LResponseCode = 303) then begin Request.Source := nil; Request.Method := Id_HTTPMethodGet; end else begin Request.Method := LMethod; end; Request.MethodOverride := ''; end else begin Result := wnJustExit; Response.Location := LLocation; end; if FHTTP.Connected then begin // This is a workaround for buggy HTTP 1.1 servers which // does not return any body with 302 response code DiscardContent; // may wait a few seconds for any kind of content end; end else begin //Ciaran, 30th Nov 2004: I commented out the following code. When a https server //sends a disconnect immediately after sending the requested page in an SSL //session (which they sometimes do to indicate a "session" is finished), the code //below causes a "Connection closed gracefully" exception BUT the returned page //is lost (IOHandler.Request is empty). If the code below is re-enabled by //someone for whatever reason, they MUST test for this case. // GREGOR Workaround // if we get an error we disconnect if we use SSLIOHandler //if Assigned(FHTTP.IOHandler) then //begin // Response.KeepAlive := not (FHTTP.Connected and (FHTTP.IOHandler is TIdSSLIOHandlerSocketBase) and Response.KeepAlive); //end; // RLebeau 2/15/2006: RFC 1945 states the following: // // For response messages, whether or not an entity body is included with // a message is dependent on both the request method and the response // code. All responses to the HEAD request method must not include a // body, even though the presence of entity header fields may lead one // to believe they do. All 1xx (informational), 204 (no content), and // 304 (not modified) responses must not include a body. All other // responses must include an entity body or a Content-Length header // field defined with a value of zero (0). if LResponseDigit <> 2 then begin case LResponseCode of 401: begin // HTTP Server authorization required if (FHTTP.AuthRetries >= FHTTP.MaxAuthRetries) or (not FHTTP.DoOnAuthorization(Request, Response)) then begin if Assigned(Request.Authentication) then begin Request.Authentication.Reset; end; CheckException; Result := wnJustExit; Exit; end else begin LNeedAuth := hoInProcessAuth in FHTTP.HTTPOptions; end; end; 407: begin // Proxy Server authorization requered if (FHTTP.AuthProxyRetries >= FHTTP.MaxAuthRetries) or (not FHTTP.DoOnProxyAuthorization(Request, Response)) then begin if Assigned(FHTTP.ProxyParams.Authentication) then begin FHTTP.ProxyParams.Authentication.Reset; end; CheckException; Result := wnJustExit; Exit; end else begin LNeedAuth := hoInProcessAuth in FHTTP.HTTPOptions; end; end; else begin CheckException; Result := wnJustExit; Exit; end; end; end; if LNeedAuth then begin // discard the content of Error message DiscardContent; Result := wnAuthRequest; end else begin // RLebeau 6/30/2006: DO NOT READ IF THE REQUEST IS HEAD!!! // The server is supposed to send a 'Content-Length' header // without sending the actual data... if TextIsSame(Request.Method, Id_HTTPMethodHead) or TextIsSame(Request.MethodOverride, Id_HTTPMethodHead) or (LResponseCode = 204) then begin // Have noticed one case where a non-conforming server did send an // entity body in response to a HEAD request. If requested, ignore // anything the server may send by accident DiscardContent; end else begin FHTTP.ReadResult(Request, Response); end; Result := wnJustExit; end; end; end; function TIdCustomHTTP.CreateProtocol: TIdHTTPProtocol; begin Result := TIdHTTPProtocol.Create(Self); end; procedure TIdCustomHTTP.InitComponent; begin inherited; FURI := TIdURI.Create(''); FAuthRetries := 0; FAuthProxyRetries := 0; AllowCookies := True; FImplicitCookieManager := False; FOptions := [hoForceEncodeParams]; FRedirectMax := Id_TIdHTTP_RedirectMax; FHandleRedirects := Id_TIdHTTP_HandleRedirects; // FProtocolVersion := Id_TIdHTTP_ProtocolVersion; FHTTPProto := CreateProtocol; FProxyParameters := TIdProxyConnectionInfo.Create; FProxyParameters.Clear; FMaxAuthRetries := Id_TIdHTTP_MaxAuthRetries; FMaxHeaderLines := Id_TIdHTTP_MaxHeaderLines; end; function TIdCustomHTTP.InternalReadLn: String; begin Result := IOHandler.ReadLn; if IOHandler.ReadLnTimedout then begin raise EIdReadTimeout.Create(RSReadTimeout); end; end; function TIdCustomHTTP.Get(AURL: string; AIgnoreReplies: array of Int16 {$IFDEF STRING_IS_ANSI}; ADestEncoding: IIdTextEncoding = nil{$ENDIF} ): string; var LStream: TMemoryStream; begin LStream := TMemoryStream.Create; try Get(AURL, LStream, AIgnoreReplies); LStream.Position := 0; Result := ReadStringAsCharset(LStream, ResponseCharset{$IFDEF STRING_IS_ANSI}, ADestEncoding{$ENDIF}); // TODO: if the data is XML, add/update the declared encoding to 'UTF-16LE'... finally FreeAndNil(LStream); end; end; procedure TIdCustomHTTP.Get(AURL: string; AResponseContent: TStream; AIgnoreReplies: array of Int16); begin DoRequest(Id_HTTPMethodGet, AURL, nil, AResponseContent, AIgnoreReplies); end; procedure TIdCustomHTTP.DoRequest(const AMethod: TIdHTTPMethod; AURL: string; ASource, AResponseContent: TStream; AIgnoreReplies: array of Int16); var LResponseLocation: TIdStreamSize; begin //reset any counters FRedirectCount := 0; FAuthRetries := 0; FAuthProxyRetries := 0; if Assigned(AResponseContent) then begin LResponseLocation := AResponseContent.Position; end else begin LResponseLocation := 0; // Just to avoid the warning message end; Request.URL := AURL; Request.Method := AMethod; Request.Source := ASource; Response.ContentStream := AResponseContent; try repeat PrepareRequest(Request); if IOHandler is TIdSSLIOHandlerSocketBase then begin TIdSSLIOHandlerSocketBase(IOHandler).URIToCheck := FURI.URI; end; ConnectToHost(Request, Response); // Workaround for servers wich respond with 100 Continue on GET and HEAD // This workaround is just for temporary use until we have final HTTP 1.1 // realisation. HTTP 1.1 is ongoing because of all the buggy and conflicting servers. repeat Response.ResponseText := InternalReadLn; FHTTPProto.RetrieveHeaders(MaxHeaderLines); ProcessCookies(Request, Response); until Response.ResponseCode <> 100; case FHTTPProto.ProcessResponse(AIgnoreReplies) of wnAuthRequest: begin Request.URL := AURL; end; wnReadAndGo: begin ReadResult(Request, Response); if Assigned(AResponseContent) then begin AResponseContent.Position := LResponseLocation; AResponseContent.Size := LResponseLocation; end; FAuthRetries := 0; FAuthProxyRetries := 0; end; wnGoToURL: begin if Assigned(AResponseContent) then begin AResponseContent.Position := LResponseLocation; AResponseContent.Size := LResponseLocation; end; FAuthRetries := 0; FAuthProxyRetries := 0; end; wnJustExit: begin Break; end; wnDontKnow: begin raise EIdException.Create(RSHTTPNotAcceptable); end; end; until False; finally if not Response.KeepAlive then begin // TODO: do not disconnect if hoNoReadMultipartMIME is in effect Disconnect; end; end; end; procedure TIdCustomHTTP.Patch(AURL: string; ASource, AResponseContent: TStream); begin DoRequest(Id_HTTPMethodPatch, AURL, ASource, AResponseContent, []); end; function TIdCustomHTTP.Patch(AURL: string; ASource: TStream {$IFDEF STRING_IS_ANSI}; ADestEncoding: IIdTextEncoding = nil{$ENDIF} ): string; var LResponse: TMemoryStream; begin LResponse := TMemoryStream.Create; try Patch(AURL, ASource, LResponse); LResponse.Position := 0; Result := ReadStringAsCharset(LResponse, ResponseCharset{$IFDEF STRING_IS_ANSI}, ADestEncoding{$ENDIF}); // TODO: if the data is XML, add/update the declared encoding to 'UTF-16LE'... finally FreeAndNil(LResponse); end; end; end.