{ $HDR$} {**********************************************************************} { Unit archived using Team Coherence } { Team Coherence is Copyright 2002 by Quality Software Components } { } { For further information / comments, visit our WEB site at } { http://www.TeamCoherence.com } {**********************************************************************} {} { $Log: 10191: IdHTTP.pas { { Rev 1.8 7/22/04 3:59:44 PM RLebeau { FindAuthClass() bug fix for TIdCustomHTTP.DoOnProxyAuthorization() } { { Rev 1.7 4/28/04 1:45:54 PM RLebeau { Updated TIdCustomHTTP.SetRequestParams() to strip off the trailing CRLF { before encoding rather than afterwards } { { Rev 1.6 29/11/2003 7:37:02 AM GGrieve { make TIdHTTPHeaderInfo.authentication a property and destroy it } { { Rev 1.5 17.7.2003 ã. 22:27:48 DBondzhev { Added domain name for authorizing against MS Proxy } { { Rev 1.4 10.7.2003 ã. 20:57:00 DBondzhev { NTLM AUthentication is working wiht Proxy servers now } { { Rev 1.3 4/30/2003 01:21:30 PM JPMugaas { Added ConnectTimeout property because ReadTimeout is problematic in HTTP with { Connect. Discussed that with Kudzu this morning. } { { Rev 1.2 06.3.2003 ã. 20:07:02 DBondzhev } { { Rev 1.1 01.2.2003 ã. 11:54:28 DBondzhev } { { Rev 1.0 2002.11.12 10:41:00 PM czhower } 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. NOTE: Initially only GET and POST will be supported. As time goes on more will be added. For other developers, please add the date and what you have done below. Initials: Hadi Hariri - HH Details of implementation ------------------------- 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. } interface uses Classes, IdException, IdAssignedNumbers, IdHeaderList, IdHTTPHeaderInfo, IdSSLOpenSSL, IdTCPConnection, IdTCPClient, IdURI, IdCookie, IdCookieManager, IdAuthentication , IdAuthenticationManager, IdMultipartFormData; type // TO DOCUMENTATION TEAM // ------------------------ // For internal use. No need of documentation // hmConnect - Used to connect trought CERN proxy to SSL enabled sites. TIdHTTPMethod = (hmHead, hmGet, hmPost, hmOptions, hmTrace, hmPut, hmDelete, hmConnect); TIdHTTPWhatsNext = (wnGoToURL, wnJustExit, wnDontKnow, wnReadAndGo, wnAuthRequest); TIdHTTPConnectionType = (ctNormal, ctSSL, ctProxy, ctSSLProxy); // Protocol options TIdHTTPOption = (hoInProcessAuth, hoKeepOrigProtocol, hoForceEncodeParams); TIdHTTPOptions = set of TIdHTTPOption; // Must be documented TIdHTTPProtocolVersion = (pv1_0, pv1_1); TIdHTTPOnHeadersAvailable = procedure(Sender: TObject; AHeaders: TIdHeaderList; var VContinue: Boolean) of object; TIdHTTPOnRedirectEvent = procedure(Sender: TObject; var dest: string; var NumRedirect: Integer; var Handled: boolean; var VMethod: TIdHTTPMethod) 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_HandleRedirects = False; 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 FHTTP: TIdCustomHTTP; FResponseCode: Integer; FResponseText: string; FKeepAlive: Boolean; FContentStream: TStream; FResponseVersion: TIdHTTPProtocolVersion; // function GetKeepAlive: Boolean; function GetResponseCode: Integer; public constructor Create(AParent: TIdCustomHTTP); reintroduce; virtual; property KeepAlive: Boolean read GetKeepAlive write FKeepAlive; property ResponseText: string read FResponseText write FResponseText; 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 FHTTP: TIdCustomHTTP; FURL: string; FMethod: TIdHTTPMethod; FSourceStream: TStream; FUseProxy: TIdHTTPConnectionType; 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; end; TIdHTTPProtocol = class(TObject) FHTTP: TIdCustomHTTP; FRequest: TIdHTTPRequest; FResponse: TIdHTTPResponse; public constructor Create(AConnection: TIdCustomHTTP); destructor Destroy; override; function ProcessResponse: TIdHTTPWhatsNext; procedure BuildAndSendRequest(AURI: TIdURI); procedure RetrieveHeaders; property Request: TIdHTTPRequest read FRequest; property Response: TIdHTTPResponse read FResponse; end; TIdCustomHTTP = class(TIdTCPClient) protected FCookieManager: TIdCookieManager; FFreeOnDestroy: Boolean; {Max retries for authorization} FMaxAuthRetries: Integer; FAllowCookies: Boolean; FAuthenticationManager: TIdAuthenticationManager; FProtocolVersion: TIdHTTPProtocolVersion; {this is an internal counter for redirercts} 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; FConnectTimeout : Integer; // procedure SetHost(const Value: string); override; procedure SetPort(const Value: integer); override; procedure SetAuthenticationManager(const 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(AResponse: TIdHTTPResponse); procedure PrepareRequest(ARequest: TIdHTTPRequest); procedure ConnectToHost(ARequest: TIdHTTPRequest; AResponse: TIdHTTPResponse); function GetResponseHeaders: TIdHTTPResponse; function GetRequestHeaders: TIdHTTPRequest; procedure SetRequestHeaders(const Value: TIdHTTPRequest); procedure EncodeRequestParams(const AStrings: TStrings); function SetRequestParams(const AStrings: TStrings): string; procedure CheckAndConnect(AResponse: TIdHTTPResponse); procedure DoOnDisconnected; override; function GetAuthRetries: Integer; function GetProxyAuthRetries: Integer; property InternalAuthRetries: Integer read GetAuthRetries; property InternalProxyAuthRetries: Integer read GetProxyAuthRetries; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure DoRequest(const AMethod: TIdHTTPMethod; AURL: string; const ASource, AResponseContent: TStream); virtual; procedure Options(AURL: string); overload; procedure Get(AURL: string; const AResponseContent: TStream); overload; function Get(AURL: string): string; overload; procedure Trace(AURL: string; const AResponseContent: TStream); overload; function Trace(AURL: string): string; overload; procedure Head(AURL: string); function Post(AURL: string; const ASource: TStrings): string; overload; function Post(AURL: string; const ASource: TStream): string; overload; function Post(AURL: string; const ASource: TIdMultiPartFormDataStream): string; overload; procedure Post(AURL: string; const ASource: TStrings; const AResponseContent: TStream); overload; {Post data provided by a stream, this is for submitting data to a server} procedure Post(AURL: string; const ASource, AResponseContent: TStream); overload; procedure Post(AURL: string; const ASource: TIdMultiPartFormDataStream; AResponseContent: TStream); overload; // function Put(AURL: string; const ASource: TStream): string; overload; procedure Put(AURL: string; const ASource, AResponseContent: TStream); overload; {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 GetResponseHeaders; { This is the last processed URL } property URL: TIdURI read FURI; // Num retries for Authentication property AuthRetries: Integer read FMaxAuthRetries write FMaxAuthRetries default 3; 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; {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; property ProxyParams: TIdProxyConnectionInfo read FProxyParameters write FProxyParameters; property Request: TIdHTTPRequest read GetRequestHeaders write SetRequestHeaders; 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; property ConnectTimeout : Integer read FConnectTimeout write FConnectTimeout default IdDefTimeout; end; TIdHTTP = class(TIdCustomHTTP) published // Num retries for Authentication property AuthRetries; 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; property ConnectTimeout; end; EIdUnknownProtocol = class(EIdException); EIdHTTPProtocolException = class(EIdProtocolReplyError) 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, IdGlobal, IdComponent, IdCoderMIME, IdResourceStrings; const ProtocolVersionString: array[TIdHTTPProtocolVersion] of string = ('1.0', '1.1'); {do not localize} MethodString: array[TIdHTTPMethod] of String = ('HEAD', 'GET', 'POST', 'OPTIONS', 'TRACE', 'PUT', 'DELETE', 'CONNECT'); {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 } constructor TIdCustomHTTP.Create(AOwner: TComponent); begin FURI := TIdURI.Create(''); inherited Create(AOwner); Port := IdPORT_HTTP; FMaxAuthRetries := 3; AllowCookies := true; FFreeOnDestroy := false; FOptions := [hoForceEncodeParams]; FRedirectMax := Id_TIdHTTP_RedirectMax; FHandleRedirects := Id_TIdHTTP_HandleRedirects; // FProtocolVersion := Id_TIdHTTP_ProtocolVersion; FHTTPProto := TIdHTTPProtocol.Create(self); FProxyParameters := TIdProxyConnectionInfo.Create; FProxyParameters.Clear; FConnectTimeout := IdDefTimeout; end; destructor TIdCustomHTTP.Destroy; begin FreeAndNil(FHTTPProto); FreeAndNil(FURI); FreeAndNil(FProxyParameters); {if FFreeOnDestroy then begin FreeAndNil(FCookieManager); end;} inherited Destroy; end; procedure TIdCustomHTTP.Options(AURL: string); begin DoRequest(hmOptions, AURL, nil, nil); end; procedure TIdCustomHTTP.Get(AURL: string; const AResponseContent: TStream); begin DoRequest(hmGet, AURL, nil, AResponseContent); end; procedure TIdCustomHTTP.Trace(AURL: string; const AResponseContent: TStream); begin DoRequest(hmTrace, AURL, nil, AResponseContent); end; procedure TIdCustomHTTP.Head(AURL: string); begin DoRequest(hmHead, AURL, nil, nil); end; procedure TIdCustomHTTP.Post(AURL: string; const 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. if Connected then begin Disconnect; end; OldProtocol := FProtocolVersion; // If hoKeepOrigProtocol is SET, is possible to assume that the developer // is sure in operations of the server if not (hoKeepOrigProtocol in FOptions) then FProtocolVersion := pv1_0; DoRequest(hmPost, AURL, ASource, AResponseContent); FProtocolVersion := OldProtocol; end; procedure TIdCustomHTTP.EncodeRequestParams(const AStrings: TStrings); var i: Integer; S: string; begin for i := 0 to AStrings.Count - 1 do begin S := AStrings.Names[i]; if Length(AStrings.Values[S]) > 0 then begin AStrings.Values[S] := TIdURI.ParamsEncode(AStrings.Values[S]); end; end; end; function TIdCustomHTTP.SetRequestParams(const AStrings: TStrings): string; begin if Assigned(AStrings) then begin if hoForceEncodeParams in FOptions then begin EncodeRequestParams(AStrings); end; if AStrings.Count > 1 then begin // break trailing CR&LF Result := StringReplace(Trim(AStrings.Text), sLineBreak, '&', [rfReplaceAll]) end else begin Result := Trim(AStrings.Text); end; end else begin Result := ''; end; end; procedure TIdCustomHTTP.Post(AURL: string; const ASource: TStrings; const AResponseContent: TStream); var LParams: TStringStream; begin // Usual posting request have default ContentType is application/x-www-form-urlencoded if (Request.ContentType = '') or (AnsiSameText(Request.ContentType, 'text/html')) then Request.ContentType := 'application/x-www-form-urlencoded'; LParams := TStringStream.Create(SetRequestParams(ASource)); try Post(AURL, LParams, AResponseContent); finally LParams.Free; end; end; function TIdCustomHTTP.Post(AURL: string; const ASource: TStrings): string; var LResponse: TStringStream; begin LResponse := TStringStream.Create(''); try Post(AURL, ASource, LResponse); finally Result := LResponse.DataString; LResponse.Free; end; end; function TIdCustomHTTP.Post(AURL: string; const ASource: TStream): string; var LResponse: TStringStream; begin LResponse := TStringStream.Create(''); try Post(AURL, ASource, LResponse); finally result := LResponse.DataString; LResponse.Free; end; end; procedure TIdCustomHTTP.Put(AURL: string; const ASource, AResponseContent: TStream); begin DoRequest(hmPut, AURL, ASource, AResponseContent); end; function TIdCustomHTTP.Put(AURL: string; const ASource: TStream): string; var LResponse: TStringStream; begin LResponse := TStringStream.Create(''); try Put(AURL, ASource, LResponse); finally result := LResponse.DataString; LResponse.Free; end; end; function TIdCustomHTTP.Get(AURL: string): string; var Stream: TMemoryStream; begin Stream := TMemoryStream.Create; try Get(AURL, Stream); finally if Stream.Size > 0 then // DO we have result? begin SetLength(result, Stream.Size); Move(PChar(Stream.Memory)^, result[1], Stream.Size); end; Stream.Free; end; end; function TIdCustomHTTP.Trace(AURL: string): string; var Stream: TStringStream; begin Stream := TStringStream.Create(''); try Trace(AURL, Stream); result := Stream.DataString; finally Stream.Free; end; end; function TIdCustomHTTP.DoOnRedirect(var Location: string; var VMethod: TIdHTTPMethod; RedirectCount: integer): boolean; begin result := HandleRedirects; if assigned(FOnRedirect) then begin FOnRedirect(self, Location, RedirectCount, result, VMethod); end; end; procedure TIdCustomHTTP.SetCookies(AURL: TIdURI; ARequest: TIdHTTPRequest); var S: string; begin if Assigned(FCookieManager) then begin // Send secure cookies only if we have Secured connection S := FCookieManager.GenerateCookieList(AURL, (IOHandler is TIdSSLIOHandlerSocket)); if Length(S) > 0 then begin ARequest.RawHeaders.Values['Cookie'] := S; end; 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; begin // First check to see if a Proxy has been specified. if Length(ProxyParams.ProxyServer) > 0 then begin if ((not AnsiSameText(Host, ProxyParams.ProxyServer)) or (Port <> ProxyParams.ProxyPort)) and (Connected) then begin Disconnect; end; FHost := ProxyParams.ProxyServer; FPort := ProxyParams.ProxyPort; if AnsiSameText(URL.Protocol, 'HTTPS') then begin Result := ctSSLProxy; if Assigned(IOHandler) then begin if not (IOHandler is TIdSSLIOHandlerSocket) then begin raise EIdIOHandlerPropInvalid.Create(RSIOHandlerPropInvalid); end else begin (IOHandler as TIdSSLIOHandlerSocket).PassThrough := true; end; end; end else begin Result := ctProxy; if Assigned(IOHandler) and (IOHandler is TIdSSLIOHandlerSocket) then begin (IOHandler as TIdSSLIOHandlerSocket).PassThrough := true; end; end; end else begin Result := ctNormal; if ((not AnsiSameText(Host, URL.Host)) or (Port <> StrToInt(URL.Port))) then begin if Connected then begin Disconnect; end; Host := URL.Host; Port := StrToInt(URL.Port); end; if AnsiSameText(URL.Protocol, 'HTTPS') then begin // Just check can we do SSL if not Assigned(IOHandler) or (not (IOHandler is TIdSSLIOHandlerSocket)) then raise EIdIOHandlerPropInvalid.Create(RSIOHandlerPropInvalid) else begin (IOHandler as TIdSSLIOHandlerSocket).PassThrough := false; result := ctSSL; end; end else begin if Assigned(IOHandler) then begin if (IOHandler is TIdSSLIOHandlerSocket) then begin (IOHandler as TIdSSLIOHandlerSocket).PassThrough := true; end; end; end; end; end; procedure TIdCustomHTTP.ReadResult(AResponse: TIdHTTPResponse); var Size: Integer; function ChunkSize: integer; var j: Integer; s: string; begin s := ReadLn; j := AnsiPos(' ', s); if j > 0 then begin s := Copy(s, 1, j - 1); end; Result := StrToIntDef('$' + s, 0); end; begin if Assigned(AResponse.ContentStream) then // Only for Get and Post begin if AResponse.ContentLength > 0 then // If chunked then this is also 0 begin try ReadStream(AResponse.ContentStream, AResponse.ContentLength); except on E: EIdConnClosedGracefully do end; end else begin if AnsiPos('chunked', LowerCase(AResponse.RawHeaders.Values['Transfer-Encoding'])) > 0 then {do not localize} begin // Chunked DoStatus(hsStatusText, [RSHTTPChunkStarted]); Size := ChunkSize; while Size > 0 do begin ReadStream(AResponse.ContentStream, Size); ReadLn; // blank line Size := ChunkSize; end; ReadLn; // blank line end else begin if not AResponse.HasContentLength then ReadStream(AResponse.ContentStream, -1, True); end; end; end; end; procedure TIdCustomHTTP.PrepareRequest(ARequest: TIdHTTPRequest); var LURI: TIdURI; begin LURI := TIdURI.Create(ARequest.URL); 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 else begin FURI.Protocol := 'http'; end; if Length(LURI.Port) > 0 then begin FURI.Port := LURI.Port; end else begin if AnsiSameText(LURI.Protocol, 'http') then begin FURI.Port := IntToStr(IdPORT_HTTP); end else begin if AnsiSameText(LURI.Protocol, 'https') then begin FURI.Port := IntToStr(IdPORT_SSL); end else begin if Length(FURI.Port) > 0 then begin { FURI.Port:=FURI.Port; } // do nothing, as the port is already filled in. end else begin raise EIdUnknownProtocol.Create(''); end; end; end; end; // The URL part is not URL encoded at this place ARequest.URL := URL.Path + URL.Document + URL.Params; if ARequest.Method = hmOptions then begin if AnsiSameText(LURI.Document, '*') then begin ARequest.URL := LURI.Document; end; end; LURI.Free; // Free URI Object; // Check for valid HTTP request methods if ARequest.Method in [hmTrace, hmPut, hmOptions, hmDelete] then begin if ProtocolVersion <> pv1_1 then begin raise EIdException.Create('This request method is supported in HTTP 1.1'); end; end; if ARequest.Method in [hmPost, hmPut] then begin ARequest.ContentLength := ARequest.Source.Size; end else ARequest.ContentLength := -1; if FURI.Port <> IntToStr(IdPORT_HTTP) then ARequest.Host := FURI.Host + ':' + FURI.Port else ARequest.Host := FURI.Host; end; procedure TIdCustomHTTP.CheckAndConnect(AResponse: TIdHTTPResponse); begin if not AResponse.KeepAlive then begin Disconnect; end; CheckForGracefulDisconnect(false); if not Connected then try Connect(FConnectTimeout); except on E: EIdSSLProtocolReplyError do begin Disconnect; raise; end; end; end; procedure TIdCustomHTTP.ConnectToHost(ARequest: TIdHTTPRequest; AResponse: TIdHTTPResponse); var LLocalHTTP: TIdHTTPProtocol; begin ARequest.FUseProxy := SetHostAndPort; if ARequest.UseProxy = ctProxy then begin ARequest.URL := FURI.URI; end; case ARequest.UseProxy of ctNormal: if (ProtocolVersion = pv1_0) and (ARequest.Connection = '') then ARequest.Connection := 'keep-alive'; ctSSL, ctSSLProxy: ARequest.Connection := ''; ctProxy: if (ProtocolVersion = pv1_0) and (ARequest.Connection = '') then ARequest.ProxyConnection := 'keep-alive'; end; if ARequest.UseProxy = ctSSLProxy then begin LLocalHTTP := TIdHTTPProtocol.Create(Self); with LLocalHTTP do begin Request.UserAgent := ARequest.UserAgent; Request.Host := ARequest.Host; Request.ContentLength := ARequest.ContentLength; Request.Pragma := 'no-cache'; Request.URL := URL.Host + ':' + URL.Port; Request.Method := hmConnect; Request.ProxyConnection := 'keep-alive'; Response.ContentStream := TMemoryStream.Create; try try repeat CheckAndConnect(Response); BuildAndSendRequest(nil); Response.ResponseText := ReadLn; if Length(Response.ResponseText) = 0 then begin Response.ResponseText := 'HTTP/1.0 200 OK'; // Support for HTTP responses whithout Status line and headers Response.Connection := 'close'; end else begin RetrieveHeaders; ProcessCookies(LLocalHTTP.Request, LLocalHTTP.Response); end; if Response.ResponseCode = 200 then begin // Connection established (IOHandler as TIdSSLIOHandlerSocket).PassThrough := False; Break; end else begin ProcessResponse; end; until false; except raise; // TODO: Add property that will contain the error messages. end; finally LLocalHTTP.Response.ContentStream.Free; LLocalHTTP.Free; end; end; end else begin CheckAndConnect(AResponse); end; FHTTPProto.BuildAndSendRequest(URL); if (ARequest.Method in [hmPost, hmPut]) then begin WriteStream(ARequest.Source, True, false); end; end; procedure TIdCustomHTTP.DoRequest(const AMethod: TIdHTTPMethod; AURL: string; const ASource, AResponseContent: TStream); var LResponseLocation: Integer; begin if Assigned(AResponseContent) then begin LResponseLocation := AResponseContent.Position; end else LResponseLocation := 0; // Just to avoid the waringing message Request.URL := AURL; Request.Method := AMethod; Request.Source := ASource; Response.ContentStream := AResponseContent; try repeat Inc(FRedirectCount); PrepareRequest(Request); 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 repeat Response.ResponseText := ReadLn; FHTTPProto.RetrieveHeaders; ProcessCookies(Request, Response); until Response.ResponseCode <> 100; case FHTTPProto.ProcessResponse of wnAuthRequest: begin Dec(FRedirectCount); Request.URL := AURL; end; wnReadAndGo: begin ReadResult(Response); if Assigned(AResponseContent) then begin AResponseContent.Position := LResponseLocation; AResponseContent.Size := LResponseLocation; end; end; wnGoToURL: begin if Assigned(AResponseContent) then begin AResponseContent.Position := LResponseLocation; AResponseContent.Size := LResponseLocation; end; end; wnJustExit: begin break; end; wnDontKnow: // TODO: This is for temporary use. Will remove it for final release raise EIdException.Create('Undefined situation'); end; until false; finally if not Response.KeepAlive then begin Disconnect; end; end; FRedirectCount := 0; end; procedure TIdCustomHTTP.SetAllowCookies(AValue: Boolean); begin FAllowCookies := AValue; end; procedure TIdCustomHTTP.ProcessCookies(ARequest: TIdHTTPRequest; AResponse: TIdHTTPResponse); var Cookies, Cookies2: TStringList; i: Integer; begin Cookies := nil; Cookies2 := nil; try if not Assigned(FCookieManager) and AllowCookies then begin CookieManager := TIdCookieManager.Create(Self); FFreeOnDestroy := true; end; if Assigned(FCookieManager) then begin Cookies := TStringList.Create; Cookies2 := TStringList.Create; AResponse.RawHeaders.Extract('Set-cookie', Cookies); AResponse.RawHeaders.Extract('Set-cookie2', Cookies2); for i := 0 to Cookies.Count - 1 do CookieManager.AddCookie(Cookies[i], FURI.Host); for i := 0 to Cookies2.Count - 1 do CookieManager.AddCookie2(Cookies2[i], FURI.Host); end; finally FreeAndNil(Cookies); FreeAndNil(Cookies2); end; end; procedure TIdCustomHTTP.Notification(AComponent: TComponent; Operation: TOperation); begin inherited Notification(AComponent, Operation); if Operation = opRemove then begin if (AComponent = FCookieManager) then begin FCookieManager := nil; end; if AComponent = FAuthenticationManager then begin FAuthenticationManager := nil; end; end; end; procedure TIdCustomHTTP.SetCookieManager(ACookieManager: TIdCookieManager); begin if Assigned(FCookieManager) then begin if FFreeOnDestroy then begin FCookieManager.Free; end; end; FCookieManager := ACookieManager; FFreeOnDestroy := false; if Assigned(FCookieManager) then begin FCookieManager.FreeNotification(Self); end; end; function TIdCustomHTTP.DoOnAuthorization(ARequest: TIdHTTPRequest; AResponse: TIdHTTPResponse): Boolean; var i: Integer; S: string; Auth: TIdAuthenticationClass; begin if not Assigned(ARequest.Authentication) then begin // Find wich Authentication method is supported from us. Auth := nil; for i := 0 to AResponse.WWWAuthenticate.Count - 1 do begin S := AResponse.WWWAuthenticate[i]; Auth := FindAuthClass(Fetch(S)); if Auth <> nil then begin Break; end; end; if Auth = nil then begin Result := False; Exit; end; if Assigned(FOnSelectAuthorization) then begin OnSelectAuthorization(Self, Auth, AResponse.WWWAuthenticate); end; ARequest.Authentication := Auth.Create; end; // Clear password and reset autorization if previous failed {if (AResponse.FResponseCode = 401) then begin ARequest.Password := ''; ARequest.Authentication.Reset; end;} Result := Assigned(FOnAuthorization) or (hoInProcessAuth in HTTPOptions); if Result then begin with ARequest.Authentication do begin Username := ARequest.Username; Password := ARequest.Password; Params.Values['Authorization'] := Authentication; AuthParams := AResponse.WWWAuthenticate; end; Result := False; repeat case ARequest.Authentication.Next of wnAskTheProgram: begin // Ask the user porgram to supply us with authorization information if Assigned(FOnAuthorization) then begin ARequest.Authentication.UserName := ARequest.Username; ARequest.Authentication.Password := ARequest.Password; OnAuthorization(self, ARequest.Authentication, Result); if Result then begin ARequest.BasicAuthentication := True; ARequest.Username := ARequest.Authentication.UserName; ARequest.Password := ARequest.Authentication.Password; end else begin Break; end; end else begin Result := False; Break; end; end; wnDoRequest: begin Result := True; Break; end; wnFail: begin Result := False; Break; end; end; until False; end; end; function TIdCustomHTTP.DoOnProxyAuthorization(ARequest: TIdHTTPRequest; AResponse: TIdHTTPResponse): Boolean; var i: Integer; S: string; Auth: TIdAuthenticationClass; begin if not Assigned(ProxyParams.Authentication) then begin // Find which Authentication method is supported from us. for i := 0 to AResponse.ProxyAuthenticate.Count - 1 do begin S := AResponse.ProxyAuthenticate[i]; Auth := FindAuthClass(Fetch(S)); if Auth <> nil then begin Break; end; end; if Auth = nil then begin Result := False; Exit; end; if Assigned(FOnSelectProxyAuthorization) then begin OnSelectProxyAuthorization(self, Auth, AResponse.ProxyAuthenticate); end; ProxyParams.Authentication := Auth.Create; end; Result := Assigned(OnProxyAuthorization) or (hoInProcessAuth in HTTPOptions); // Clear password and reset autorization if previous failed {if (AResponse.FResponseCode = 407) then begin ProxyParams.ProxyPassword := ''; ProxyParams.Authentication.Reset; end;} if Result then begin with ProxyParams.Authentication do begin Username := ProxyParams.ProxyUsername; Password := ProxyParams.ProxyPassword; Params.Values['Authorization'] := Authentication; AuthParams := AResponse.ProxyAuthenticate; end; Result := false; repeat case ProxyParams.Authentication.Next of wnAskTheProgram: // Ask the user porgram to supply us with authorization information begin if Assigned(OnProxyAuthorization) then begin ProxyParams.Authentication.Username := ProxyParams.ProxyUsername; ProxyParams.Authentication.Password := ProxyParams.ProxyPassword; OnProxyAuthorization(self, ProxyParams.Authentication, result); if Result then begin ProxyParams.BasicAuthentication := true; ProxyParams.ProxyUsername := ProxyParams.Authentication.Username; ProxyParams.ProxyPassword := ProxyParams.Authentication.Password; end else begin Break; end; end else begin Result := False; Break; end; end; wnDoRequest: begin Result := True; Break; end; wnFail: begin Result := False; Break; end; end; until False; end; end; function TIdCustomHTTP.GetResponseCode: Integer; begin result := Response.ResponseCode; end; function TIdCustomHTTP.GetResponseText: string; begin result := Response.FResponseText; end; function TIdCustomHTTP.GetResponseHeaders: TIdHTTPResponse; begin result := FHTTPProto.Response; end; function TIdCustomHTTP.GetRequestHeaders: TIdHTTPRequest; begin result := FHTTPProto.Request; end; procedure TIdCustomHTTP.DoOnDisconnected; begin inherited DoOnDisconnected; if Assigned(Request.Authentication) and (Request.Authentication.CurrentStep = Request.Authentication.Steps) then begin if Assigned(AuthenticationManager) then begin AuthenticationManager.AddAuthentication(Request.Authentication, URL); end; Request.Authentication.Free; Request.Authentication := nil; end; if Assigned(ProxyParams.Authentication) and (ProxyParams.Authentication.CurrentStep = ProxyParams.Authentication.Steps) then begin ProxyParams.ProxyUsername := ''; ProxyParams.ProxyPassword := ''; ProxyParams.Authentication.Reset; end; end; procedure TIdCustomHTTP.SetAuthenticationManager(const Value: TIdAuthenticationManager); begin FAuthenticationManager := Value; if Assigned(FAuthenticationManager) then begin FAuthenticationManager.FreeNotification(self); end; 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.SetRequestHEaders(const Value: TIdHTTPRequest); begin FHTTPProto.Request.Assign(Value); end; procedure TIdCustomHTTP.Post(AURL: string; const ASource: TIdMultiPartFormDataStream; AResponseContent: TStream); begin Request.ContentType := ASource.RequestContentType; Post(AURL, TStream(ASource), AResponseContent); end; function TIdCustomHTTP.Post(AURL: string; const ASource: TIdMultiPartFormDataStream): string; begin Request.ContentType := ASource.RequestContentType; result := Post(AURL, TStream(ASource)); end; { TIdHTTPResponse } constructor TIdHTTPResponse.Create(AParent: TIdCustomHTTP); begin inherited Create; FHTTP := AParent; end; function TIdHTTPResponse.GetKeepAlive: Boolean; var S: string; i: TIdHTTPProtocolVersion; begin S := Copy(FResponseText, 6, 3); for i := Low(TIdHTtpProtocolVersion) to High(TIdHTtpProtocolVersion) do if AnsiSameText(ProtocolVersionString[i], S) then begin ResponseVersion := i; break; end; FHTTP.CheckForDisconnect(false); FKeepAlive := FHTTP.Connected; if FKeepAlive then case FHTTP.ProtocolVersion of pv1_1: // By default we assume that keep-alive is by default and will close the connection only there is "close" begin FKeepAlive := not (AnsiSameText(Trim(Connection), 'CLOSE') or AnsiSameText(Trim(ProxyConnection), 'CLOSE')); 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 := AnsiSameText(Trim(Connection), 'KEEP-ALIVE') or AnsiSameText(Trim(ProxyConnection), 'KEEP-ALIVE') {or ((ResponseVersion = pv1_1) and (Length(Trim(Connection)) = 0) and (Length(Trim(ProxyConnection)) = 0))}; end; end; result := FKeepAlive; end; function TIdHTTPResponse.GetResponseCode: Integer; var S: string; begin S := FResponseText; Fetch(S); S := Trim(S); FResponseCode := StrToIntDef(Fetch(S, ' ', False), -1); Result := FResponseCode; end; { TIdHTTPRequest } constructor TIdHTTPRequest.Create(AHTTP: TIdCustomHTTP); begin inherited Create; 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; begin Request.SetHeaders; FHTTP.ProxyParams.SetHeaders(Request.RawHeaders); if Assigned(AURI) then begin FHTTP.SetCookies(AURI, Request); end; // This is a wrokaround for some HTTP servers wich does not implement properly the HTTP protocol FHTTP.OpenWriteBuffer; try FHTTP.WriteLn(MethodString[Request.Method] + ' ' + Request.URL + ' HTTP/' + ProtocolVersionString[FHTTP.ProtocolVersion]); {do not localize} // write the headers for i := 0 to Request.RawHeaders.Count - 1 do if Length(Request.RawHeaders.Strings[i]) > 0 then FHTTP.WriteLn(Request.RawHeaders.Strings[i]); FHTTP.WriteLn(''); FHTTP.CloseWriteBuffer; except FHTTP.CancelWriteBuffer; raise; end; end; procedure TIdHTTPProtocol.RetrieveHeaders; var S: string; begin // Set the response headers // Clear headers // Don't use Capture. Response.RawHeaders.Clear; s := FHTTP.ReadLn; try while Length(s) > 0 do begin Response.RawHeaders.Add(S); s := FHTTP.ReadLn; end; except on E: EIdConnClosedGracefully do begin FHTTP.Disconnect; end; end; Response.ProcessHeaders; end; function TIdHTTPProtocol.ProcessResponse: TIdHTTPWhatsNext; procedure RaiseException; var LRespStream: TStringStream; LTempStream: TStream; LTemp: Integer; begin LTemp := FHTTP.ReadTimeout; FHTTP.ReadTimeout := 2000; // Lets wait 2 seconds for any kind of content LRespStream := TStringStream.Create(''); LTempStream := Response.ContentStream; Response.ContentStream := LRespStream; try FHTTP.ReadResult(Response); raise EIdHTTPProtocolException.CreateError(Response.ResponseCode, FHTTP.ResponseText, LRespStream.DataString); finally Response.ContentStream := LTempStream; LRespStream.Free; FHTTP.ReadTimeout := LTemp; end; end; procedure ReadContent; Var LTempResponse: TStringStream; LTempStream: TStream; begin LTempResponse := TStringStream.Create(''); LTempStream := Response.ContentStream; Response.ContentStream := LTempResponse; try FHTTP.ReadResult(Response); finally LTempResponse.Free; Response.ContentStream := LTempStream; end; end; function HeadersCanContinue: Boolean; begin Result := True; if Assigned(FHTTP.OnHeadersAvailable) then begin FHTTP.OnHeadersAvailable(FHTTP, Response.RawHeaders, Result); end; end; var LTemp: Integer; LLocation: string; LMethod: TIdHTTPMethod; LResponseDigit: Integer; LNeedAutorization: Boolean; 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; // force DoRequest() to disconnect the connection Result := wnJustExit; Exit; end; Result := wnDontKnow; LNeedAutorization := False; LResponseDigit := Response.ResponseCode div 100; // Handle Redirects if ((LResponseDigit = 3) and (Response.ResponseCode <> 304)) or (Length(Response.Location) > 0) then begin // LLocation := TIdURI.URLDecode(Response.Location); LLocation := Response.Location; if (FHTTP.FHandleRedirects) and (FHTTP.FRedirectCount < FHTTP.FRedirectMax) then begin LMethod := Request.Method; if FHTTP.DoOnRedirect(LLocation, LMethod, FHTTP.FRedirectCount) then begin Result := wnGoToURL; Request.URL := LLocation; Request.Method := LMethod; end else RaiseException; end else // Just fire the event begin LMethod := Request.Method; Result := wnJustExit; if not FHTTP.DoOnRedirect(LLocation, LMethod, FHTTP.FRedirectCount) then begin // If not Handled RaiseException; end else begin Response.Location := LLocation; end; 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 LTemp := FHTTP.ReadTimeout; FHTTP.ReadTimeout := 4000; // Lets wait 4 seconds for any kind of content try ReadContent; except end; FHTTP.ReadTimeout := LTemp; end; end else begin // 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 TIdSSLIOHandlerSocket) and Response.KeepAlive); end; if LResponseDigit <> 2 then begin result := wnGoToURL; case Response.ResponseCode of 401: begin // HTTP Server authorization requered if (FHTTP.InternalAuthRetries >= FHTTP.AuthRetries) or not FHTTP.DoOnAuthorization(Request, Response) then begin if Assigned(Request.Authentication) then Request.Authentication.Reset; RaiseException; end else if hoInProcessAuth in FHTTP.HTTPOptions then begin LNeedAutorization := True; end; end; 407: begin // Proxy Server authorization requered if (FHTTP.InternalProxyAuthRetries >= FHTTP.AuthRetries) or not FHTTP.DoOnProxyAuthorization(Request, Response) then begin if Assigned(FHTTP.ProxyParams.Authentication) then with FHTTP.ProxyParams do begin Authentication.Reset; ProxyUsername := ''; ProxyPassword := ''; end; RaiseException; end else begin if hoInProcessAuth in FHTTP.HTTPOptions then LNeedAutorization := True; end; end; else begin RaiseException; end; end; end; if FHTTP.Connected then begin if LNeedAutorization then begin // Read the content of Error message in temporary stream LTemp := FHTTP.ReadTimeout; FHTTP.ReadTimeout := 4000; // Lets wait 4 seconds for any kind of content try ReadContent; except end; FHTTP.ReadTimeout := LTemp; Result := wnAuthRequest end else if (Response.ResponseCode <> 204) then begin FHTTP.ReadResult(Response); Result := wnJustExit; end else begin Result := wnJustExit; end; end; end; end; function TIdCustomHTTP.GetAuthRetries: Integer; begin if Assigned(Request.Authentication) then begin Result := Request.Authentication.AuthRetries; end else begin Result := 0; end; end; function TIdCustomHTTP.GetProxyAuthRetries: Integer; begin if Assigned(ProxyParams.Authentication) then begin Result := ProxyParams.Authentication.AuthRetries; end else begin Result := 0; end; end; end.